diff --git a/browser/browse.m b/browser/browse.m index a46f9019a..ef3f2083b 100644 --- a/browser/browse.m +++ b/browser/browse.m @@ -1,4 +1,6 @@ %---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% % Copyright (C) 1998-2005 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. @@ -6,12 +8,12 @@ % browse - implements a very simple term browser. % There are a number of features that haven't been incorporated: -% - Scripting language that allows precise control over -% how types are printed. -% - User preferences, which use the scripting language -% to allow user control beyond the provided defaults. -% - Node expansion and contraction in the style of -% Windows Explorer. +% +% - Scripting language that allows precise control over +% how types are printed. +% - User preferences, which use the scripting language +% to allow user control beyond the provided defaults. +% - Node expansion and contraction in the style of Windows Explorer. % % authors: aet % stability: low @@ -27,120 +29,120 @@ :- import_module list. :- import_module std_util. - % The interactive term browser. The caller type will be `browse', and - % the default format for the `browse' caller type will be used. Since - % this predicate is exported to be used by C code, no browser term - % mode function can be supplied. - % -:- pred browse__browse_browser_term_no_modes(browser_term::in, - io__input_stream::in, io__output_stream::in, maybe(list(dir))::out, - browser_persistent_state::in, browser_persistent_state::out, - io::di, io::uo) is cc_multi. + % The interactive term browser. The caller type will be `browse', and + % the default format for the `browse' caller type will be used. Since + % this predicate is exported to be used by C code, no browser term + % mode function can be supplied. + % +:- pred browse_browser_term_no_modes(browser_term::in, + io__input_stream::in, io__output_stream::in, maybe(list(dir))::out, + browser_persistent_state::in, browser_persistent_state::out, + io::di, io::uo) is cc_multi. - % The interactive term browser. The caller type will be `browse' and - % the default format for the `browse' caller type will be used. - % -:- pred browse__browse_browser_term(browser_term::in, - io__input_stream::in, io__output_stream::in, - maybe(browser_mode_func)::in, maybe(list(dir))::out, - browser_persistent_state::in, browser_persistent_state::out, - io::di, io::uo) is cc_multi. + % The interactive term browser. The caller type will be `browse' and + % the default format for the `browse' caller type will be used. + % +:- pred browse_browser_term(browser_term::in, + io__input_stream::in, io__output_stream::in, + maybe(browser_mode_func)::in, maybe(list(dir))::out, + browser_persistent_state::in, browser_persistent_state::out, + io::di, io::uo) is cc_multi. - % Dump the term as an XML file and launch the XML browser specified - % by the xml_browser_cmd field in the browser_persistent_state. - % -:- pred browse__save_and_browse_browser_term_xml(browser_term::in, - io__output_stream::in, io__output_stream::in, - browser_persistent_state::in, io::di, io::uo) is cc_multi. + % Dump the term as an XML file and launch the XML browser specified + % by the xml_browser_cmd field in the browser_persistent_state. + % +:- pred save_and_browse_browser_term_xml(browser_term::in, + io__output_stream::in, io__output_stream::in, + browser_persistent_state::in, io::di, io::uo) is cc_multi. - % As above, except that the supplied format will override the default. - % Again, this is exported to C code, so the browser term mode function - % can't be supplied. - % -:- pred browse__browse_browser_term_format_no_modes(browser_term::in, - io__input_stream::in, io__output_stream::in, portray_format::in, - browser_persistent_state::in, browser_persistent_state::out, - io::di, io::uo) is cc_multi. + % As above, except that the supplied format will override the default. + % Again, this is exported to C code, so the browser term mode function + % can't be supplied. + % +:- pred browse_browser_term_format_no_modes(browser_term::in, + io__input_stream::in, io__output_stream::in, portray_format::in, + browser_persistent_state::in, browser_persistent_state::out, + io::di, io::uo) is cc_multi. - % As above, except that the supplied format will override the default. - % -:- pred browse__browse_browser_term_format(browser_term::in, - io__input_stream::in, io__output_stream::in, portray_format::in, - maybe(browser_mode_func)::in, - browser_persistent_state::in, browser_persistent_state::out, - io::di, io::uo) is cc_multi. + % As above, except that the supplied format will override the default. + % +:- pred browse_browser_term_format(browser_term::in, + io__input_stream::in, io__output_stream::in, portray_format::in, + maybe(browser_mode_func)::in, + browser_persistent_state::in, browser_persistent_state::out, + io::di, io::uo) is cc_multi. - % The browser interface for the external debugger. The caller type - % will be `browse', and the default format will be used. - % This version is exported for use in C code, so no browser term mode - % function can be supplied. - % -:- pred browse__browse_external_no_modes(T::in, io__input_stream::in, - io__output_stream::in, - browser_persistent_state::in, browser_persistent_state::out, - io::di, io::uo) is cc_multi. + % The browser interface for the external debugger. The caller type + % will be `browse', and the default format will be used. + % This version is exported for use in C code, so no browser term mode + % function can be supplied. + % +:- pred browse_external_no_modes(T::in, io__input_stream::in, + io__output_stream::in, + browser_persistent_state::in, browser_persistent_state::out, + io::di, io::uo) is cc_multi. - % The browser interface for the external debugger. The caller type - % will be `browse', and the default format will be used. - % -:- pred browse__browse_external(T::in, io__input_stream::in, - io__output_stream::in, maybe(browser_mode_func)::in, - browser_persistent_state::in, browser_persistent_state::out, - io::di, io::uo) is cc_multi. + % The browser interface for the external debugger. The caller type + % will be `browse', and the default format will be used. + % +:- pred browse_external(T::in, io__input_stream::in, + io__output_stream::in, maybe(browser_mode_func)::in, + browser_persistent_state::in, browser_persistent_state::out, + io::di, io::uo) is cc_multi. - % The non-interactive term browser. The caller type should be either - % `print' or `print_all'. The default portray format for that - % caller type is used. - % -:- pred browse__print_browser_term(browser_term::in, - io__output_stream::in, browse_caller_type::in, - browser_persistent_state::in, io::di, io::uo) is cc_multi. + % The non-interactive term browser. The caller type should be either + % `print' or `print_all'. The default portray format for that + % caller type is used. + % +:- pred print_browser_term(browser_term::in, + io__output_stream::in, browse_caller_type::in, + browser_persistent_state::in, io::di, io::uo) is cc_multi. - % As above, except that the supplied format will override the default. - % -:- pred browse__print_browser_term_format(browser_term::in, - io__output_stream::in, browse_caller_type::in, portray_format::in, - browser_persistent_state::in, io::di, io::uo) is cc_multi. + % As above, except that the supplied format will override the default. + % +:- pred print_browser_term_format(browser_term::in, + io__output_stream::in, browse_caller_type::in, portray_format::in, + browser_persistent_state::in, io::di, io::uo) is cc_multi. - % Estimate the total term size, in characters, - % We count the number of characters in the functor, - % plus two characters for each argument: "(" and ")" - % for the first, and ", " for each of the rest, - % plus the sizes of the arguments themselves. - % This is only approximate since it doesn't take into - % account all the special cases such as operators. - % - % This predicate returns not the estimated total term size, - % but the difference between the given maximum size the caller - % is interested in and the estimated total term size. - % This difference is positive if the term is smaller than the - % maximum and negative if it is bigger. If the difference is - % negative, term_size_left_from_max will return a negative difference - % but the value will usually not be accurate, since in such cases - % by definition the caller is not interested in the accurate value. + % Estimate the total term size, in characters, We count the number of + % characters in the functor, plus two characters for each argument: + % "(" and ")" for the first, and ", " for each of the rest, plus the + % sizes of the arguments themselves. This is only approximate since it + % doesn't take into account all the special cases such as operators. + % + % This predicate returns not the estimated total term size, + % but the difference between the given maximum size the caller + % is interested in and the estimated total term size. + % This difference is positive if the term is smaller than the + % maximum and negative if it is bigger. If the difference is + % negative, term_size_left_from_max will return a negative difference + % but the value will usually not be accurate, since in such cases + % by definition the caller is not interested in the accurate value. + % :- pred term_size_left_from_max(univ::in, int::in, int::out) is cc_multi. - :- pred browser_term_size_left_from_max(browser_term::in, - int::in, int::out) is cc_multi. + int::in, int::out) is cc_multi. %---------------------------------------------------------------------------% - % save_term_to_file(FileName, Format, BrowserTerm, Out, !IO): - % Save BrowserTerm to the file FileName. If there is an error, - % print an error message to Out. - % - % The format of the saved term can be influenced by the Format - % argument, but how this works is not specified. - + % save_term_to_file(FileName, Format, BrowserTerm, Out, !IO): + % + % Save BrowserTerm to the file FileName. If there is an error, + % print an error message to Out. + % + % The format of the saved term can be influenced by the Format + % argument, but how this works is not specified. + % :- pred save_term_to_file(string::in, string::in, browser_term::in, - io__output_stream::in, io::di, io::uo) is cc_multi. + io__output_stream::in, io::di, io::uo) is cc_multi. - % save_term_to_file_xml(FileName, BrowserTerm, Out, !IO): - % Save BrowserTerm to FileName as an XML document. If there - % is an error, print an error message to Out. - % + % save_term_to_file_xml(FileName, BrowserTerm, Out, !IO): + % + % Save BrowserTerm to FileName as an XML document. If there is an error, + % print an error message to Out. + % :- pred save_term_to_file_xml(string::in, browser_term::in, - io__output_stream::in, io::di, io::uo) is cc_multi. + io__output_stream::in, io::di, io::uo) is cc_multi. %---------------------------------------------------------------------------% @@ -170,25 +172,25 @@ % they are used in trace/mercury_trace_browser.c. % -:- pragma export(browse__browse_browser_term_no_modes(in, in, in, out, in, out, - di, uo), "ML_BROWSE_browse_browser_term"). -:- pragma export(browse__browse_browser_term_format_no_modes(in, in, in, in, - in, out, di, uo), "ML_BROWSE_browse_browser_term_format"). -:- pragma export(browse__browse_external_no_modes(in, in, in, in, out, di, uo), - "ML_BROWSE_browse_external"). -:- pragma export(browse__print_browser_term(in, in, in, in, di, uo), - "ML_BROWSE_print_browser_term"). -:- pragma export(browse__print_browser_term_format(in, in, in, in, in, di, uo), - "ML_BROWSE_print_browser_term_format"). +:- pragma export(browse_browser_term_no_modes(in, in, in, out, in, out, + di, uo), "ML_BROWSE_browse_browser_term"). +:- pragma export(browse_browser_term_format_no_modes(in, in, in, in, + in, out, di, uo), "ML_BROWSE_browse_browser_term_format"). +:- pragma export(browse_external_no_modes(in, in, in, in, out, di, uo), + "ML_BROWSE_browse_external"). +:- pragma export(print_browser_term(in, in, in, in, di, uo), + "ML_BROWSE_print_browser_term"). +:- pragma export(print_browser_term_format(in, in, in, in, in, di, uo), + "ML_BROWSE_print_browser_term_format"). :- pragma export(save_term_to_file(in, in, in, in, di, uo), - "ML_BROWSE_save_term_to_file"). + "ML_BROWSE_save_term_to_file"). :- pragma export(save_term_to_file_xml(in, in, in, di, uo), - "ML_BROWSE_save_term_to_file_xml"). + "ML_BROWSE_save_term_to_file_xml"). -:- pragma export(browse__save_and_browse_browser_term_xml(in, in, in, in, - di, uo), "ML_BROWSE_browse_term_xml"). +:- pragma export(save_and_browse_browser_term_xml(in, in, in, in, + di, uo), "ML_BROWSE_browse_term_xml"). %---------------------------------------------------------------------------% % @@ -200,15 +202,15 @@ % term_browser_response. :- type term_browser_response - ---> browser_str(string) - ; browser_int(int) - ; browser_nl - ; browser_end_command - ; browser_quit. + ---> browser_str(string) + ; browser_int(int) + ; browser_nl + ; browser_end_command + ; browser_quit. :- type debugger - ---> internal - ; external. + ---> internal + ; external. %---------------------------------------------------------------------------% % @@ -216,559 +218,538 @@ % save_term_to_file(FileName, _Format, BrowserTerm, OutStream, !IO) :- - % io__write_string(FileName, !IO), - % io__nl(!IO), - % io__write(BrowserTerm, !IO), - % io__nl(!IO), - io__tell(FileName, FileStreamRes, !IO), - ( - FileStreamRes = ok, - ( - BrowserTerm = plain_term(Term), - save_univ(0, Term, !IO), - io__nl(!IO) - ; - BrowserTerm = synthetic_term(Functor, Args, MaybeRes), - io__write_string(Functor, !IO), - io__write_string("(\n", !IO), - save_args(1, Args, !IO), - io__write_string("\n)\n", !IO), - ( - MaybeRes = no - ; - MaybeRes = yes(Result), - io__write_string("=\n", !IO), - save_univ(1, Result, !IO), - io__write_string("\n", !IO) - ) - ), - io__told(!IO) - ; - FileStreamRes = error(Error), - io__error_message(Error, Msg), - io__write_string(OutStream, Msg, !IO) - ). + % io__write_string(FileName, !IO), + % io__nl(!IO), + % io__write(BrowserTerm, !IO), + % io__nl(!IO), + io__tell(FileName, FileStreamRes, !IO), + ( + FileStreamRes = ok, + ( + BrowserTerm = plain_term(Term), + save_univ(0, Term, !IO), + io__nl(!IO) + ; + BrowserTerm = synthetic_term(Functor, Args, MaybeRes), + io__write_string(Functor, !IO), + io__write_string("(\n", !IO), + save_args(1, Args, !IO), + io__write_string("\n)\n", !IO), + ( + MaybeRes = no + ; + MaybeRes = yes(Result), + io__write_string("=\n", !IO), + save_univ(1, Result, !IO), + io__write_string("\n", !IO) + ) + ), + io__told(!IO) + ; + FileStreamRes = error(Error), + io__error_message(Error, Msg), + io__write_string(OutStream, Msg, !IO) + ). :- type xml_predicate_wrapper - ---> predicate( - predicate_name :: string, - predicate_arguments :: list(univ) - ). + ---> predicate( + predicate_name :: string, + predicate_arguments :: list(univ) + ). :- type xml_function_wrapper - ---> function( - function_name :: string, - function_arguments :: list(univ), - return_value :: univ - ). + ---> function( + function_name :: string, + function_arguments :: list(univ), + return_value :: univ + ). save_term_to_file_xml(FileName, BrowserTerm, OutStream, !IO) :- - maybe_save_term_to_file_xml(FileName, BrowserTerm, Result, !IO), - ( - Result = ok - ; - Result = error(Error), - io__error_message(Error, Msg), - io__write_string(OutStream, Msg, !IO), - io__nl(!IO) - ). + maybe_save_term_to_file_xml(FileName, BrowserTerm, Result, !IO), + ( + Result = ok + ; + Result = error(Error), + io__error_message(Error, Msg), + io__write_string(OutStream, Msg, !IO), + io__nl(!IO) + ). :- pred maybe_save_term_to_file_xml(string::in, browser_term::in, - io.res::out, io::di, io::uo) is cc_multi. + io.res::out, io::di, io::uo) is cc_multi. maybe_save_term_to_file_xml(FileName, BrowserTerm, FileStreamRes, !IO) :- - io__tell(FileName, FileStreamRes, !IO), - ( - FileStreamRes = ok, - ( - BrowserTerm = plain_term(Univ), - Term = univ_value(Univ), - term_to_xml.write_xml_doc_cc(Term, simple, - no_stylesheet, no_dtd, _, !IO) - ; - BrowserTerm = synthetic_term(Functor, Args, MaybeRes), - ( - MaybeRes = no, - PredicateTerm = predicate(Functor, Args), - term_to_xml.write_xml_doc_cc(PredicateTerm, - simple, no_stylesheet, no_dtd, _, !IO) - ; - MaybeRes = yes(Result), - FunctionTerm = function(Functor, Args, Result), - term_to_xml.write_xml_doc_cc(FunctionTerm, - simple, no_stylesheet, no_dtd, _, !IO) - ) - ), - io__told(!IO) - ; - FileStreamRes = error(_) - ). + io__tell(FileName, FileStreamRes, !IO), + ( + FileStreamRes = ok, + ( + BrowserTerm = plain_term(Univ), + Term = univ_value(Univ), + term_to_xml.write_xml_doc_cc(Term, simple, + no_stylesheet, no_dtd, _, !IO) + ; + BrowserTerm = synthetic_term(Functor, Args, MaybeRes), + ( + MaybeRes = no, + PredicateTerm = predicate(Functor, Args), + term_to_xml.write_xml_doc_cc(PredicateTerm, + simple, no_stylesheet, no_dtd, _, !IO) + ; + MaybeRes = yes(Result), + FunctionTerm = function(Functor, Args, Result), + term_to_xml.write_xml_doc_cc(FunctionTerm, + simple, no_stylesheet, no_dtd, _, !IO) + ) + ), + io__told(!IO) + ; + FileStreamRes = error(_) + ). -browse__save_and_browse_browser_term_xml(Term, OutStream, ErrStream, State, - !IO) :- - MaybeXMLBrowserCmd = State ^ xml_browser_cmd, - ( - MaybeXMLBrowserCmd = yes(CommandStr), - MaybeTmpFileName = State ^ xml_tmp_filename, - ( - MaybeTmpFileName = yes(TmpFileName), - io.write_string(OutStream, - "Saving term to XML file...\n", !IO), - maybe_save_term_to_file_xml(TmpFileName, Term, - SaveResult, !IO), - ( - SaveResult = ok, - launch_xml_browser(OutStream, ErrStream, - CommandStr, !IO) - ; - SaveResult = error(Error), - io.error_message(Error, Msg), - io.write_string(ErrStream, - "Error opening file `" ++ - TmpFileName ++ "': ", !IO), - io.write_string(ErrStream, Msg, !IO), - io.nl(!IO) - ) - ; - MaybeTmpFileName = no, - io.write_string(ErrStream, - "mdb: You need to issue a " ++ - "\"set xml_tmp_filename ''\" " ++ - " command first.\n", !IO) - ) - ; - MaybeXMLBrowserCmd = no, - io.write_string(ErrStream, "mdb: You need to issue a " ++ - "\"set xml_browser_cmd ''\" " ++ - " command first.\n", !IO) - ). +save_and_browse_browser_term_xml(Term, OutStream, ErrStream, State, !IO) :- + MaybeXMLBrowserCmd = State ^ xml_browser_cmd, + ( + MaybeXMLBrowserCmd = yes(CommandStr), + MaybeTmpFileName = State ^ xml_tmp_filename, + ( + MaybeTmpFileName = yes(TmpFileName), + io.write_string(OutStream, "Saving term to XML file...\n", !IO), + maybe_save_term_to_file_xml(TmpFileName, Term, + SaveResult, !IO), + ( + SaveResult = ok, + launch_xml_browser(OutStream, ErrStream, CommandStr, !IO) + ; + SaveResult = error(Error), + io.error_message(Error, Msg), + io.write_string(ErrStream, + "Error opening file `" ++ TmpFileName ++ "': ", !IO), + io.write_string(ErrStream, Msg, !IO), + io.nl(!IO) + ) + ; + MaybeTmpFileName = no, + io.write_string(ErrStream, "mdb: You need to issue a " ++ + "\"set xml_tmp_filename ''\" command first.\n", !IO) + ) + ; + MaybeXMLBrowserCmd = no, + io.write_string(ErrStream, "mdb: You need to issue a " ++ + "\"set xml_browser_cmd ''\" command first.\n", !IO) + ). :- pred launch_xml_browser(io.output_stream::in, io.output_stream::in, - string::in, io::di, io::uo) is det. + string::in, io::di, io::uo) is det. launch_xml_browser(OutStream, ErrStream, CommandStr, !IO) :- - io.write_string(OutStream, "Launching XML browser " - ++ "(this may take some time) ...\n", !IO), - % Flush the output stream, so output appears in the correct order - % for tests where the `cat' command is used as the XML browser. - io.flush_output(OutStream, !IO), - io.call_system_return_signal(CommandStr, Result, !IO), - ( - Result = ok(ExitStatus), - ( - ExitStatus = exited(ExitCode), - ( - ExitCode = 0 - -> - true - ; - io.write_string(ErrStream, - "mdb: The command `" ++ CommandStr ++ - "' terminated with a non-zero exit "++ - "code.\n", !IO) - ) - ; - ExitStatus = signalled(_), - io.write_string(ErrStream, "mdb: The browser " ++ - "was killed.\n", !IO) - ) - ; - Result = error(Error), - io.write_string(ErrStream, "mdb: Error launching browser" - ++ ": " ++ string.string(Error) ++ - ".\n", !IO) - ). + io.write_string(OutStream, "Launching XML browser " + ++ "(this may take some time) ...\n", !IO), + % Flush the output stream, so output appears in the correct order + % for tests where the `cat' command is used as the XML browser. + io.flush_output(OutStream, !IO), + io.call_system_return_signal(CommandStr, Result, !IO), + ( + Result = ok(ExitStatus), + ( + ExitStatus = exited(ExitCode), + ( + ExitCode = 0 + -> + true + ; + io.write_string(ErrStream, + "mdb: The command `" ++ CommandStr ++ + "' terminated with a non-zero exit code.\n", !IO) + ) + ; + ExitStatus = signalled(_), + io.write_string(ErrStream, "mdb: The browser was killed.\n", !IO) + ) + ; + Result = error(Error), + io.write_string(ErrStream, "mdb: Error launching browser: " + ++ string.string(Error) ++ ".\n", !IO) + ). :- pred save_univ(int::in, univ::in, io::di, io::uo) is cc_multi. save_univ(Indent, Univ, !IO) :- - save_term(Indent, univ_value(Univ), !IO). + save_term(Indent, univ_value(Univ), !IO). :- pred save_term(int::in, T::in, io::di, io::uo) is cc_multi. save_term(Indent, Term, !IO) :- - ( dynamic_cast_to_list(Term, List) -> - ( - List = [], - write_indent(Indent, !IO), - io__write_string("[]", !IO) - ; - List = [_ | _], - MakeUniv = (func(Element) = (ElementUniv) :- - ElementUniv = univ(Element) - ), - Univs = list__map(MakeUniv, List), - write_indent(Indent, !IO), - io__write_string("[\n", !IO), - save_args(Indent + 1, Univs, !IO), - io__write_string("\n", !IO), - write_indent(Indent, !IO), - io__write_string("]", !IO) - ) - ; - deconstruct_cc(Term, Functor, _Arity, Args), - write_indent(Indent, !IO), - io__write_string(Functor, !IO), - ( - Args = [] - ; - Args = [_ | _], - io__write_string("(\n", !IO), - save_args(Indent + 1, Args, !IO), - io__write_string("\n", !IO), - write_indent(Indent, !IO), - io__write_string(")", !IO) - ) - ). + ( dynamic_cast_to_list(Term, List) -> + ( + List = [], + write_indent(Indent, !IO), + io__write_string("[]", !IO) + ; + List = [_ | _], + MakeUniv = (func(Element) = (ElementUniv) :- + ElementUniv = univ(Element) + ), + Univs = list__map(MakeUniv, List), + write_indent(Indent, !IO), + io__write_string("[\n", !IO), + save_args(Indent + 1, Univs, !IO), + io__write_string("\n", !IO), + write_indent(Indent, !IO), + io__write_string("]", !IO) + ) + ; + deconstruct_cc(Term, Functor, _Arity, Args), + write_indent(Indent, !IO), + io__write_string(Functor, !IO), + ( + Args = [] + ; + Args = [_ | _], + io__write_string("(\n", !IO), + save_args(Indent + 1, Args, !IO), + io__write_string("\n", !IO), + write_indent(Indent, !IO), + io__write_string(")", !IO) + ) + ). :- some [T2] pred dynamic_cast_to_list(T1::in, list(T2)::out) is semidet. dynamic_cast_to_list(X, L) :- - % The code of this predicate is copied from pprint.m. - [ArgTypeDesc] = type_args(type_of(X)), - (_ `with_type` ArgType) `has_type` ArgTypeDesc, - dynamic_cast(X, L `with_type` list(ArgType)). + % The code of this predicate is copied from pprint.m. + [ArgTypeDesc] = type_args(type_of(X)), + (_ `with_type` ArgType) `has_type` ArgTypeDesc, + dynamic_cast(X, L `with_type` list(ArgType)). :- pred save_args(int::in, list(univ)::in, io::di, io::uo) is cc_multi. save_args(_Indent, [], !IO). save_args(Indent, [Univ | Univs], !IO) :- - save_univ(Indent, Univ, !IO), - ( - Univs = [] - ; - Univs = [_ | _], - io__write_string(",\n", !IO), - save_args(Indent, Univs, !IO) - ). + save_univ(Indent, Univ, !IO), + ( + Univs = [] + ; + Univs = [_ | _], + io__write_string(",\n", !IO), + save_args(Indent, Univs, !IO) + ). :- pred write_indent(int::in, io::di, io::uo) is det. write_indent(Indent, !IO) :- - ( Indent =< 0 -> - true - ; - io__write_char(' ', !IO), - write_indent(Indent - 1, !IO) - ). + ( Indent =< 0 -> + true + ; + io__write_char(' ', !IO), + write_indent(Indent - 1, !IO) + ). %---------------------------------------------------------------------------% % % Non-interactive display % -browse__print_browser_term(Term, OutputStream, Caller, State, !IO) :- - browse__print_common(Term, OutputStream, Caller, no, State, !IO). +print_browser_term(Term, OutputStream, Caller, State, !IO) :- + print_common(Term, OutputStream, Caller, no, State, !IO). -browse__print_browser_term_format(Term, OutputStream, Caller, Format, - State, !IO):- - browse__print_common(Term, OutputStream, Caller, yes(Format), - State, !IO). +print_browser_term_format(Term, OutputStream, Caller, Format, State, !IO):- + print_common(Term, OutputStream, Caller, yes(Format), State, !IO). -:- pred browse__print_common(browser_term::in, io__output_stream::in, - browse_caller_type::in, maybe(portray_format)::in, - browser_persistent_state::in, io::di, io::uo) is cc_multi. +:- pred print_common(browser_term::in, io__output_stream::in, + browse_caller_type::in, maybe(portray_format)::in, + browser_persistent_state::in, io::di, io::uo) is cc_multi. -browse__print_common(BrowserTerm, OutputStream, Caller, MaybeFormat, State, - !IO):- - Info = browser_info__init(BrowserTerm, Caller, MaybeFormat, no, State), - io__set_output_stream(OutputStream, OldStream, !IO), - browser_info__get_format(Info, Caller, MaybeFormat, Format), - % - % For plain terms, we assume that the variable name has been printed - % on the first part of the line. If the format is something other than - % `flat', then we need to start on the next line. - % - ( - BrowserTerm = plain_term(_), - Format \= flat - -> - io__nl(!IO) - ; - true - ), - portray(internal, Caller, no, Info, !IO), - io__set_output_stream(OldStream, _, !IO). +print_common(BrowserTerm, OutputStream, Caller, MaybeFormat, State, !IO):- + Info = browser_info__init(BrowserTerm, Caller, MaybeFormat, no, State), + io__set_output_stream(OutputStream, OldStream, !IO), + browser_info__get_format(Info, Caller, MaybeFormat, Format), + + % For plain terms, we assume that the variable name has been printed + % on the first part of the line. If the format is something other than + % `flat', then we need to start on the next line. + ( + BrowserTerm = plain_term(_), + Format \= flat + -> + io__nl(!IO) + ; + true + ), + portray(internal, Caller, no, Info, !IO), + io__set_output_stream(OldStream, _, !IO). %---------------------------------------------------------------------------% % % Interactive display % -browse__browse_browser_term_no_modes(Term, InputStream, OutputStream, - MaybeMark, !State, !IO) :- - browse_common(internal, Term, InputStream, OutputStream, no, no, - MaybeMark, !State, !IO). +browse_browser_term_no_modes(Term, InputStream, OutputStream, + MaybeMark, !State, !IO) :- + browse_common(internal, Term, InputStream, OutputStream, no, no, + MaybeMark, !State, !IO). -browse__browse_browser_term(Term, InputStream, OutputStream, MaybeModeFunc, - MaybeMark, !State, !IO) :- - browse_common(internal, Term, InputStream, OutputStream, no, - MaybeModeFunc, MaybeMark, !State, !IO). +browse_browser_term(Term, InputStream, OutputStream, MaybeModeFunc, + MaybeMark, !State, !IO) :- + browse_common(internal, Term, InputStream, OutputStream, no, + MaybeModeFunc, MaybeMark, !State, !IO). -browse__browse_browser_term_format_no_modes(Term, InputStream, OutputStream, - Format, !State, !IO) :- - browse_common(internal, Term, InputStream, OutputStream, yes(Format), - no, _, !State, !IO). +browse_browser_term_format_no_modes(Term, InputStream, OutputStream, + Format, !State, !IO) :- + browse_common(internal, Term, InputStream, OutputStream, yes(Format), + no, _, !State, !IO). -browse__browse_browser_term_format(Term, InputStream, OutputStream, - Format, MaybeModeFunc, !State, !IO) :- - browse_common(internal, Term, InputStream, OutputStream, yes(Format), - MaybeModeFunc, _, !State, !IO). +browse_browser_term_format(Term, InputStream, OutputStream, + Format, MaybeModeFunc, !State, !IO) :- + browse_common(internal, Term, InputStream, OutputStream, yes(Format), + MaybeModeFunc, _, !State, !IO). -browse__browse_external_no_modes(Term, InputStream, OutputStream, !State, !IO) - :- - browse_common(external, plain_term(univ(Term)), - InputStream, OutputStream, no, no, _, !State, !IO). +browse_external_no_modes(Term, InputStream, OutputStream, !State, !IO) :- + browse_common(external, plain_term(univ(Term)), + InputStream, OutputStream, no, no, _, !State, !IO). -browse__browse_external(Term, InputStream, OutputStream, MaybeModeFunc, !State, - !IO) :- - browse_common(external, plain_term(univ(Term)), - InputStream, OutputStream, no, MaybeModeFunc, _, !State, !IO). +browse_external(Term, InputStream, OutputStream, MaybeModeFunc, !State, !IO) :- + browse_common(external, plain_term(univ(Term)), + InputStream, OutputStream, no, MaybeModeFunc, _, !State, !IO). :- pred browse_common(debugger::in, browser_term::in, io__input_stream::in, - io__output_stream::in, maybe(portray_format)::in, - maybe(browser_mode_func)::in, maybe(list(dir))::out, - browser_persistent_state::in, browser_persistent_state::out, - io::di, io::uo) is cc_multi. + io__output_stream::in, maybe(portray_format)::in, + maybe(browser_mode_func)::in, maybe(list(dir))::out, + browser_persistent_state::in, browser_persistent_state::out, + io::di, io::uo) is cc_multi. browse_common(Debugger, Object, InputStream, OutputStream, MaybeFormat, - MaybeModeFunc, MaybeMark, !State, !IO) :- - Info0 = browser_info__init(Object, browse, MaybeFormat, MaybeModeFunc, - !.State), - io__set_input_stream(InputStream, OldInputStream, !IO), - io__set_output_stream(OutputStream, OldOutputStream, !IO), - % startup_message, - browse_main_loop(Debugger, Info0, Info, !IO), - io__set_input_stream(OldInputStream, _, !IO), - io__set_output_stream(OldOutputStream, _, !IO), - MaybeMark = Info ^ maybe_mark, - !:State = Info ^ state. + MaybeModeFunc, MaybeMark, !State, !IO) :- + Info0 = browser_info__init(Object, browse, MaybeFormat, MaybeModeFunc, + !.State), + io__set_input_stream(InputStream, OldInputStream, !IO), + io__set_output_stream(OutputStream, OldOutputStream, !IO), + % startup_message, + browse_main_loop(Debugger, Info0, Info, !IO), + io__set_input_stream(OldInputStream, _, !IO), + io__set_output_stream(OldOutputStream, _, !IO), + MaybeMark = Info ^ maybe_mark, + !:State = Info ^ state. :- pred browse_main_loop(debugger::in, browser_info::in, browser_info::out, - io::di, io::uo) is cc_multi. + io::di, io::uo) is cc_multi. browse_main_loop(Debugger, !Info, !IO) :- - ( - Debugger = internal, - prompt(Prompt), - parse__read_command(Prompt, Command, !IO) - ; - Debugger = external, - parse__read_command_external(Command, !IO) - ), - run_command(Debugger, Command, Quit, !Info, !IO), - ( - Quit = yes, - % write_string_debugger(Debugger, "quitting...\n", !IO) - ( - Debugger = external, - send_term_to_socket(browser_quit, !IO) - ; - Debugger = internal - ) - ; - Quit = no, - browse_main_loop(Debugger, !Info, !IO) - ). + ( + Debugger = internal, + parse__read_command(prompt, Command, !IO) + ; + Debugger = external, + parse__read_command_external(Command, !IO) + ), + run_command(Debugger, Command, Quit, !Info, !IO), + ( + Quit = yes, + % write_string_debugger(Debugger, "quitting...\n", !IO) + ( + Debugger = external, + send_term_to_socket(browser_quit, !IO) + ; + Debugger = internal + ) + ; + Quit = no, + browse_main_loop(Debugger, !Info, !IO) + ). :- pred startup_message(debugger::in, io::di, io::uo) is det. startup_message(Debugger) --> - write_string_debugger(Debugger, "-- Simple Mercury Term Browser.\n"), - write_string_debugger(Debugger, "-- Type \"help\" for help.\n\n"). + write_string_debugger(Debugger, "-- Simple Mercury Term Browser.\n"), + write_string_debugger(Debugger, "-- Type \"help\" for help.\n\n"). -:- pred prompt(string::out) is det. +:- func prompt = string. -prompt("browser> "). +prompt = "browser> ". :- pred run_command(debugger::in, command::in, bool::out, - browser_info::in, browser_info::out, io::di, io::uo) is cc_multi. + browser_info::in, browser_info::out, io::di, io::uo) is cc_multi. run_command(Debugger, Command, Quit, !Info, !IO) :- - % XXX The commands `set', `ls' and `print' should allow the format - % to be specified by an option. In each case we instead pass `no' to - % the respective handler. - ( - Command = empty, - Quit = no - ; - Command = unknown, - write_string_debugger(Debugger, - "Error: unknown command or syntax error.\n", !IO), - write_string_debugger(Debugger, - "Type \"help\" for help.\n", !IO), - Quit = no - ; - Command = help, - help(Debugger, !IO), - Quit = no - ; - Command = set, - show_settings(Debugger, !.Info, !IO), - Quit = no - ; - Command = set(MaybeOptionTable, Setting), - ( - MaybeOptionTable = ok(OptionTable), - set_browse_param(OptionTable, Setting, !Info) - ; - MaybeOptionTable = error(Msg), - write_string_debugger(Debugger, Msg, !IO) - ), - Quit = no - ; - Command = cd, - set_path(root_rel([]), !Info), - Quit = no - ; - Command = cd(Path), - change_dir(!.Info ^ dirs, Path, NewPwd), - deref_subterm(!.Info ^ term, NewPwd, [], Result), - ( - Result = deref_result(_), - !:Info = !.Info ^ dirs := NewPwd - ; - Result = deref_error(OKPath, ErrorDir), - report_deref_error(Debugger, OKPath, ErrorDir, !IO) - ), - Quit = no - ; - Command = print(PrintOption, MaybePath), - do_portray(Debugger, browse, PrintOption, !.Info, - MaybePath, !IO), - Quit = no - ; - Command = pwd, - write_path(Debugger, !.Info ^ dirs, !IO), - nl_debugger(Debugger, !IO), - Quit = no - ; - Command = mark, - !:Info = !.Info ^ maybe_mark := yes(!.Info ^ dirs), - Quit = yes - ; - Command = mark(Path), - change_dir(!.Info ^ dirs, Path, NewPwd), - deref_subterm(!.Info ^ term, NewPwd, [], SubResult), - ( - SubResult = deref_result(_), - !:Info = !.Info ^ maybe_mark := yes(NewPwd), - Quit = yes - ; - SubResult = deref_error(_, _), - write_string_debugger(Debugger, - "error: cannot mark subterm\n", !IO), - Quit = no - ) - ; - Command = mode_query, - MaybeModeFunc = !.Info ^ maybe_mode_func, - write_term_mode_debugger(Debugger, MaybeModeFunc, - !.Info ^ dirs, !IO), - Quit = no - ; - Command = mode_query(Path), - change_dir(!.Info ^ dirs, Path, NewPwd), - MaybeModeFunc = !.Info ^ maybe_mode_func, - write_term_mode_debugger(Debugger, MaybeModeFunc, NewPwd, !IO), - Quit = no - ; - Command = quit, - Quit = yes - ; - Command = display, - write_string_debugger(Debugger, - "command not yet implemented\n", !IO), - Quit = no - ; - Command = write, - write_string_debugger(Debugger, - "command not yet implemented\n", !IO), - Quit = no - ), - ( Debugger = external -> - send_term_to_socket(browser_end_command, !IO) - ; - true - ). + % XXX The commands `set', `ls' and `print' should allow the format + % to be specified by an option. In each case we instead pass `no' to + % the respective handler. + ( + Command = empty, + Quit = no + ; + Command = unknown, + write_string_debugger(Debugger, + "Error: unknown command or syntax error.\n", !IO), + write_string_debugger(Debugger, "Type \"help\" for help.\n", !IO), + Quit = no + ; + Command = help, + help(Debugger, !IO), + Quit = no + ; + Command = set, + show_settings(Debugger, !.Info, !IO), + Quit = no + ; + Command = set(MaybeOptionTable, Setting), + ( + MaybeOptionTable = ok(OptionTable), + set_browse_param(OptionTable, Setting, !Info) + ; + MaybeOptionTable = error(Msg), + write_string_debugger(Debugger, Msg, !IO) + ), + Quit = no + ; + Command = cd, + set_path(root_rel([]), !Info), + Quit = no + ; + Command = cd(Path), + change_dir(!.Info ^ dirs, Path, NewPwd), + deref_subterm(!.Info ^ term, NewPwd, [], Result), + ( + Result = deref_result(_), + !:Info = !.Info ^ dirs := NewPwd + ; + Result = deref_error(OKPath, ErrorDir), + report_deref_error(Debugger, OKPath, ErrorDir, !IO) + ), + Quit = no + ; + Command = print(PrintOption, MaybePath), + do_portray(Debugger, browse, PrintOption, !.Info, MaybePath, !IO), + Quit = no + ; + Command = pwd, + write_path(Debugger, !.Info ^ dirs, !IO), + nl_debugger(Debugger, !IO), + Quit = no + ; + Command = mark, + !:Info = !.Info ^ maybe_mark := yes(!.Info ^ dirs), + Quit = yes + ; + Command = mark(Path), + change_dir(!.Info ^ dirs, Path, NewPwd), + deref_subterm(!.Info ^ term, NewPwd, [], SubResult), + ( + SubResult = deref_result(_), + !:Info = !.Info ^ maybe_mark := yes(NewPwd), + Quit = yes + ; + SubResult = deref_error(_, _), + write_string_debugger(Debugger, "error: cannot mark subterm\n", + !IO), + Quit = no + ) + ; + Command = mode_query, + MaybeModeFunc = !.Info ^ maybe_mode_func, + write_term_mode_debugger(Debugger, MaybeModeFunc, !.Info ^ dirs, !IO), + Quit = no + ; + Command = mode_query(Path), + change_dir(!.Info ^ dirs, Path, NewPwd), + MaybeModeFunc = !.Info ^ maybe_mode_func, + write_term_mode_debugger(Debugger, MaybeModeFunc, NewPwd, !IO), + Quit = no + ; + Command = quit, + Quit = yes + ; + Command = display, + write_string_debugger(Debugger, "command not yet implemented\n", !IO), + Quit = no + ; + Command = write, + write_string_debugger(Debugger, + "command not yet implemented\n", !IO), + Quit = no + ), + ( + Debugger = external, + send_term_to_socket(browser_end_command, !IO) + ; + Debugger = internal + ). :- pred do_portray(debugger::in, browse_caller_type::in, - maybe(maybe_option_table(format_option))::in, browser_info::in, - maybe(path)::in, io::di, io::uo) is cc_multi. + maybe(maybe_option_table(format_option))::in, browser_info::in, + maybe(path)::in, io::di, io::uo) is cc_multi. -do_portray(Debugger, CallerType, MaybeMaybeOptionTable, Info, - MaybePath, !IO) :- - ( - MaybeMaybeOptionTable = no, - portray_maybe_path(Debugger, CallerType, no, Info, - MaybePath, !IO) - ; - MaybeMaybeOptionTable = yes(MaybeOptionTable), - ( - MaybeOptionTable = ok(OptionTable), - interpret_format_options(OptionTable, FormatResult), - ( - FormatResult = ok(MaybeFormat), - portray_maybe_path(Debugger, CallerType, - MaybeFormat, Info, MaybePath, !IO) - ; - FormatResult = error(Msg), - write_string_debugger(Debugger, Msg, !IO) - ) - ; - MaybeOptionTable = error(Msg), - write_string_debugger(Debugger, Msg, !IO) - ) - ). +do_portray(Debugger, CallerType, MaybeMaybeOptionTable, Info, MaybePath, + !IO) :- + ( + MaybeMaybeOptionTable = no, + portray_maybe_path(Debugger, CallerType, no, Info, MaybePath, !IO) + ; + MaybeMaybeOptionTable = yes(MaybeOptionTable), + ( + MaybeOptionTable = ok(OptionTable), + interpret_format_options(OptionTable, FormatResult), + ( + FormatResult = ok(MaybeFormat), + portray_maybe_path(Debugger, CallerType, MaybeFormat, Info, + MaybePath, !IO) + ; + FormatResult = error(Msg), + write_string_debugger(Debugger, Msg, !IO) + ) + ; + MaybeOptionTable = error(Msg), + write_string_debugger(Debugger, Msg, !IO) + ) + ). :- pred interpret_format_options(option_table(format_option)::in, - maybe_error(maybe(portray_format))::out) is det. + maybe_error(maybe(portray_format))::out) is det. interpret_format_options(OptionTable, MaybeMaybeFormat) :- - map__to_assoc_list(OptionTable, OptionAssocList), - list__filter_map(bool_format_option_is_true, OptionAssocList, - TrueFormatOptions), - ( - TrueFormatOptions = [], - MaybeMaybeFormat = ok(no) - ; - TrueFormatOptions = [FormatOption], - ( - FormatOption = flat, - Format = flat - ; - FormatOption = raw_pretty, - Format = raw_pretty - ; - FormatOption = pretty, - Format = pretty - ; - FormatOption = verbose, - Format = verbose - ), - MaybeMaybeFormat = ok(yes(Format)) - ; - TrueFormatOptions = [_, _ | _], - MaybeMaybeFormat = error("error: inconsistent format options") - ). + map__to_assoc_list(OptionTable, OptionAssocList), + list__filter_map(bool_format_option_is_true, OptionAssocList, + TrueFormatOptions), + ( + TrueFormatOptions = [], + MaybeMaybeFormat = ok(no) + ; + TrueFormatOptions = [FormatOption], + ( + FormatOption = flat, + Format = flat + ; + FormatOption = raw_pretty, + Format = raw_pretty + ; + FormatOption = pretty, + Format = pretty + ; + FormatOption = verbose, + Format = verbose + ), + MaybeMaybeFormat = ok(yes(Format)) + ; + TrueFormatOptions = [_, _ | _], + MaybeMaybeFormat = error("error: inconsistent format options") + ). :- pred bool_format_option_is_true(pair(format_option, option_data)::in, - format_option::out) is semidet. + format_option::out) is semidet. bool_format_option_is_true(Format - bool(yes), Format). :- pred set_browse_param(option_table(setting_option)::in, setting::in, - browser_info::in, browser_info::out) is det. + browser_info::in, browser_info::out) is det. set_browse_param(OptionTable, Setting, !Info) :- - browser_info.set_param(yes, OptionTable, Setting, !.Info ^ state, - NewState), - !:Info = !.Info ^ state := NewState. + browser_info.set_param(yes, OptionTable, Setting, !.Info ^ state, + NewState), + !:Info = !.Info ^ state := NewState. :- pred help(debugger::in, io::di, io::uo) is det. help(Debugger) --> - { string__append_list([ + { string__append_list([ "Commands are:\n", "\t[print|p|ls] [format_options] [path]\n", "\t -- print the specified subterm using the `browse' params\n", @@ -795,8 +776,8 @@ help(Debugger) --> "-- format ;\n", "-- Paths can be Unix-style or SICStus-style: /2/3/1 or ^2^3^1\n", "\n"], - HelpMessage) }, - write_string_debugger(Debugger, HelpMessage). + HelpMessage) }, + write_string_debugger(Debugger, HelpMessage). %---------------------------------------------------------------------------% % @@ -804,208 +785,207 @@ help(Debugger) --> % :- pred portray_maybe_path(debugger::in, browse_caller_type::in, - maybe(portray_format)::in, browser_info::in, - maybe(path)::in, io::di, io::uo) is cc_multi. + maybe(portray_format)::in, browser_info::in, + maybe(path)::in, io::di, io::uo) is cc_multi. portray_maybe_path(Debugger, Caller, MaybeFormat, Info, MaybePath, !IO) :- - ( - MaybePath = no, - portray(Debugger, Caller, MaybeFormat, Info, !IO) - ; - MaybePath = yes(Path), - portray_path(Debugger, Caller, MaybeFormat, Info, Path, !IO) - ). + ( + MaybePath = no, + portray(Debugger, Caller, MaybeFormat, Info, !IO) + ; + MaybePath = yes(Path), + portray_path(Debugger, Caller, MaybeFormat, Info, Path, !IO) + ). :- pred portray(debugger::in, browse_caller_type::in, - maybe(portray_format)::in, browser_info::in, - io::di, io::uo) is cc_multi. + maybe(portray_format)::in, browser_info::in, + io::di, io::uo) is cc_multi. portray(Debugger, Caller, MaybeFormat, Info, !IO) :- - browser_info__get_format(Info, Caller, MaybeFormat, Format), - browser_info__get_format_params(Info, Caller, Format, Params), - deref_subterm(Info ^ term, Info ^ dirs, [], SubResult), - ( - SubResult = deref_result(SubUniv), - ( - Format = flat, - portray_flat(Debugger, SubUniv, Params, !IO) - ; - Format = raw_pretty, - portray_raw_pretty(Debugger, SubUniv, Params, !IO) - ; - Format = verbose, - portray_verbose(Debugger, SubUniv, Params, !IO) - ; - Format = pretty, - portray_pretty(Debugger, SubUniv, Params, !IO) - ) - ; - SubResult = deref_error(OKPath, ErrorDir), - report_deref_error(Debugger, OKPath, ErrorDir, !IO) - % write_string_debugger(Debugger, "error: no such subterm") - ), - nl_debugger(Debugger, !IO). + browser_info__get_format(Info, Caller, MaybeFormat, Format), + browser_info__get_format_params(Info, Caller, Format, Params), + deref_subterm(Info ^ term, Info ^ dirs, [], SubResult), + ( + SubResult = deref_result(SubUniv), + ( + Format = flat, + portray_flat(Debugger, SubUniv, Params, !IO) + ; + Format = raw_pretty, + portray_raw_pretty(Debugger, SubUniv, Params, !IO) + ; + Format = verbose, + portray_verbose(Debugger, SubUniv, Params, !IO) + ; + Format = pretty, + portray_pretty(Debugger, SubUniv, Params, !IO) + ) + ; + SubResult = deref_error(OKPath, ErrorDir), + report_deref_error(Debugger, OKPath, ErrorDir, !IO) + % write_string_debugger(Debugger, "error: no such subterm") + ), + nl_debugger(Debugger, !IO). :- pred portray_path(debugger::in, browse_caller_type::in, - maybe(portray_format)::in, browser_info::in, path::in, - io::di, io::uo) is cc_multi. + maybe(portray_format)::in, browser_info::in, path::in, + io::di, io::uo) is cc_multi. portray_path(Debugger, Caller, MaybeFormat, Info0, Path, !IO) :- - set_path(Path, Info0, Info), - portray(Debugger, Caller, MaybeFormat, Info, !IO). + set_path(Path, Info0, Info), + portray(Debugger, Caller, MaybeFormat, Info, !IO). :- pred portray_flat(debugger::in, browser_term::in, format_params::in, - io::di, io::uo) is cc_multi. + io::di, io::uo) is cc_multi. portray_flat(Debugger, BrowserTerm, Params, !IO) :- - % - % io__write handles the special cases such as lists, - % operators, etc. better, so we prefer to use it if we - % can. However, io__write doesn't have a depth or size limit, - % so we need to check the size first; if the term is small - % enough, we use io__write (actually io__write_univ), otherwise - % we use term_to_string/4. - % - % XXX this ignores the maximum number of lines - % - browser_term_size_left_from_max(BrowserTerm, max_print_size, - RemainingSize), - ( RemainingSize >= 0 -> - portray_flat_write_browser_term(BrowserTerm, !IO) - ; - io__get_stream_db(StreamDb, !IO), - BrowserDb = browser_db(StreamDb), - browser_term_to_string(BrowserDb, BrowserTerm, Params ^ size, - Params ^ depth, Str), - write_string_debugger(Debugger, Str, !IO) - ). + % io__write handles the special cases such as lists, operators, etc better, + % so we prefer to use it if we can. However, io__write doesn't have + % a depth or size limit, so we need to check the size first; if the term + % is small enough, we use io__write (actually io__write_univ), otherwise + % we use term_to_string/4. + % + % XXX This ignores the maximum number of lines. + + browser_term_size_left_from_max(BrowserTerm, max_print_size, + RemainingSize), + ( RemainingSize >= 0 -> + portray_flat_write_browser_term(BrowserTerm, !IO) + ; + io__get_stream_db(StreamDb, !IO), + BrowserDb = browser_db(StreamDb), + browser_term_to_string(BrowserDb, BrowserTerm, Params ^ size, + Params ^ depth, Str), + write_string_debugger(Debugger, Str, !IO) + ). :- pred portray_flat_write_browser_term(browser_term::in, - io::di, io::uo) is cc_multi. + io::di, io::uo) is cc_multi. portray_flat_write_browser_term(plain_term(Univ), !IO) :- - io__output_stream(Stream, !IO), - io__write_univ(Stream, include_details_cc, Univ, !IO). + io__output_stream(Stream, !IO), + io__write_univ(Stream, include_details_cc, Univ, !IO). portray_flat_write_browser_term(synthetic_term(Functor, Args, MaybeReturn), - !IO) :- - io__write_string(Functor, !IO), - io__output_stream(Stream, !IO), - ( Args = [] -> - true - ; - io__write_string("(", !IO), - io__write_list(Args, ", ", write_univ_or_unbound(Stream), !IO), - io__write_string(")", !IO) - ), - ( - MaybeReturn = yes(Return), - io__write_string(" = ", !IO), - io__write_univ(Stream, include_details_cc, Return, !IO) - ; - MaybeReturn = no - ). + !IO) :- + io__write_string(Functor, !IO), + io__output_stream(Stream, !IO), + ( + Args = [] + ; + Args = [_ | _], + io__write_string("(", !IO), + io__write_list(Args, ", ", write_univ_or_unbound(Stream), !IO), + io__write_string(")", !IO) + ), + ( + MaybeReturn = yes(Return), + io__write_string(" = ", !IO), + io__write_univ(Stream, include_details_cc, Return, !IO) + ; + MaybeReturn = no + ). :- pred portray_verbose(debugger::in, browser_term::in, format_params::in, - io::di, io::uo) is cc_multi. + io::di, io::uo) is cc_multi. portray_verbose(Debugger, BrowserTerm, Params, !IO) :- - io__get_stream_db(StreamDb, !IO), - BrowserDb = browser_db(StreamDb), - browser_term_to_string_verbose(BrowserDb, BrowserTerm, Params ^ size, - Params ^ depth, Params ^ width, Params ^ lines, Str), - write_string_debugger(Debugger, Str, !IO). + io__get_stream_db(StreamDb, !IO), + BrowserDb = browser_db(StreamDb), + browser_term_to_string_verbose(BrowserDb, BrowserTerm, Params ^ size, + Params ^ depth, Params ^ width, Params ^ lines, Str), + write_string_debugger(Debugger, Str, !IO). :- pred portray_pretty(debugger::in, browser_term::in, format_params::in, - io::di, io::uo) is det. + io::di, io::uo) is det. portray_pretty(Debugger, BrowserTerm, Params, !IO) :- - browser_term_to_string_pretty(BrowserTerm, Params ^ width, - Params ^ depth, Str), - write_string_debugger(Debugger, Str, !IO). + browser_term_to_string_pretty(BrowserTerm, Params ^ width, + Params ^ depth, Str), + write_string_debugger(Debugger, Str, !IO). :- pred portray_raw_pretty(debugger::in, browser_term::in, format_params::in, - io::di, io::uo) is cc_multi. + io::di, io::uo) is cc_multi. portray_raw_pretty(Debugger, BrowserTerm, Params, !IO) :- - io__get_stream_db(StreamDb, !IO), - BrowserDb = browser_db(StreamDb), - sized_pretty__browser_term_to_string_line(BrowserDb, BrowserTerm, - Params ^ width, Params ^ lines, Str), - write_string_debugger(Debugger, Str, !IO). + io__get_stream_db(StreamDb, !IO), + BrowserDb = browser_db(StreamDb), + sized_pretty__browser_term_to_string_line(BrowserDb, BrowserTerm, + Params ^ width, Params ^ lines, Str), + write_string_debugger(Debugger, Str, !IO). - % The maximum estimated size for which we use `io__write'. + % The maximum estimated size for which we use `io__write'. + % :- func max_print_size = int. max_print_size = 60. term_size_left_from_max(Univ, MaxSize, RemainingSize) :- - ( MaxSize < 0 -> - RemainingSize = MaxSize - ; - deconstruct__limited_deconstruct_cc(univ_value(Univ), MaxSize, - MaybeFunctorArityArgs), - ( - MaybeFunctorArityArgs = yes({Functor, Arity, Args}), - string__length(Functor, FunctorSize), - % "()", plus Arity-1 times ", " - PrincipalSize = FunctorSize + Arity * 2, - MaxArgsSize = MaxSize - PrincipalSize, - list__foldl(term_size_left_from_max, - Args, MaxArgsSize, RemainingSize) - ; - MaybeFunctorArityArgs = no, - RemainingSize = -1 - ) - ; - RemainingSize = -1 - ). + ( MaxSize < 0 -> + RemainingSize = MaxSize + ; + deconstruct__limited_deconstruct_cc(univ_value(Univ), MaxSize, + MaybeFunctorArityArgs), + ( + MaybeFunctorArityArgs = yes({Functor, Arity, Args}), + string__length(Functor, FunctorSize), + % "()", plus Arity-1 times ", " + PrincipalSize = FunctorSize + Arity * 2, + MaxArgsSize = MaxSize - PrincipalSize, + list__foldl(term_size_left_from_max, Args, + MaxArgsSize, RemainingSize) + ; + MaybeFunctorArityArgs = no, + RemainingSize = -1 + ) + ; + RemainingSize = -1 + ). browser_term_size_left_from_max(BrowserTerm, MaxSize, RemainingSize) :- - ( - BrowserTerm = plain_term(Univ), - term_size_left_from_max(Univ, MaxSize, RemainingSize) - ; - BrowserTerm = synthetic_term(Functor, Args, MaybeReturn), - string__length(Functor, FunctorSize), - list__length(Args, Arity), - ( - MaybeReturn = yes(_), - % "()", " = ", plus Arity-1 times ", " - PrincipalSize = FunctorSize + Arity * 2 + 3 - ; - MaybeReturn = no, - % "()", plus Arity-1 times ", " - PrincipalSize = FunctorSize + Arity * 2 - ), - MaxArgsSize = MaxSize - PrincipalSize, - list__foldl(term_size_left_from_max, - Args, MaxArgsSize, RemainingSize) - ). + ( + BrowserTerm = plain_term(Univ), + term_size_left_from_max(Univ, MaxSize, RemainingSize) + ; + BrowserTerm = synthetic_term(Functor, Args, MaybeReturn), + string__length(Functor, FunctorSize), + list__length(Args, Arity), + ( + MaybeReturn = yes(_), + % "()", " = ", plus Arity-1 times ", " + PrincipalSize = FunctorSize + Arity * 2 + 3 + ; + MaybeReturn = no, + % "()", plus Arity-1 times ", " + PrincipalSize = FunctorSize + Arity * 2 + ), + MaxArgsSize = MaxSize - PrincipalSize, + list__foldl(term_size_left_from_max, Args, MaxArgsSize, RemainingSize) + ). :- pred write_univ_or_unbound(io__output_stream::in, univ::in, io::di, io::uo) - is cc_multi. + is cc_multi. write_univ_or_unbound(Stream, Univ, !IO) :- - ( univ_to_type(Univ, _ `with_type` unbound) -> - io__write_char(Stream, '_', !IO) - ; - io__write_univ(Stream, include_details_cc, Univ, !IO) - ). + ( univ_to_type(Univ, _ `with_type` unbound) -> + io__write_char(Stream, '_', !IO) + ; + io__write_univ(Stream, include_details_cc, Univ, !IO) + ). :- pred report_deref_error(debugger::in, list(dir)::in, dir::in, - io::di, io::uo) is det. + io::di, io::uo) is det. report_deref_error(Debugger, OKPath, ErrorDir, !IO) :- - write_string_debugger(Debugger, "error: ", !IO), - ( - OKPath = [_ | _], - Context = "in subdir " ++ dirs_to_string(OKPath) ++ ": ", - write_string_debugger(Debugger, Context, !IO) - ; - OKPath = [] - ), - Msg = "there is no subterm " ++ dir_to_string(ErrorDir) ++ "\n", - write_string_debugger(Debugger, Msg, !IO). + write_string_debugger(Debugger, "error: ", !IO), + ( + OKPath = [_ | _], + Context = "in subdir " ++ dirs_to_string(OKPath) ++ ": ", + write_string_debugger(Debugger, Context, !IO) + ; + OKPath = [] + ), + Msg = "there is no subterm " ++ dir_to_string(ErrorDir) ++ "\n", + write_string_debugger(Debugger, Msg, !IO). %---------------------------------------------------------------------------% % @@ -1013,323 +993,311 @@ report_deref_error(Debugger, OKPath, ErrorDir, !IO) :- % :- pred browser_term_to_string(browser_db::in, browser_term::in, - int::in, int::in, string::out) is cc_multi. + int::in, int::in, string::out) is cc_multi. browser_term_to_string(BrowserDb, BrowserTerm, MaxSize, MaxDepth, Str) :- - CurSize = 0, - CurDepth = 0, - browser_term_to_string_2(BrowserDb, BrowserTerm, - MaxSize, CurSize, _NewSize, MaxDepth, CurDepth, Str). + CurSize = 0, + CurDepth = 0, + browser_term_to_string_2(BrowserDb, BrowserTerm, + MaxSize, CurSize, _NewSize, MaxDepth, CurDepth, Str). - % Note: When the size limit is reached, we simply display - % further subterms compressed. This is consistent with the - % User's Guide, which describes the size limit as a "suggested - % maximum". + % Note: When the size limit is reached, we simply display further subterms + % compressed. This is consistent with the User's Guide, which describes + % the size limit as a "suggested maximum". + % :- pred browser_term_to_string_2(browser_db::in, browser_term::in, - int::in, int::in, int::out, int::in, int::in, string::out) is cc_multi. + int::in, int::in, int::out, int::in, int::in, string::out) is cc_multi. browser_term_to_string_2(BrowserDb, BrowserTerm, MaxSize, CurSize, NewSize, - MaxDepth, CurDepth, Str) :- - limited_deconstruct_browser_term_cc(BrowserDb, BrowserTerm, MaxSize, - MaybeFunctorArityArgs, MaybeReturn), - ( - CurSize < MaxSize, - CurDepth < MaxDepth, - MaybeFunctorArityArgs = yes({Functor, _Arity, Args}) - -> - browser_term_to_string_3(BrowserDb, Functor, Args, MaybeReturn, - MaxSize, CurSize, NewSize, MaxDepth, CurDepth, Str) - ; - browser_term_compress(BrowserDb, BrowserTerm, Str), - NewSize = CurSize - ). + MaxDepth, CurDepth, Str) :- + limited_deconstruct_browser_term_cc(BrowserDb, BrowserTerm, MaxSize, + MaybeFunctorArityArgs, MaybeReturn), + ( + CurSize < MaxSize, + CurDepth < MaxDepth, + MaybeFunctorArityArgs = yes({Functor, _Arity, Args}) + -> + browser_term_to_string_3(BrowserDb, Functor, Args, MaybeReturn, + MaxSize, CurSize, NewSize, MaxDepth, CurDepth, Str) + ; + browser_term_compress(BrowserDb, BrowserTerm, Str), + NewSize = CurSize + ). :- pred browser_term_to_string_3(browser_db::in, string::in, - list(univ)::in, maybe(univ)::in, int::in, int::in, int::out, - int::in, int::in, string::out) is cc_multi. + list(univ)::in, maybe(univ)::in, int::in, int::in, int::out, + int::in, int::in, string::out) is cc_multi. browser_term_to_string_3(BrowserDb, Functor, Args, MaybeReturn, - MaxSize, Size0, Size, MaxDepth, Depth0, Str) :- - ( - Functor = "[|]", - Args = [ListHead, ListTail], - MaybeReturn = no - -> - % For the purposes of size and depth, we treat lists as if - % they consist of one functor plus an argument for each - % element of the list. - Size1 = Size0 + 1, - Depth1 = Depth0 + 1, - browser_term_to_string_2(BrowserDb, plain_term(ListHead), - MaxSize, Size1, Size2, MaxDepth, Depth1, HeadStr), - list_tail_to_string_list(BrowserDb, ListTail, - MaxSize, Size2, Size, MaxDepth, Depth1, TailStrs), - list__append(TailStrs, ["]"], Strs), - string__append_list(["[", HeadStr | Strs], Str) - ; - Functor = "[]", - Args = [], - MaybeReturn = no - -> - Size = Size0 + 1, - Str = "[]" - ; - Size1 = Size0 + 1, - Depth1 = Depth0 + 1, - args_to_string_list(BrowserDb, Args, MaxSize, Size1, Size2, - MaxDepth, Depth1, ArgStrs), - BracketedArgsStr = bracket_string_list(ArgStrs), - ( - MaybeReturn = yes(Return), - browser_term_to_string_2(BrowserDb, plain_term(Return), - MaxSize, Size2, Size, MaxDepth, Depth1, - ReturnStr), - string__append_list([Functor, BracketedArgsStr, - " = ", ReturnStr], Str) - ; - MaybeReturn = no, - Size = Size2, - string__append_list([Functor, BracketedArgsStr], Str) - ) - ). + MaxSize, Size0, Size, MaxDepth, Depth0, Str) :- + ( + Functor = "[|]", + Args = [ListHead, ListTail], + MaybeReturn = no + -> + % For the purposes of size and depth, we treat lists as if they consist + % of one functor plus an argument for each element of the list. + Size1 = Size0 + 1, + Depth1 = Depth0 + 1, + browser_term_to_string_2(BrowserDb, plain_term(ListHead), + MaxSize, Size1, Size2, MaxDepth, Depth1, HeadStr), + list_tail_to_string_list(BrowserDb, ListTail, + MaxSize, Size2, Size, MaxDepth, Depth1, TailStrs), + list__append(TailStrs, ["]"], Strs), + string__append_list(["[", HeadStr | Strs], Str) + ; + Functor = "[]", + Args = [], + MaybeReturn = no + -> + Size = Size0 + 1, + Str = "[]" + ; + Size1 = Size0 + 1, + Depth1 = Depth0 + 1, + args_to_string_list(BrowserDb, Args, MaxSize, Size1, Size2, + MaxDepth, Depth1, ArgStrs), + BracketedArgsStr = bracket_string_list(ArgStrs), + ( + MaybeReturn = yes(Return), + browser_term_to_string_2(BrowserDb, plain_term(Return), + MaxSize, Size2, Size, MaxDepth, Depth1, ReturnStr), + string__append_list([Functor, BracketedArgsStr, " = ", ReturnStr], + Str) + ; + MaybeReturn = no, + Size = Size2, + string__append_list([Functor, BracketedArgsStr], Str) + ) + ). :- pred list_tail_to_string_list(browser_db::in, univ::in, - int::in, int::in, int::out, int::in, int::in, list(string)::out) - is cc_multi. + int::in, int::in, int::out, int::in, int::in, list(string)::out) + is cc_multi. list_tail_to_string_list(BrowserDb, TailUniv, MaxSize, Size0, Size, - MaxDepth, Depth0, TailStrs) :- - - % We want the limit to be at least two to ensure that the limited - % deconstruct won't fail for any list term. - Limit = max(MaxSize, 2), - limited_deconstruct_browser_term_cc(BrowserDb, plain_term(TailUniv), - Limit, MaybeFunctorArityArgs, MaybeReturn), - ( - MaybeFunctorArityArgs = yes({Functor, _Arity, Args}), - ( - Functor = "[]", - Args = [], - MaybeReturn = no - -> - Size = Size0, - TailStrs = [] - ; - Functor = "[|]", - Args = [ListHead, ListTail], - MaybeReturn = no - -> - ( - Size0 < MaxSize, - Depth0 < MaxDepth - -> - browser_term_to_string_2(BrowserDb, - plain_term(ListHead), - MaxSize, Size0, Size1, - MaxDepth, Depth0, HeadStr), - list_tail_to_string_list(BrowserDb, ListTail, - MaxSize, Size1, Size, MaxDepth, Depth0, - TailStrs0), - TailStrs = [", ", HeadStr | TailStrs0] - ; - Size = Size0, - TailStrs = [", ..."] - ) - ; - ( - Size0 < MaxSize, - Depth0 < MaxDepth - -> - browser_term_to_string_3(BrowserDb, - Functor, Args, MaybeReturn, - MaxSize, Size0, Size, - MaxDepth, Depth0, TailStr), - TailStrs = [" | ", TailStr] - ; - Size = Size0, - browser_term_compress(BrowserDb, - plain_term(TailUniv), - TailCompressedStr), - TailStrs = [" | ", TailCompressedStr] - ) - ) - ; - MaybeFunctorArityArgs = no, - Size = Size0, - browser_term_compress(BrowserDb, plain_term(TailUniv), - TailCompressedStr), - TailStrs = [" | ", TailCompressedStr] - ). + MaxDepth, Depth0, TailStrs) :- + % We want the limit to be at least two to ensure that the limited + % deconstruct won't fail for any list term. + Limit = max(MaxSize, 2), + limited_deconstruct_browser_term_cc(BrowserDb, plain_term(TailUniv), + Limit, MaybeFunctorArityArgs, MaybeReturn), + ( + MaybeFunctorArityArgs = yes({Functor, _Arity, Args}), + ( + Functor = "[]", + Args = [], + MaybeReturn = no + -> + Size = Size0, + TailStrs = [] + ; + Functor = "[|]", + Args = [ListHead, ListTail], + MaybeReturn = no + -> + ( + Size0 < MaxSize, + Depth0 < MaxDepth + -> + browser_term_to_string_2(BrowserDb, plain_term(ListHead), + MaxSize, Size0, Size1, MaxDepth, Depth0, HeadStr), + list_tail_to_string_list(BrowserDb, ListTail, MaxSize, + Size1, Size, MaxDepth, Depth0, TailStrs0), + TailStrs = [", ", HeadStr | TailStrs0] + ; + Size = Size0, + TailStrs = [", ..."] + ) + ; + ( + Size0 < MaxSize, + Depth0 < MaxDepth + -> + browser_term_to_string_3(BrowserDb, Functor, Args, MaybeReturn, + MaxSize, Size0, Size, MaxDepth, Depth0, TailStr), + TailStrs = [" | ", TailStr] + ; + Size = Size0, + browser_term_compress(BrowserDb, plain_term(TailUniv), + TailCompressedStr), + TailStrs = [" | ", TailCompressedStr] + ) + ) + ; + MaybeFunctorArityArgs = no, + Size = Size0, + browser_term_compress(BrowserDb, plain_term(TailUniv), + TailCompressedStr), + TailStrs = [" | ", TailCompressedStr] + ). :- pred args_to_string_list(browser_db::in, list(univ)::in, - int::in, int::in, int::out, int::in, int::in, list(string)::out) - is cc_multi. + int::in, int::in, int::out, int::in, int::in, list(string)::out) + is cc_multi. args_to_string_list(_BrowserDb, [], _MaxSize, CurSize, NewSize, - _MaxDepth, _CurDepth, Strs) :- - Strs = [], - NewSize = CurSize. + _MaxDepth, _CurDepth, Strs) :- + Strs = [], + NewSize = CurSize. args_to_string_list(BrowserDb, [Univ | Univs], MaxSize, CurSize, NewSize, - MaxDepth, CurDepth, Strs) :- - browser_term_to_string_2(BrowserDb, plain_term(Univ), - MaxSize, CurSize, NewSize1, MaxDepth, CurDepth, Str), - args_to_string_list(BrowserDb, Univs, MaxSize, NewSize1, NewSize, - MaxDepth, CurDepth, RestStrs), - Strs = [Str | RestStrs]. + MaxDepth, CurDepth, Strs) :- + browser_term_to_string_2(BrowserDb, plain_term(Univ), + MaxSize, CurSize, NewSize1, MaxDepth, CurDepth, Str), + args_to_string_list(BrowserDb, Univs, MaxSize, NewSize1, NewSize, + MaxDepth, CurDepth, RestStrs), + Strs = [Str | RestStrs]. :- func bracket_string_list(list(string)) = string. bracket_string_list(Args) = Str :- - ( Args = [] -> - Str = "" - ; - string__append_list(["(", comma_string_list(Args), ")"], Str) - ). + ( + Args = [], + Str = "" + ; + Args = [_ | _], + string__append_list(["(", comma_string_list(Args), ")"], Str) + ). :- func comma_string_list(list(string)) = string. comma_string_list(Args) = Str :- - ( - Args = [], - Str = "" - ; - Args = [S], - Str = S - ; - Args = [S1, S2 | Ss], - Rest = comma_string_list([S2 | Ss]), - string__append_list([S1, ", ", Rest], Str) - ). + ( + Args = [], + Str = "" + ; + Args = [S], + Str = S + ; + Args = [S1, S2 | Ss], + Rest = comma_string_list([S2 | Ss]), + string__append_list([S1, ", ", Rest], Str) + ). :- pred browser_term_compress(browser_db::in, browser_term::in, string::out) - is cc_multi. + is cc_multi. browser_term_compress(BrowserDb, BrowserTerm, Str) :- - functor_browser_term_cc(BrowserDb, BrowserTerm, Functor, Arity, IsFunc), - ( Arity = 0 -> - Str = Functor - ; - int_to_string(Arity, ArityStr), - ( - IsFunc = yes, - append_list([Functor, "/", ArityStr, "+1"], Str) - ; - IsFunc = no, - append_list([Functor, "/", ArityStr], Str) - ) - ). + functor_browser_term_cc(BrowserDb, BrowserTerm, Functor, Arity, IsFunc), + ( Arity = 0 -> + Str = Functor + ; + int_to_string(Arity, ArityStr), + ( + IsFunc = yes, + append_list([Functor, "/", ArityStr, "+1"], Str) + ; + IsFunc = no, + append_list([Functor, "/", ArityStr], Str) + ) + ). %---------------------------------------------------------------------------% -% -% Print using the pretty printer from the standard library. -% XXX the size of the term is not limited---the pretty printer -% provides no way of doing this. -% + % Print using the pretty printer from the standard library. + % XXX The size of the term is not limited -- the pretty printer + % provides no way of doing this. + % :- pred browser_term_to_string_pretty(browser_term::in, int::in, int::in, - string::out) is det. + string::out) is det. browser_term_to_string_pretty(plain_term(Univ), Width, MaxDepth, Str) :- - Value = univ_value(Univ), - Doc = to_doc(MaxDepth, Value), - Str = to_string(Width, Doc). + Value = univ_value(Univ), + Doc = to_doc(MaxDepth, Value), + Str = to_string(Width, Doc). browser_term_to_string_pretty(synthetic_term(Functor, Args, MaybeReturn), - Width, MaxDepth, Str) :- - Doc = synthetic_term_to_doc(MaxDepth, Functor, Args, MaybeReturn), - Str = to_string(Width, Doc). + Width, MaxDepth, Str) :- + Doc = synthetic_term_to_doc(MaxDepth, Functor, Args, MaybeReturn), + Str = to_string(Width, Doc). %---------------------------------------------------------------------------% -% -% Verbose printing. Tree layout with numbered branches. -% Numbering makes it easier to change to subterms. -% + % Verbose printing. Tree layout with numbered branches. + % Numbering makes it easier to change to subterms. + % :- pred browser_term_to_string_verbose(browser_db::in, browser_term::in, - int::in, int::in, int::in, int::in, string::out) is cc_multi. + int::in, int::in, int::in, int::in, string::out) is cc_multi. browser_term_to_string_verbose(BrowserDb, BrowserTerm, MaxSize, MaxDepth, - X, Y, Str) :- - CurSize = 0, - CurDepth = 0, - browser_term_to_string_verbose_2(BrowserDb, BrowserTerm, - MaxSize, CurSize, _NewSize, MaxDepth, CurDepth, Frame), - frame__clip(X-Y, Frame, ClippedFrame), - unlines(ClippedFrame, Str). + X, Y, Str) :- + CurSize = 0, + CurDepth = 0, + browser_term_to_string_verbose_2(BrowserDb, BrowserTerm, + MaxSize, CurSize, _NewSize, MaxDepth, CurDepth, Frame), + ClippedFrame = frame__clip(X-Y, Frame), + unlines(ClippedFrame, Str). :- pred browser_term_to_string_verbose_2(browser_db::in, browser_term::in, - int::in, int::in, int::out, int::in, int::in, frame::out) is cc_multi. + int::in, int::in, int::out, int::in, int::in, frame::out) is cc_multi. browser_term_to_string_verbose_2(BrowserDb, BrowserTerm, - MaxSize, CurSize, NewSize, MaxDepth, CurDepth, Frame) :- - limited_deconstruct_browser_term_cc(BrowserDb, BrowserTerm, MaxSize, - MaybeFunctorArityArgs, MaybeReturn), - ( - CurSize < MaxSize, - CurDepth < MaxDepth, - MaybeFunctorArityArgs = yes({Functor, _Arity, Args0}) - -> - % XXX we should consider formatting function terms differently. - ( - MaybeReturn = yes(Return), - list__append(Args0, [Return], Args) - ; - MaybeReturn = no, - Args = Args0 - ), - CurSize1 = CurSize + 1, - CurDepth1 = CurDepth + 1, - ArgNum = 1, - args_to_string_verbose_list(BrowserDb, Args, ArgNum, - MaxSize, CurSize1, NewSize, MaxDepth, CurDepth1, - ArgsFrame), - frame__vglue([Functor], ArgsFrame, Frame) - ; - browser_term_compress(BrowserDb, BrowserTerm, Line), - Frame = [Line], - NewSize = CurSize - ). + MaxSize, CurSize, NewSize, MaxDepth, CurDepth, Frame) :- + limited_deconstruct_browser_term_cc(BrowserDb, BrowserTerm, MaxSize, + MaybeFunctorArityArgs, MaybeReturn), + ( + CurSize < MaxSize, + CurDepth < MaxDepth, + MaybeFunctorArityArgs = yes({Functor, _Arity, Args0}) + -> + % XXX We should consider formatting function terms differently. + ( + MaybeReturn = yes(Return), + list__append(Args0, [Return], Args) + ; + MaybeReturn = no, + Args = Args0 + ), + CurSize1 = CurSize + 1, + CurDepth1 = CurDepth + 1, + ArgNum = 1, + args_to_string_verbose_list(BrowserDb, Args, ArgNum, + MaxSize, CurSize1, NewSize, MaxDepth, CurDepth1, ArgsFrame), + Frame = frame__vglue([Functor], ArgsFrame) + ; + browser_term_compress(BrowserDb, BrowserTerm, Line), + Frame = [Line], + NewSize = CurSize + ). :- pred args_to_string_verbose_list(browser_db::in, list(univ)::in, - int::in, int::in, int::in, int::out, int::in, int::in, frame::out) - is cc_multi. + int::in, int::in, int::in, int::out, int::in, int::in, frame::out) + is cc_multi. args_to_string_verbose_list(_BrowserDb, [], _ArgNum, - _MaxSize, CurSize, NewSize, _MaxDepth, _CurDepth, []) :- - NewSize = CurSize. + _MaxSize, CurSize, NewSize, _MaxDepth, _CurDepth, []) :- + NewSize = CurSize. args_to_string_verbose_list(BrowserDb, [Univ], ArgNum, - MaxSize, CurSize, NewSize, MaxDepth, CurDepth, Frame) :- - browser_term_to_string_verbose_2(BrowserDb, plain_term(Univ), MaxSize, - CurSize, NewSize, MaxDepth, CurDepth, TreeFrame), - % XXX: ArgNumS must have fixed length 2. - string__int_to_string(ArgNum, ArgNumS), - string__append_list([ArgNumS, "-"], LastBranchS), - frame__hglue([LastBranchS], TreeFrame, Frame). + MaxSize, CurSize, NewSize, MaxDepth, CurDepth, Frame) :- + browser_term_to_string_verbose_2(BrowserDb, plain_term(Univ), MaxSize, + CurSize, NewSize, MaxDepth, CurDepth, TreeFrame), + % XXX: ArgNumS must have fixed length 2. + string__int_to_string(ArgNum, ArgNumS), + string__append_list([ArgNumS, "-"], LastBranchS), + Frame = frame__hglue([LastBranchS], TreeFrame). args_to_string_verbose_list(BrowserDb, [Univ1, Univ2 | Univs], ArgNum, MaxSize, - CurSize, NewSize, MaxDepth, CurDepth, Frame) :- - browser_term_to_string_verbose_2(BrowserDb, plain_term(Univ1), - MaxSize, CurSize, NewSize1, MaxDepth, CurDepth, TreeFrame), - ArgNum1 = ArgNum + 1, - args_to_string_verbose_list(BrowserDb, [Univ2 | Univs], ArgNum1, - MaxSize, NewSize1, NewSize2, MaxDepth, CurDepth, - RestTreesFrame), - NewSize = NewSize2, - % XXX: ArgNumS must have fixed length 2. - string__int_to_string(ArgNum, ArgNumS), - string__append_list([ArgNumS, "-"], BranchFrameS), - frame__vsize(TreeFrame, Height), - Height1 = Height - 1, - list__duplicate(Height1, "|", VBranchFrame), - frame__vglue([BranchFrameS], VBranchFrame, LeftFrame), - frame__hglue(LeftFrame, TreeFrame, TopFrame), - frame__vglue(TopFrame, RestTreesFrame, Frame). + CurSize, NewSize, MaxDepth, CurDepth, Frame) :- + browser_term_to_string_verbose_2(BrowserDb, plain_term(Univ1), + MaxSize, CurSize, NewSize1, MaxDepth, CurDepth, TreeFrame), + ArgNum1 = ArgNum + 1, + args_to_string_verbose_list(BrowserDb, [Univ2 | Univs], ArgNum1, + MaxSize, NewSize1, NewSize2, MaxDepth, CurDepth, RestTreesFrame), + NewSize = NewSize2, + % XXX: ArgNumS must have fixed length 2. + string__int_to_string(ArgNum, ArgNumS), + string__append_list([ArgNumS, "-"], BranchFrameS), + Height = frame__vsize(TreeFrame) - 1, + list__duplicate(Height, "|", VBranchFrame), + LeftFrame = frame__vglue([BranchFrameS], VBranchFrame), + TopFrame = frame__hglue(LeftFrame, TreeFrame), + Frame = frame__vglue(TopFrame, RestTreesFrame). :- pred unlines(list(string)::in, string::out) is det. unlines([], ""). unlines([Line | Lines], Str) :- - string__append(Line, "\n", NLine), - unlines(Lines, Strs), - string__append(NLine, Strs, Str). + string__append(Line, "\n", NLine), + unlines(Lines, Strs), + string__append(NLine, Strs, Str). %---------------------------------------------------------------------------% % @@ -1339,163 +1307,157 @@ unlines([Line | Lines], Str) :- :- pred write_path(debugger::in, list(dir)::in, io::di, io::uo) is det. write_path(Debugger, [], !IO) :- - write_string_debugger(Debugger, "/", !IO). + write_string_debugger(Debugger, "/", !IO). write_path(Debugger, [Dir], !IO) :- - ( - Dir = parent, - write_string_debugger(Debugger, "/", !IO) - ; - Dir = child_num(N), - write_string_debugger(Debugger, "/", !IO), - write_int_debugger(Debugger, N, !IO) - ; - Dir = child_name(Name), - write_string_debugger(Debugger, "/", !IO), - write_string_debugger(Debugger, Name, !IO) - ). + ( + Dir = parent, + write_string_debugger(Debugger, "/", !IO) + ; + Dir = child_num(N), + write_string_debugger(Debugger, "/", !IO), + write_int_debugger(Debugger, N, !IO) + ; + Dir = child_name(Name), + write_string_debugger(Debugger, "/", !IO), + write_string_debugger(Debugger, Name, !IO) + ). write_path(Debugger, [Dir, Dir2 | Dirs], !IO) :- - write_path_2(Debugger, [Dir, Dir2 | Dirs], !IO). + write_path_2(Debugger, [Dir, Dir2 | Dirs], !IO). :- pred write_path_2(debugger::in, list(dir)::in, io::di, io::uo) is det. write_path_2(Debugger, [], !IO) :- - write_string_debugger(Debugger, "/", !IO). + write_string_debugger(Debugger, "/", !IO). write_path_2(Debugger, [Dir], !IO) :- - ( - Dir = parent, - write_string_debugger(Debugger, "/..", !IO) - ; - Dir = child_num(N), - write_string_debugger(Debugger, "/", !IO), - write_int_debugger(Debugger, N, !IO) - ; - Dir = child_name(Name), - write_string_debugger(Debugger, "/", !IO), - write_string_debugger(Debugger, Name, !IO) - ). + ( + Dir = parent, + write_string_debugger(Debugger, "/..", !IO) + ; + Dir = child_num(N), + write_string_debugger(Debugger, "/", !IO), + write_int_debugger(Debugger, N, !IO) + ; + Dir = child_name(Name), + write_string_debugger(Debugger, "/", !IO), + write_string_debugger(Debugger, Name, !IO) + ). write_path_2(Debugger, [Dir, Dir2 | Dirs], !IO) :- - ( - Dir = parent, - write_string_debugger(Debugger, "/..", !IO), - write_path_2(Debugger, [Dir2 | Dirs], !IO) - ; - Dir = child_num(N), - write_string_debugger(Debugger, "/", !IO), - write_int_debugger(Debugger, N, !IO), - write_path_2(Debugger, [Dir2 | Dirs], !IO) - ; - Dir = child_name(Name), - write_string_debugger(Debugger, "/", !IO), - write_string_debugger(Debugger, Name, !IO), - write_path_2(Debugger, [Dir2 | Dirs], !IO) - ). + ( + Dir = parent, + write_string_debugger(Debugger, "/..", !IO), + write_path_2(Debugger, [Dir2 | Dirs], !IO) + ; + Dir = child_num(N), + write_string_debugger(Debugger, "/", !IO), + write_int_debugger(Debugger, N, !IO), + write_path_2(Debugger, [Dir2 | Dirs], !IO) + ; + Dir = child_name(Name), + write_string_debugger(Debugger, "/", !IO), + write_string_debugger(Debugger, Name, !IO), + write_path_2(Debugger, [Dir2 | Dirs], !IO) + ). :- type deref_result(T) - ---> deref_result(T) - ; deref_error(list(dir), dir). + ---> deref_result(T) + ; deref_error(list(dir), dir). - % We assume a root-relative path. We assume Term is the entire term - % passed into browse/3, not a subterm. + % We assume a root-relative path. We assume Term is the entire term + % passed into browse/3, not a subterm. :- pred deref_subterm(browser_term::in, list(dir)::in, list(dir)::in, - deref_result(browser_term)::out) is det. + deref_result(browser_term)::out) is det. deref_subterm(BrowserTerm, Path, RevPath0, Result) :- - simplify_dirs(Path, SimplifiedPath), - ( - BrowserTerm = plain_term(Univ), - deref_subterm_2(Univ, SimplifiedPath, RevPath0, SubResult), - deref_result_univ_to_browser_term(SubResult, Result) - ; - BrowserTerm = synthetic_term(_Functor, Args, MaybeReturn), - ( - SimplifiedPath = [], - SubBrowserTerm = BrowserTerm, - Result = deref_result(SubBrowserTerm) - ; - SimplifiedPath = [Step | SimplifiedPathTail], - ( - ( - Step = child_num(N), - % The first argument of a non-array - % is numbered argument 1. - list__index1(Args, N, ArgUniv) - ; - Step = child_name(Name), - MaybeReturn = yes(ArgUniv), - ( Name = "r" - ; Name = "res" - ; Name = "result" - ) - ; - Step = parent, - error("deref_subterm: found parent") - ) - -> - deref_subterm_2(ArgUniv, SimplifiedPathTail, - [Step | RevPath0], SubResult), - deref_result_univ_to_browser_term(SubResult, - Result) - ; - Result = deref_error(list__reverse(RevPath0), - Step) - ) - ) - ). + simplify_dirs(Path, SimplifiedPath), + ( + BrowserTerm = plain_term(Univ), + deref_subterm_2(Univ, SimplifiedPath, RevPath0, SubResult), + deref_result_univ_to_browser_term(SubResult, Result) + ; + BrowserTerm = synthetic_term(_Functor, Args, MaybeReturn), + ( + SimplifiedPath = [], + SubBrowserTerm = BrowserTerm, + Result = deref_result(SubBrowserTerm) + ; + SimplifiedPath = [Step | SimplifiedPathTail], + ( + ( + Step = child_num(N), + % The first argument of a non-array + % is numbered argument 1. + list__index1(Args, N, ArgUniv) + ; + Step = child_name(Name), + MaybeReturn = yes(ArgUniv), + ( Name = "r" + ; Name = "res" + ; Name = "result" + ) + ; + Step = parent, + error("deref_subterm: found parent") + ) + -> + deref_subterm_2(ArgUniv, SimplifiedPathTail, + [Step | RevPath0], SubResult), + deref_result_univ_to_browser_term(SubResult, Result) + ; + Result = deref_error(list__reverse(RevPath0), Step) + ) + ) + ). :- pred deref_result_univ_to_browser_term(deref_result(univ)::in, - deref_result(browser_term)::out) is det. + deref_result(browser_term)::out) is det. deref_result_univ_to_browser_term(SubResult, Result) :- - ( - SubResult = deref_result(SubUniv), - SubBrowserTerm = plain_term(SubUniv), - Result = deref_result(SubBrowserTerm) - ; - SubResult = deref_error(OKPath, ErrorDir), - Result = deref_error(OKPath, ErrorDir) - ). + ( + SubResult = deref_result(SubUniv), + SubBrowserTerm = plain_term(SubUniv), + Result = deref_result(SubBrowserTerm) + ; + SubResult = deref_error(OKPath, ErrorDir), + Result = deref_error(OKPath, ErrorDir) + ). :- pred deref_subterm_2(univ::in, list(dir)::in, list(dir)::in, - deref_result(univ)::out) is det. + deref_result(univ)::out) is det. deref_subterm_2(Univ, Path, RevPath0, Result) :- - ( - Path = [], - Result = deref_result(Univ) - ; - Path = [Dir | Dirs], - ( - ( - Dir = child_num(N), - ( - TypeCtor = type_ctor(univ_type(Univ)), - type_ctor_name(TypeCtor) = "array", - type_ctor_module_name(TypeCtor) = - "array" - -> - % The first element of an array - % is at index zero. - ArgN = argument(univ_value(Univ), N) - ; - % The first argument of a non-array is - % numbered argument 1 by the user - % but argument 0 by std_util:argument. - ArgN = argument(univ_value(Univ), - N - 1) - ) - ; - Dir = child_name(Name), - ArgN = named_argument(univ_value(Univ), Name) - ; - Dir = parent, - error("deref_subterm_2: found parent") - ) - -> - deref_subterm_2(ArgN, Dirs, [Dir | RevPath0], Result) - ; - Result = deref_error(list__reverse(RevPath0), Dir) - ) - ). + ( + Path = [], + Result = deref_result(Univ) + ; + Path = [Dir | Dirs], + ( + ( + Dir = child_num(N), + ( + TypeCtor = type_ctor(univ_type(Univ)), + type_ctor_name(TypeCtor) = "array", + type_ctor_module_name(TypeCtor) = "array" + -> + % The first element of an array is at index zero. + ArgN = argument(univ_value(Univ), N) + ; + % The first argument of a non-array is numbered argument 1 + % by the user but argument 0 by deconstruct.argument. + ArgN = argument(univ_value(Univ), N - 1) + ) + ; + Dir = child_name(Name), + ArgN = named_argument(univ_value(Univ), Name) + ; + Dir = parent, + error("deref_subterm_2: found parent") + ) + -> + deref_subterm_2(ArgN, Dirs, [Dir | RevPath0], Result) + ; + Result = deref_error(list__reverse(RevPath0), Dir) + ) + ). %---------------------------------------------------------------------------% @@ -1506,31 +1468,31 @@ get_path(Info, root_rel(Info ^ dirs)). :- pred set_path(path::in, browser_info::in, browser_info::out) is det. set_path(NewPath, Info0, Info) :- - change_dir(Info0 ^ dirs, NewPath, NewDirs), - Info = Info0 ^ dirs := NewDirs. + change_dir(Info0 ^ dirs, NewPath, NewDirs), + Info = Info0 ^ dirs := NewDirs. :- pred change_dir(list(dir)::in, path::in, list(dir)::out) is det. change_dir(PwdDirs, Path, RootRelDirs) :- - ( - Path = root_rel(Dirs), - NewDirs = Dirs - ; - Path = dot_rel(Dirs), - list__append(PwdDirs, Dirs, NewDirs) - ), - simplify_dirs(NewDirs, RootRelDirs). + ( + Path = root_rel(Dirs), + NewDirs = Dirs + ; + Path = dot_rel(Dirs), + list__append(PwdDirs, Dirs, NewDirs) + ), + simplify_dirs(NewDirs, RootRelDirs). :- pred set_term(univ::in, browser_info::in, browser_info::out) is det. set_term(Term, Info0, Info) :- - set_browser_term(plain_term(Term), Info0, Info1), - % Display from the root term. - % This avoid errors due to dereferencing non-existent subterms. - set_path(root_rel([]), Info1, Info). + set_browser_term(plain_term(Term), Info0, Info1), + % Display from the root term. + % This avoid errors due to dereferencing non-existent subterms. + set_path(root_rel([]), Info1, Info). :- pred set_browser_term(browser_term::in, browser_info::in, browser_info::out) - is det. + is det. set_browser_term(BrowserTerm, Info, Info ^ term := BrowserTerm). @@ -1540,78 +1502,71 @@ set_browser_term(BrowserTerm, Info, Info ^ term := BrowserTerm). % :- pred show_settings(debugger::in, browser_info::in, - io::di, io::uo) is det. + io::di, io::uo) is det. show_settings(Debugger, Info, !IO) :- - show_settings_caller(Debugger, Info, browse, "Browser", !IO), - show_settings_caller(Debugger, Info, print, "Print", !IO), - show_settings_caller(Debugger, Info, print_all, "Printall", !IO), + show_settings_caller(Debugger, Info, browse, "Browser", !IO), + show_settings_caller(Debugger, Info, print, "Print", !IO), + show_settings_caller(Debugger, Info, print_all, "Printall", !IO), - write_string_debugger(Debugger, "Current path is: ", !IO), - write_path(Debugger, Info ^ dirs, !IO), - nl_debugger(Debugger, !IO), + write_string_debugger(Debugger, "Current path is: ", !IO), + write_path(Debugger, Info ^ dirs, !IO), + nl_debugger(Debugger, !IO), - write_string_debugger(Debugger, - "Number of I/O actions printed is: ", !IO), - write_int_debugger(Debugger, - get_num_printed_io_actions(Info ^ state), !IO), - nl_debugger(Debugger, !IO). + write_string_debugger(Debugger, + "Number of I/O actions printed is: ", !IO), + write_int_debugger(Debugger, + get_num_printed_io_actions(Info ^ state), !IO), + nl_debugger(Debugger, !IO). :- pred show_settings_caller(debugger::in, browser_info::in, - browse_caller_type::in, string::in, - io::di, io::uo) is det. + browse_caller_type::in, string::in, + io::di, io::uo) is det. show_settings_caller(Debugger, Info, Caller, CallerName, !IO) :- - browser_info__get_format(Info, Caller, no, Format), - write_string_debugger(Debugger, - CallerName ++ " default format: ", !IO), - print_format_debugger(Debugger, Format, !IO), - nl_debugger(Debugger, !IO), + browser_info__get_format(Info, Caller, no, Format), + write_string_debugger(Debugger, CallerName ++ " default format: ", !IO), + print_format_debugger(Debugger, Format, !IO), + nl_debugger(Debugger, !IO), - write_string_debugger(Debugger, - pad_right("", ' ', row_name_len), !IO), - write_string_debugger(Debugger, - pad_right("depth", ' ', depth_len), !IO), - write_string_debugger(Debugger, - pad_right("size", ' ', size_len), !IO), - write_string_debugger(Debugger, - pad_right("x clip", ' ', x_len), !IO), - write_string_debugger(Debugger, - pad_right("y clip", ' ', y_len), !IO), - nl_debugger(Debugger, !IO), + write_string_debugger(Debugger, pad_right("", ' ', row_name_len), !IO), + write_string_debugger(Debugger, pad_right("depth", ' ', depth_len), !IO), + write_string_debugger(Debugger, pad_right("size", ' ', size_len), !IO), + write_string_debugger(Debugger, pad_right("x clip", ' ', x_len), !IO), + write_string_debugger(Debugger, pad_right("y clip", ' ', y_len), !IO), + nl_debugger(Debugger, !IO), - show_settings_caller_format(Debugger, Info, Caller, CallerName, - flat, "flat", !IO), - show_settings_caller_format(Debugger, Info, Caller, CallerName, - verbose, "verbose", !IO), - show_settings_caller_format(Debugger, Info, Caller, CallerName, - pretty, "pretty", !IO), - show_settings_caller_format(Debugger, Info, Caller, CallerName, - raw_pretty, "raw_pretty", !IO), - nl_debugger(Debugger, !IO). + show_settings_caller_format(Debugger, Info, Caller, CallerName, + flat, "flat", !IO), + show_settings_caller_format(Debugger, Info, Caller, CallerName, + verbose, "verbose", !IO), + show_settings_caller_format(Debugger, Info, Caller, CallerName, + pretty, "pretty", !IO), + show_settings_caller_format(Debugger, Info, Caller, CallerName, + raw_pretty, "raw_pretty", !IO), + nl_debugger(Debugger, !IO). :- pred show_settings_caller_format(debugger::in, browser_info::in, - browse_caller_type::in, string::in, portray_format::in, string::in, - io::di, io::uo) is det. + browse_caller_type::in, string::in, portray_format::in, string::in, + io::di, io::uo) is det. show_settings_caller_format(Debugger, Info, Caller, CallerName, - Format, FormatName, !IO) :- - browser_info__get_format_params(Info, Caller, Format, Params), - write_string_debugger(Debugger, - pad_right(CallerName ++ " " ++ FormatName ++ ":", - ' ', row_name_len), - !IO), - write_string_debugger(Debugger, - pad_right(" ", ' ', centering_len), !IO), - write_string_debugger(Debugger, - pad_right(int_to_string(Params ^ depth), ' ', depth_len), !IO), - write_string_debugger(Debugger, - pad_right(int_to_string(Params ^ size), ' ', size_len), !IO), - write_string_debugger(Debugger, - pad_right(int_to_string(Params ^ width), ' ', x_len), !IO), - write_string_debugger(Debugger, - pad_right(int_to_string(Params ^ lines), ' ', y_len), !IO), - nl_debugger(Debugger, !IO). + Format, FormatName, !IO) :- + browser_info__get_format_params(Info, Caller, Format, Params), + write_string_debugger(Debugger, + pad_right(CallerName ++ " " ++ FormatName ++ ":", ' ', row_name_len), + !IO), + write_string_debugger(Debugger, + pad_right(" ", ' ', centering_len), !IO), + write_string_debugger(Debugger, + pad_right(int_to_string(Params ^ depth), ' ', depth_len), !IO), + write_string_debugger(Debugger, + pad_right(int_to_string(Params ^ size), ' ', size_len), !IO), + write_string_debugger(Debugger, + pad_right(int_to_string(Params ^ width), ' ', x_len), !IO), + write_string_debugger(Debugger, + pad_right(int_to_string(Params ^ lines), ' ', y_len), !IO), + nl_debugger(Debugger, !IO). :- func row_name_len = int. :- func centering_len = int. @@ -1630,94 +1585,95 @@ y_len = 10. :- pred string_to_path(string::in, path::out) is semidet. string_to_path(Str, Path) :- - string__to_char_list(Str, Cs), - chars_to_path(Cs, Path). + string__to_char_list(Str, Cs), + chars_to_path(Cs, Path). :- pred chars_to_path(list(char)::in, path::out) is semidet. chars_to_path([C | Cs], Path) :- - ( C = ('/') -> - Path = root_rel(Dirs), - chars_to_dirs(Cs, Dirs) - ; - Path = dot_rel(Dirs), - chars_to_dirs([C | Cs], Dirs) - ). + ( C = ('/') -> + Path = root_rel(Dirs), + chars_to_dirs(Cs, Dirs) + ; + Path = dot_rel(Dirs), + chars_to_dirs([C | Cs], Dirs) + ). :- pred chars_to_dirs(list(char)::in, list(dir)::out) is semidet. chars_to_dirs(Cs, Dirs) :- - split_dirs(Cs, Names), - names_to_dirs(Names, Dirs). + split_dirs(Cs, Names), + names_to_dirs(Names, Dirs). :- pred names_to_dirs(list(string)::in, list(dir)::out) is semidet. names_to_dirs([], []). names_to_dirs([Name | Names], Dirs) :- - ( Name = ".." -> - Dirs = [parent | RestDirs], - names_to_dirs(Names, RestDirs) - ; Name = "." -> - names_to_dirs(Names, Dirs) - ; string__to_int(Name, Num) -> - Dirs = [child_num(Num) | RestDirs], - names_to_dirs(Names, RestDirs) - ; - Dirs = [child_name(Name) | RestDirs], - names_to_dirs(Names, RestDirs) - ). + ( Name = ".." -> + Dirs = [parent | RestDirs], + names_to_dirs(Names, RestDirs) + ; Name = "." -> + names_to_dirs(Names, Dirs) + ; string__to_int(Name, Num) -> + Dirs = [child_num(Num) | RestDirs], + names_to_dirs(Names, RestDirs) + ; + Dirs = [child_name(Name) | RestDirs], + names_to_dirs(Names, RestDirs) + ). :- pred split_dirs(list(char)::in, list(string)::out) is det. split_dirs(Cs, Names) :- - takewhile(not_slash, Cs, NameCs, Rest), - string__from_char_list(NameCs, Name), - ( NameCs = [] -> - Names = [] - ; Rest = [] -> - Names = [Name] - ; Rest = [_Slash | RestCs] -> - split_dirs(RestCs, RestNames), - Names = [Name | RestNames] - ; - error("split_dirs: software error") - ). + takewhile(not_slash, Cs, NameCs, Rest), + string__from_char_list(NameCs, Name), + ( NameCs = [] -> + Names = [] + ; Rest = [] -> + Names = [Name] + ; Rest = [_Slash | RestCs] -> + split_dirs(RestCs, RestNames), + Names = [Name | RestNames] + ; + error("split_dirs: software error") + ). :- pred not_slash(char::in) is semidet. not_slash(C) :- - C \= ('/'). + C \= ('/'). - % Remove "/dir/../" sequences from a list of directories to yield - % a form that lacks ".." entries. - % + % Remove "/dir/../" sequences from a list of directories to yield + % a form that lacks ".." entries. + % :- pred simplify_dirs(list(dir)::in, list(dir)::out) is det. simplify_dirs(Dirs, SimpleDirs) :- - list.reverse(Dirs, RevDirs), - simplify_rev_dirs(RevDirs, 0, [], SimpleDirs). + list.reverse(Dirs, RevDirs), + simplify_rev_dirs(RevDirs, 0, [], SimpleDirs). - % simplify_rev_dirs(RevDirs, N, SoFar, SimpleDirs). - % Assumes a reverse list of directories and removes redundant `..' - % entries by scanning from the bottom most directory to the top, - % counting how many `..' occured (N) and removing entries accordingly. - % SoFar accumulates the simplified dirs processed so far so we can be - % tail recursive. - % + % simplify_rev_dirs(RevDirs, N, SoFar, SimpleDirs): + % + % Assumes a reverse list of directories and removes redundant `..' + % entries by scanning from the bottom most directory to the top, + % counting how many `..' occured (N) and removing entries accordingly. + % SoFar accumulates the simplified dirs processed so far so we can be + % tail recursive. + % :- pred simplify_rev_dirs(list(dir)::in, int::in, list(dir)::in, - list(dir)::out) is det. + list(dir)::out) is det. simplify_rev_dirs([], _, SimpleDirs, SimpleDirs). simplify_rev_dirs([Dir | Dirs], N, SoFar, SimpleDirs) :- - ( Dir = parent -> - simplify_rev_dirs(Dirs, N+1, SoFar, SimpleDirs) - ; - ( N > 0 -> - simplify_rev_dirs(Dirs, N-1, SoFar, SimpleDirs) - ; - simplify_rev_dirs(Dirs, N, [Dir | SoFar], SimpleDirs) - ) - ). + ( Dir = parent -> + simplify_rev_dirs(Dirs, N+1, SoFar, SimpleDirs) + ; + ( N > 0 -> + simplify_rev_dirs(Dirs, N-1, SoFar, SimpleDirs) + ; + simplify_rev_dirs(Dirs, N, [Dir | SoFar], SimpleDirs) + ) + ). :- func dir_to_string(dir) = string. @@ -1729,35 +1685,35 @@ dir_to_string(child_name(Name)) = Name. dirs_to_string([]) = "". dirs_to_string([Dir | Dirs]) = - ( Dirs = [] -> - dir_to_string(Dir) - ; - dir_to_string(Dir) ++ "/" ++ dirs_to_string(Dirs) - ). + ( Dirs = [] -> + dir_to_string(Dir) + ; + dir_to_string(Dir) ++ "/" ++ dirs_to_string(Dirs) + ). %---------------------------------------------------------------------------% :- pred write_string_debugger(debugger::in, string::in, io::di, io::uo) is det. write_string_debugger(internal, String, !IO) :- - io__write_string(String, !IO). + io__write_string(String, !IO). write_string_debugger(external, String, !IO) :- - send_term_to_socket(browser_str(String), !IO). + send_term_to_socket(browser_str(String), !IO). :- pred write_term_mode_debugger(debugger::in, maybe(browser_mode_func)::in, - list(dir)::in, io::di, io::uo) is det. + list(dir)::in, io::di, io::uo) is det. write_term_mode_debugger(Debugger, MaybeModeFunc, Dirs, !IO) :- - ( - MaybeModeFunc = yes(ModeFunc), - Mode = ModeFunc(Dirs), - ModeStr = browser_mode_to_string(Mode), - write_string_debugger(Debugger, ModeStr ++ "\n", !IO) - ; - MaybeModeFunc = no, - write_string_debugger(Debugger, - "Mode information not available.\n", !IO) - ). + ( + MaybeModeFunc = yes(ModeFunc), + Mode = ModeFunc(Dirs), + ModeStr = browser_mode_to_string(Mode), + write_string_debugger(Debugger, ModeStr ++ "\n", !IO) + ; + MaybeModeFunc = no, + write_string_debugger(Debugger, + "Mode information not available.\n", !IO) + ). :- func browser_mode_to_string(browser_term_mode) = string. @@ -1769,43 +1725,43 @@ browser_mode_to_string(unbound) = "Unbound". :- pred nl_debugger(debugger::in, io::di, io::uo) is det. nl_debugger(internal, !IO) :- - io__nl(!IO). + io__nl(!IO). nl_debugger(external, !IO) :- - send_term_to_socket(browser_nl, !IO). + send_term_to_socket(browser_nl, !IO). :- pred write_int_debugger(debugger::in, int::in, io::di, io::uo) is det. write_int_debugger(internal, Int, !IO) :- - io__write_int(Int, !IO). + io__write_int(Int, !IO). write_int_debugger(external, Int, !IO) :- - send_term_to_socket(browser_int(Int), !IO). + send_term_to_socket(browser_int(Int), !IO). :- pred print_format_debugger(debugger::in, portray_format::in, - io::di, io::uo) is det. + io::di, io::uo) is det. print_format_debugger(internal, X, !IO) :- - io__print(X, !IO). + io__print(X, !IO). print_format_debugger(external, X, !IO) :- - ( - X = flat, - send_term_to_socket(browser_str("flat"), !IO) - ; - X = raw_pretty, - send_term_to_socket(browser_str("raw_pretty"), !IO) - ; - X = verbose, - send_term_to_socket(browser_str("verbose"), !IO) - ; - X = pretty, - send_term_to_socket(browser_str("pretty"), !IO) - ). + ( + X = flat, + send_term_to_socket(browser_str("flat"), !IO) + ; + X = raw_pretty, + send_term_to_socket(browser_str("raw_pretty"), !IO) + ; + X = verbose, + send_term_to_socket(browser_str("verbose"), !IO) + ; + X = pretty, + send_term_to_socket(browser_str("pretty"), !IO) + ). :- pred send_term_to_socket(term_browser_response::in, io::di, io::uo) is det. send_term_to_socket(Term, !IO) :- - write(Term, !IO), - print(".\n", !IO), - flush_output(!IO). + write(Term, !IO), + print(".\n", !IO), + flush_output(!IO). %---------------------------------------------------------------------------% @@ -1813,55 +1769,49 @@ send_term_to_socket(Term, !IO) :- % is not a natural term, but a synthetic term defined by a functor, a list % of arguments, and if the synthetic term is a function application, then % the result of that function application. - + % :- func synthetic_term_to_doc(string, list(univ), maybe(univ)) = doc. :- func synthetic_term_to_doc(int, string, list(univ), maybe(univ)) = doc. synthetic_term_to_doc(Functor, Args, MaybeReturn) = - synthetic_term_to_doc(int__max_int, Functor, Args, MaybeReturn). + synthetic_term_to_doc(int__max_int, Functor, Args, MaybeReturn). synthetic_term_to_doc(Depth, Functor, Args, MaybeReturn) = Doc :- - Arity = list__length(Args), - ( Depth =< 0 -> - ( Arity = 0 -> - Doc = text(Functor) - ; - ( - MaybeReturn = yes(_), - Doc = text(Functor) `<>` text("/") `<>` - poly(i(Arity)) `<>` text("+1") - ; - MaybeReturn = no, - Doc = text(Functor) `<>` text("/") `<>` - poly(i(Arity)) - ) - ) - ; - ( Arity = 0 -> - Doc = text(Functor) - ; - ArgDocs = packed_cs_univ_args(Depth - 1, Args), - ( - MaybeReturn = yes(Return), - Doc = group( - text(Functor) `<>` - parentheses( - nest(2, ArgDocs) - ) `<>` - nest(2, text(" = ") `<>` - to_doc(Depth - 1, - univ_value(Return)) - ) - ) - ; - MaybeReturn = no, - Doc = group( - text(Functor) `<>` parentheses( - nest(2, ArgDocs) - ) - ) - ) - ) - ). + Arity = list__length(Args), + ( Depth =< 0 -> + ( Arity = 0 -> + Doc = text(Functor) + ; + ( + MaybeReturn = yes(_), + Doc = text(Functor) `<>` text("/") `<>` + poly(i(Arity)) `<>` text("+1") + ; + MaybeReturn = no, + Doc = text(Functor) `<>` text("/") `<>` poly(i(Arity)) + ) + ) + ; + ( Arity = 0 -> + Doc = text(Functor) + ; + ArgDocs = packed_cs_univ_args(Depth - 1, Args), + ( + MaybeReturn = yes(Return), + Doc = group( + text(Functor) `<>` + parentheses(nest(2, ArgDocs)) `<>` + nest(2, text(" = ") `<>` + to_doc(Depth - 1, univ_value(Return)) + ) + ) + ; + MaybeReturn = no, + Doc = group( + text(Functor) `<>` parentheses(nest(2, ArgDocs)) + ) + ) + ) + ). %---------------------------------------------------------------------------% diff --git a/browser/frame.m b/browser/frame.m index 642af1785..e808c7767 100644 --- a/browser/frame.m +++ b/browser/frame.m @@ -1,16 +1,17 @@ %---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% % Copyright (C) 1998-2000, 2003, 2005 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. %---------------------------------------------------------------------------% - +% % frame - minimally implements ASCII graphics frames. % This module is used by the term browser for displaying terms. % % XXX: This implementation is: -% - very inefficient. -% - specific to our immediate needs, and could be made more -% general. +% - very inefficient. +% - specific to our immediate needs, and could be made more general. % % authors: aet % stability: low @@ -22,145 +23,126 @@ :- import_module list. :- import_module std_util. - % XXX: Make frame type abstract instead? -% :- type frame. + % XXX: Make frame type abstract instead? :- type frame == list(string). - % We always clip from top-left corner, hence only one pair of - % coordinates is needed. -:- type frame__clip_rect == pair(int, int). + % We always clip from top-left corner, hence only one pair of + % coordinates is needed. +:- type clip_rect == pair(int, int). - % Width of a frame (horizontal size). -:- pred frame__hsize(frame, int). -:- mode frame__hsize(in, out) is det. + % Width of a frame (horizontal size). + % +:- func hsize(frame) = int. - % Height of a frame (vertical size). -:- pred frame__vsize(frame, int). -:- mode frame__vsize(in, out) is det. + % Height of a frame (vertical size). + % +:- func vsize(frame) = int. - % Create a frame from a string. -:- pred frame__from_string(string, frame). -:- mode frame__from_string(in, out) is det. + % Create a frame from a string. + % +:- func from_string(string) = frame. - % Stack (vertically glue) two frames, left-aligned. -:- pred frame__vglue(frame, frame, frame). -:- mode frame__vglue(in, in, out) is det. + % Stack (vertically glue) two frames, left-aligned. + % +:- func vglue(frame, frame) = frame. - % Juxtapose (horizontally glue) two frames, top-aligned. -:- pred frame__hglue(frame, frame, frame). -:- mode frame__hglue(in, in, out) is det. + % Juxtapose (horizontally glue) two frames, top-aligned. + % +:- func frame__hglue(frame, frame) = frame. - % clip a frame, where cliprect originates in top-left corner of frame. -:- pred frame__clip(frame__clip_rect, frame, frame). -:- mode frame__clip(in, in, out) is det. + % Clip a frame to the rectangle ((0,0),(X,Y)) where origin is on the + % top-left. Coordinate axes go down and right. + % +:- func clip(clip_rect, frame) = frame. %---------------------------------------------------------------------------% + :- implementation. :- import_module mdb.util. +:- import_module assoc_list. :- import_module int. -:- import_module io. :- import_module list. :- import_module require. :- import_module string. -frame__from_string(Str, [Str]). +from_string(Str) = [Str]. - % glue frames vertically (stack). align to left. -frame__vglue(TopFrame, BottomFrame, StackedFrame) :- - list__append(TopFrame, BottomFrame, StackedFrame). +vglue(TopFrame, BottomFrame) = StackedFrame :- + % Glue frames vertically (stack). Align to left. + list__append(TopFrame, BottomFrame, StackedFrame). - % glue frames horizontally (juxtapose). align to top. -frame__hglue(LeftFrame, RightFrame, GluedFrame) :- - frame__vsize(RightFrame, RVSize), - frame__vsize(LeftFrame, LVSize), - ( RVSize < LVSize -> - PadLines = LVSize - RVSize, - frame_lower_pad(RightFrame, PadLines, RightFrameNew), - LeftFrameNew = LeftFrame - ; LVSize < RVSize -> - PadLines = RVSize - LVSize, - frame_lower_pad(LeftFrame, PadLines, LeftFrameNew), - RightFrameNew = RightFrame - ; - LeftFrameNew = LeftFrame, - RightFrameNew = RightFrame - ), - frame_right_pad(LeftFrameNew, PaddedLeftFrameNew), - % XXX: mmc doesn't yet handle this. Use more verbose version instead. - % zip_with(string__append, PaddedLeftFrameNew, RightFrameNew, - % GluedFrame). - util__zip_with((pred(S1::in, S2::in, S3::out) is det :- - string__append(S1,S2,S3)), - PaddedLeftFrameNew, RightFrameNew, GluedFrame). +hglue(LeftFrame, RightFrame) = GluedFrame :- + % Glue frames horizontally (juxtapose). align to top. + RVSize = vsize(RightFrame), + LVSize = vsize(LeftFrame), + ( RVSize < LVSize -> + PadLines = LVSize - RVSize, + RightFrameNew = frame_lower_pad(RightFrame, PadLines), + LeftFrameNew = LeftFrame + ; LVSize < RVSize -> + PadLines = RVSize - LVSize, + LeftFrameNew = frame_lower_pad(LeftFrame, PadLines), + RightFrameNew = RightFrame + ; + LeftFrameNew = LeftFrame, + RightFrameNew = RightFrame + ), + frame_right_pad(LeftFrameNew, PaddedLeftFrameNew), + util__zip_with((pred(S1::in, S2::in, S3::out) is det :- + string__append(S1, S2, S3)), + PaddedLeftFrameNew, RightFrameNew, GluedFrame). + + % Add right padding. That is, add whitespace on right so that + % lines are all equal length. + % +:- pred frame_right_pad(frame::in, frame::out) is det. - % Add right padding. That is, add whitespace on right so that - % lines are all equal length. -:- pred frame_right_pad(frame, frame). -:- mode frame_right_pad(in, out) is det. frame_right_pad(Frame, PaddedFrame) :- - Lengths = list__map((func(Str) = string__length(Str)), Frame), - list__foldl(int__max, Lengths, 0, MaxLen), - list__map(subtract(MaxLen), Lengths, Paddings), - add_right_padding(Frame, Paddings, PaddedFrame). + Lengths = list__map((func(Str) = string__length(Str)), Frame), + list__foldl(int__max, Lengths, 0, MaxLen), + list__map(subtract(MaxLen), Lengths, Paddings), + list__map(add_right_padding, + assoc_list__from_corresponding_lists(Frame, Paddings), PaddedFrame). -:- pred add_right_padding(frame, list(int), frame). -:- mode add_right_padding(in, in, out) is det. -add_right_padding(Strs, Lens, PaddedFrame) :- - ( (Strs = [], Lens = []) -> - PaddedFrame = [] - ; (Strs = [S|Ss], Lens = [L|Ls]) -> - list__duplicate(L, ' ', PadChars), - string__from_char_list(PadChars, Padding), - string__append(S, Padding, SP), - add_right_padding(Ss, Ls, Rest), - PaddedFrame = [SP|Rest] - ; - error("add_right_padding: list arguments are of unequal length") - ). +:- pred add_right_padding(pair(string, int)::in, string::out) is det. + +add_right_padding(Str - Len, PaddedFrameStr) :- + list__duplicate(Len, ' ', PadChars), + string__from_char_list(PadChars, Padding), + string__append(Str, Padding, PaddedFrameStr). + + % We need this since Mercury has no Haskell-ese operation sections. + % +:- pred subtract(int::in, int::in, int::out) is det. - % We need this since Mercury has no Haskell-ese operation sections. -:- pred subtract(int, int, int). -:- mode subtract(in, in, out) is det. subtract(M, X, Z) :- - Z = M - X. + Z = M - X. - % Add empty lines of padding to the bottom of a frame. -:- pred frame_lower_pad(frame, int, frame). -:- mode frame_lower_pad(in, in, out) is det. -frame_lower_pad(Frame, PadLines, PaddedFrame) :- - list__duplicate(PadLines, "", Padding), - list__append(Frame, Padding, PaddedFrame). + % Add empty lines of padding to the bottom of a frame. + % +:- func frame_lower_pad(frame, int) = frame. - % Horizontal size (width) of a frame -frame__hsize(Frame, HSize) :- - Lengths = list__map(func(Str) = string__length(Str), Frame), - list__foldl(int__max, Lengths, 0, MaxLen), - HSize = MaxLen. +frame_lower_pad(Frame, PadLines) = PaddedFrame :- + list__duplicate(PadLines, "", Padding), + list__append(Frame, Padding, PaddedFrame). - % Vertical size (height) of a frame. -frame__vsize(Frame, VSize) :- - length(Frame, VSize). +hsize(Frame) = HSize :- + Lengths = list__map(func(Str) = string__length(Str), Frame), + list__foldl(int__max, Lengths, 0, MaxLen), + HSize = MaxLen. - % Clip a frame to the rectangle ((0,0),(X,Y)) where - % origin is on the top-left. Coordinate axes go down and right. -frame__clip(X-Y, Frame, ClippedFrame) :- - list__take_upto(Y, Frame, YClippedFrame), - list__map(left(X), YClippedFrame, ClippedFrame). +vsize(Frame) = VSize :- + length(Frame, VSize). + +clip(X-Y, Frame) = ClippedFrame :- + list__take_upto(Y, Frame, YClippedFrame), + list__map(left(X), YClippedFrame, ClippedFrame). + +:- pred left(int::in, string::in, string::out) is det. -:- pred left(int, string, string). -:- mode left(in, in, out) is det. left(N, Str, Left) :- - string__left(Str, N, Left). - -:- pred frame__print(frame, io__state, io__state). -:- mode frame__print(in, di, uo) is det. -frame__print([]) --> - { true }. -frame__print([L|Ls]) --> - io__write_string(L), - io__nl, - frame__print(Ls). + string__left(Str, N, Left). %---------------------------------------------------------------------------% diff --git a/compiler/add_mode.m b/compiler/add_mode.m index 0aaa7e2e3..e35d1130f 100644 --- a/compiler/add_mode.m +++ b/compiler/add_mode.m @@ -108,7 +108,7 @@ check_for_cyclic_inst(UserInstTable, OrigInstId, InstId0, Args0, Expansions0, map__search(InstDefns, InstId0, InstDefn), InstDefn = hlds_inst_defn(_, Params, Body, _, _), Body = eqv_inst(EqvInst0), - inst_substitute_arg_list(EqvInst0, Params, Args0, EqvInst), + inst_substitute_arg_list(Params, Args0, EqvInst0, EqvInst), EqvInst = defined_inst(user_inst(Name, Args)) -> Arity = list__length(Args), diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m index 7465fd568..8ce3e8054 100644 --- a/compiler/check_typeclass.m +++ b/compiler/check_typeclass.m @@ -1,11 +1,13 @@ %---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% % Copyright (C) 1996-2001, 2003-2005 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. %---------------------------------------------------------------------------% % % This module checks conformance of instance declarations to the typeclass -% declaration. It takes various steps to do this. +% declaration. It takes various steps to do this. % % First, for every method of every instance it generates a new pred % whose types and modes are as expected by the typeclass declaration and @@ -15,11 +17,11 @@ % eg. given the declarations: % % :- typeclass c(T) where [ -% pred m(T::in, T::out) is semidet +% pred m(T::in, T::out) is semidet % ]. % % :- instance c(int) where [ -% pred(m/2) is my_m +% pred(m/2) is my_m % ]. % % The correctness of my_m/2 as an implementation of m/2 is checked by @@ -28,7 +30,7 @@ % :- pred 'implementation of m/2'(int::in, int::out) is semidet. % % 'implementation of m/2'(HeadVar_1, HeadVar_2) :- -% my_m(HeadVar_1, HeadVar_2). +% my_m(HeadVar_1, HeadVar_2). % % By generating the new pred, we check the instance method for type, mode, % determinism and uniqueness correctness since the generated pred is checked @@ -72,8 +74,8 @@ :- import_module io. :- pred check_typeclass__check_typeclasses(make_hlds_qual_info::in, - make_hlds_qual_info::out, module_info::in, module_info::out, - bool::out, io::di, io::uo) is det. + make_hlds_qual_info::out, module_info::in, module_info::out, bool::out, + io::di, io::uo) is det. %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% @@ -119,29 +121,27 @@ %---------------------------------------------------------------------------% check_typeclass__check_typeclasses(!QualInfo, !ModuleInfo, FoundError, !IO) :- - globals__io_lookup_bool_option(verbose, Verbose, !IO), - maybe_write_string(Verbose, "% Checking typeclass instances...\n", !IO), - check_typeclass__check_instance_decls(!QualInfo, !ModuleInfo, - FoundInstanceError, !IO), + globals__io_lookup_bool_option(verbose, Verbose, !IO), + maybe_write_string(Verbose, "% Checking typeclass instances...\n", !IO), + check_typeclass__check_instance_decls(!QualInfo, !ModuleInfo, + FoundInstanceError, !IO), - maybe_write_string(Verbose, "% Checking for cyclic classes...\n", !IO), - check_for_cyclic_classes(!ModuleInfo, FoundCycleError, !IO), + maybe_write_string(Verbose, "% Checking for cyclic classes...\n", !IO), + check_for_cyclic_classes(!ModuleInfo, FoundCycleError, !IO), - maybe_write_string(Verbose, - "% Checking for missing concrete instances...\n", !IO), - check_for_missing_concrete_instances(!ModuleInfo, FoundMissingError, - !IO), + maybe_write_string(Verbose, + "% Checking for missing concrete instances...\n", !IO), + check_for_missing_concrete_instances(!ModuleInfo, FoundMissingError, !IO), - maybe_write_string(Verbose, - "% Checking functional dependencies on instances...\n", !IO), - check_functional_dependencies(!ModuleInfo, FoundFunDepError, !IO), + maybe_write_string(Verbose, + "% Checking functional dependencies on instances...\n", !IO), + check_functional_dependencies(!ModuleInfo, FoundFunDepError, !IO), - maybe_write_string(Verbose, - "% Checking typeclass constraints...\n", !IO), - check_constraints(!ModuleInfo, FoundConstraintsError, !IO), + maybe_write_string(Verbose, "% Checking typeclass constraints...\n", !IO), + check_constraints(!ModuleInfo, FoundConstraintsError, !IO), - FoundError = bool.or_list([FoundInstanceError, FoundCycleError, - FoundMissingError, FoundFunDepError, FoundConstraintsError]). + FoundError = bool.or_list([FoundInstanceError, FoundCycleError, + FoundMissingError, FoundFunDepError, FoundConstraintsError]). %---------------------------------------------------------------------------% @@ -149,1364 +149,1275 @@ check_typeclass__check_typeclasses(!QualInfo, !ModuleInfo, FoundError, !IO) :- :- type error_messages == list(error_message). :- pred check_typeclass__check_instance_decls(make_hlds_qual_info::in, - make_hlds_qual_info::out, module_info::in, module_info::out, - bool::out, io::di, io::uo) is det. + make_hlds_qual_info::out, module_info::in, module_info::out, + bool::out, io::di, io::uo) is det. check_typeclass__check_instance_decls(!QualInfo, !ModuleInfo, FoundError, - !IO) :- - module_info_get_class_table(!.ModuleInfo, ClassTable), - module_info_get_instance_table(!.ModuleInfo, InstanceTable0), - map__to_assoc_list(InstanceTable0, InstanceList0), - list__map_foldl2(check_one_class(ClassTable), InstanceList0, - InstanceList, check_tc_info([], !.ModuleInfo, !.QualInfo), - check_tc_info(Errors, !:ModuleInfo, !:QualInfo), !IO), - ( - Errors = [], - map__from_assoc_list(InstanceList, InstanceTable), - module_info_set_instance_table(InstanceTable, !ModuleInfo), - FoundError = no - ; - Errors = [_ | _], - list__reverse(Errors, ErrorList), - WriteError = (pred(E::in, IO0::di, IO::uo) is det :- - E = ErrorContext - ErrorPieces, - write_error_pieces(ErrorContext, 0, ErrorPieces, - IO0, IO) - ), - list__foldl(WriteError, ErrorList, !IO), - io__set_exit_status(1, !IO), - FoundError = yes - ). + !IO) :- + module_info_get_class_table(!.ModuleInfo, ClassTable), + module_info_get_instance_table(!.ModuleInfo, InstanceTable0), + map__to_assoc_list(InstanceTable0, InstanceList0), + list__map_foldl2(check_one_class(ClassTable), InstanceList0, + InstanceList, check_tc_info([], !.ModuleInfo, !.QualInfo), + check_tc_info(Errors, !:ModuleInfo, !:QualInfo), !IO), + ( + Errors = [], + map__from_assoc_list(InstanceList, InstanceTable), + module_info_set_instance_table(InstanceTable, !ModuleInfo), + FoundError = no + ; + Errors = [_ | _], + list__reverse(Errors, ErrorList), + WriteError = (pred(E::in, IO0::di, IO::uo) is det :- + E = ErrorContext - ErrorPieces, + write_error_pieces(ErrorContext, 0, ErrorPieces, IO0, IO) + ), + list__foldl(WriteError, ErrorList, !IO), + io__set_exit_status(1, !IO), + FoundError = yes + ). :- type check_tc_info - ---> check_tc_info( - error_messages :: error_messages, - module_info :: module_info, - qual_info :: make_hlds_qual_info - ). + ---> check_tc_info( + error_messages :: error_messages, + module_info :: module_info, + qual_info :: make_hlds_qual_info + ). - % Check all the instances of one class. - % + % Check all the instances of one class. + % :- pred check_one_class(class_table::in, - pair(class_id, list(hlds_instance_defn))::in, - pair(class_id, list(hlds_instance_defn))::out, - check_tc_info::in, check_tc_info::out, - io::di, io::uo) is det. + pair(class_id, list(hlds_instance_defn))::in, + pair(class_id, list(hlds_instance_defn))::out, + check_tc_info::in, check_tc_info::out, + io::di, io::uo) is det. check_one_class(ClassTable, ClassId - InstanceDefns0, - ClassId - InstanceDefns, !CheckTCInfo, !IO) :- + ClassId - InstanceDefns, !CheckTCInfo, !IO) :- - map__lookup(ClassTable, ClassId, ClassDefn), - ClassDefn = hlds_class_defn(ImportStatus, SuperClasses, _FunDeps, - _Ancestors, ClassVars, _Kinds, Interface, ClassInterface, - ClassVarSet, TermContext), - ( - status_defined_in_this_module(ImportStatus, yes), - Interface = abstract - -> - ClassId = class_id(ClassName, ClassArity), - ErrorPieces = [ - words("Error: no definition for typeclass"), - sym_name_and_arity(ClassName / ClassArity) - ], - Messages0 = !.CheckTCInfo ^ error_messages, - !:CheckTCInfo = !.CheckTCInfo ^ error_messages := - [TermContext - ErrorPieces | Messages0], - InstanceDefns = InstanceDefns0 - ; - solutions( - (pred(PredId::out) is nondet :- - list__member(ClassProc, ClassInterface), - ClassProc = hlds_class_proc(PredId, _) - ), - PredIds), - list__map_foldl2( - check_class_instance(ClassId, SuperClasses, - ClassVars, ClassInterface, Interface, - ClassVarSet, PredIds), - InstanceDefns0, InstanceDefns, - !CheckTCInfo, !IO) - ). + map__lookup(ClassTable, ClassId, ClassDefn), + ClassDefn = hlds_class_defn(ImportStatus, SuperClasses, _FunDeps, + _Ancestors, ClassVars, _Kinds, Interface, ClassInterface, + ClassVarSet, TermContext), + ( + status_defined_in_this_module(ImportStatus, yes), + Interface = abstract + -> + ClassId = class_id(ClassName, ClassArity), + ErrorPieces = [ + words("Error: no definition for typeclass"), + sym_name_and_arity(ClassName / ClassArity) + ], + Messages0 = !.CheckTCInfo ^ error_messages, + !:CheckTCInfo = !.CheckTCInfo ^ error_messages := + [TermContext - ErrorPieces | Messages0], + InstanceDefns = InstanceDefns0 + ; + solutions( + ( pred(PredId::out) is nondet :- + list__member(ClassProc, ClassInterface), + ClassProc = hlds_class_proc(PredId, _) + ), + PredIds), + list__map_foldl2( + check_class_instance(ClassId, SuperClasses, ClassVars, + ClassInterface, Interface, ClassVarSet, PredIds), + InstanceDefns0, InstanceDefns, + !CheckTCInfo, !IO) + ). - % Check one instance of one class. - % + % Check one instance of one class. + % :- pred check_class_instance(class_id::in, list(prog_constraint)::in, - list(tvar)::in, hlds_class_interface::in, class_interface::in, - tvarset::in, list(pred_id)::in, - hlds_instance_defn::in, hlds_instance_defn::out, - check_tc_info::in, check_tc_info::out, - io::di, io::uo) is det. + list(tvar)::in, hlds_class_interface::in, class_interface::in, + tvarset::in, list(pred_id)::in, + hlds_instance_defn::in, hlds_instance_defn::out, + check_tc_info::in, check_tc_info::out, + io::di, io::uo) is det. check_class_instance(ClassId, SuperClasses, Vars, HLDSClassInterface, - ClassInterface, ClassVarSet, PredIds, - InstanceDefn0, InstanceDefn, - check_tc_info(Errors0, ModuleInfo0, QualInfo0), - check_tc_info(Errors, ModuleInfo, QualInfo), - !IO):- + ClassInterface, ClassVarSet, PredIds, !InstanceDefn, + check_tc_info(Errors0, ModuleInfo0, QualInfo0), + check_tc_info(Errors, ModuleInfo, QualInfo), + !IO):- - % check conformance of the instance body - InstanceDefn0 = hlds_instance_defn(_, _, TermContext, _, _, - InstanceBody, _, _, _), - ( - InstanceBody = abstract, - InstanceDefn1 = InstanceDefn0, - ModuleInfo = ModuleInfo0, - QualInfo = QualInfo0, - Errors1 = Errors0 - ; - InstanceBody = concrete(InstanceMethods), - check_concrete_class_instance(ClassId, Vars, - HLDSClassInterface, ClassInterface, - PredIds, TermContext, InstanceMethods, - InstanceDefn0, InstanceDefn1, Errors0, Errors1, - ModuleInfo0, ModuleInfo, QualInfo0, QualInfo, !IO) - ), - % check that the superclass constraints are satisfied for the - % types in this instance declaration - check_superclass_conformance(ClassId, SuperClasses, Vars, ClassVarSet, - ModuleInfo, InstanceDefn1, InstanceDefn, Errors1, Errors). + % Check conformance of the instance body. + !.InstanceDefn = hlds_instance_defn(_, _, TermContext, _, _, + InstanceBody, _, _, _), + ( + InstanceBody = abstract, + ModuleInfo = ModuleInfo0, + QualInfo = QualInfo0, + Errors1 = Errors0 + ; + InstanceBody = concrete(InstanceMethods), + check_concrete_class_instance(ClassId, Vars, + HLDSClassInterface, ClassInterface, + PredIds, TermContext, InstanceMethods, + !InstanceDefn, Errors0, Errors1, + ModuleInfo0, ModuleInfo, QualInfo0, QualInfo, !IO) + ), + % Check that the superclass constraints are satisfied for the + % types in this instance declaration. + check_superclass_conformance(ClassId, SuperClasses, Vars, ClassVarSet, + ModuleInfo, !InstanceDefn, Errors1, Errors). :- pred check_concrete_class_instance(class_id::in, list(tvar)::in, - hlds_class_interface::in, class_interface::in, - list(pred_id)::in, term__context::in, - instance_methods::in, hlds_instance_defn::in, hlds_instance_defn::out, - error_messages::in, error_messages::out, - module_info::in, module_info::out, - make_hlds_qual_info::in, make_hlds_qual_info::out, io::di, io::uo) - is det. + hlds_class_interface::in, class_interface::in, + list(pred_id)::in, term__context::in, + instance_methods::in, hlds_instance_defn::in, hlds_instance_defn::out, + error_messages::in, error_messages::out, + module_info::in, module_info::out, + make_hlds_qual_info::in, make_hlds_qual_info::out, io::di, io::uo) is det. check_concrete_class_instance(ClassId, Vars, HLDSClassInterface, - ClassInterface, PredIds, TermContext, - InstanceMethods, !InstanceDefn, !Errors, !ModuleInfo, - !QualInfo, !IO) :- - ( - ClassInterface = abstract, - ClassId = class_id(ClassName, ClassArity), - ErrorPieces = [ - words("Error: instance declaration for"), - words("abstract typeclass"), - sym_name_and_arity(ClassName / ClassArity), - suffix(".") - ], - !:Errors = [TermContext - ErrorPieces | !.Errors] - ; - ClassInterface = concrete(_), - InstanceCheckInfo0 = instance_check_info(!.InstanceDefn, - [], !.Errors, !.ModuleInfo, !.QualInfo), - list__foldl2( - check_instance_pred(ClassId, Vars, HLDSClassInterface), - PredIds, InstanceCheckInfo0, InstanceCheckInfo, !IO), - InstanceCheckInfo = instance_check_info(!:InstanceDefn, - RevInstanceMethods, !:Errors, !:ModuleInfo, - !:QualInfo), + ClassInterface, PredIds, TermContext, InstanceMethods, !InstanceDefn, + !Errors, !ModuleInfo, !QualInfo, !IO) :- + ( + ClassInterface = abstract, + ClassId = class_id(ClassName, ClassArity), + ErrorPieces = [ + words("Error: instance declaration for"), + words("abstract typeclass"), + sym_name_and_arity(ClassName / ClassArity), + suffix(".") + ], + !:Errors = [TermContext - ErrorPieces | !.Errors] + ; + ClassInterface = concrete(_), + InstanceCheckInfo0 = instance_check_info(!.InstanceDefn, + [], !.Errors, !.ModuleInfo, !.QualInfo), + list__foldl2(check_instance_pred(ClassId, Vars, HLDSClassInterface), + PredIds, InstanceCheckInfo0, InstanceCheckInfo, !IO), + InstanceCheckInfo = instance_check_info(!:InstanceDefn, + RevInstanceMethods, !:Errors, !:ModuleInfo, !:QualInfo), - % - % We need to make sure that the MaybePredProcs field is - % set to yes(_) after this pass. Normally that will be - % handled by check_instance_pred, but we also need to handle - % it below, in case the class has no methods. - % - MaybePredProcs1 = !.InstanceDefn ^ instance_hlds_interface, - ( - MaybePredProcs1 = yes(_), - MaybePredProcs = MaybePredProcs1 - ; - MaybePredProcs1 = no, - MaybePredProcs = yes([]) - ), + % We need to make sure that the MaybePredProcs field is set to yes(_) + % after this pass. Normally that will be handled by + % check_instance_pred, but we also need to handle it below, + % in case the class has no methods. + MaybePredProcs1 = !.InstanceDefn ^ instance_hlds_interface, + ( + MaybePredProcs1 = yes(_), + MaybePredProcs = MaybePredProcs1 + ; + MaybePredProcs1 = no, + MaybePredProcs = yes([]) + ), - % - % Make sure the list of instance methods is in the same - % order as the methods in the class definition. intermod.m - % relies on this - OrderedInstanceMethods = list__reverse(RevInstanceMethods), + % Make sure the list of instance methods is in the same order + % as the methods in the class definition. intermod.m relies on this. + OrderedInstanceMethods = list__reverse(RevInstanceMethods), - !:InstanceDefn = ((!.InstanceDefn - ^ instance_hlds_interface := MaybePredProcs) - ^ instance_body := concrete(OrderedInstanceMethods)), + !:InstanceDefn = !.InstanceDefn ^ instance_hlds_interface + := MaybePredProcs, + !:InstanceDefn = !.InstanceDefn ^ instance_body + := concrete(OrderedInstanceMethods), - % - % Check if there are any instance methods left over, - % which did not match any of the methods from the - % class interface. - % - Context = !.InstanceDefn ^ instance_context, - check_for_bogus_methods(InstanceMethods, ClassId, PredIds, - Context, !.ModuleInfo, !Errors) - ). + % Check if there are any instance methods left over, which did not + % match any of the methods from the class interface. + Context = !.InstanceDefn ^ instance_context, + check_for_bogus_methods(InstanceMethods, ClassId, PredIds, + Context, !.ModuleInfo, !Errors) + ). - % - % Check if there are any instance methods left over, - % which did not match any of the methods from the - % class interface. If so, add an appropriate error - % message to the list of error messages. - % + % Check if there are any instance methods left over, which did not match + % any of the methods from the class interface. If so, add an appropriate + % error message to the list of error messages. + % :- pred check_for_bogus_methods(list(instance_method)::in, class_id::in, - list(pred_id)::in, prog_context::in, module_info::in, - error_messages::in, error_messages::out) is det. + list(pred_id)::in, prog_context::in, module_info::in, + error_messages::in, error_messages::out) is det. check_for_bogus_methods(InstanceMethods, ClassId, ClassPredIds, Context, - ModuleInfo1, !Errors) :- - module_info_get_predicate_table(ModuleInfo1, PredTable), - DefnIsOK = (pred(Method::in) is semidet :- - % Find this method definition's p/f, name, arity - Method = instance_method(MethodPredOrFunc, - MethodName, _MethodDefn, MethodArity, _Context), - % Search for pred_ids matching that p/f, name, arity, - % and succeed if the method definition p/f, name, and - % arity matches at least one of the methods from the - % class interface - adjust_func_arity(MethodPredOrFunc, MethodArity, - MethodPredArity), - predicate_table_search_pf_sym_arity(PredTable, - is_fully_qualified, MethodPredOrFunc, - MethodName, MethodPredArity, MatchingPredIds), - some [PredId] ( - list__member(PredId, MatchingPredIds), - list__member(PredId, ClassPredIds) - ) - ), - list__filter(DefnIsOK, InstanceMethods, _OKInstanceMethods, - BogusInstanceMethods), - ( - BogusInstanceMethods = [] - ; - BogusInstanceMethods = [_ | _], - % - % There were one or more bogus methods. - % Construct an appropriate error message. - % - ClassId = class_id(ClassName, ClassArity), - ErrorMsgStart = [ - words("In instance declaration for"), - sym_name_and_arity(ClassName / ClassArity), - suffix(":"), - words("incorrect method name(s):") - ], - ErrorMsgBody0 = list.map(format_method_name, - BogusInstanceMethods), - ErrorMsgBody1 = list.condense(ErrorMsgBody0), - ErrorMsgBody = list__append(ErrorMsgBody1, [suffix(".")]), - NewError = Context - ( ErrorMsgStart ++ ErrorMsgBody ), - !:Errors = [NewError | !.Errors] - ). + ModuleInfo, !Errors) :- + module_info_get_predicate_table(ModuleInfo, PredTable), + DefnIsOK = (pred(Method::in) is semidet :- + % Find this method definition's p/f, name, arity + Method = instance_method(MethodPredOrFunc, MethodName, _MethodDefn, + MethodArity, _Context), + % Search for pred_ids matching that p/f, name, arity, and succeed + % if the method definition p/f, name, and arity matches at least one + % of the methods from the class interface. + adjust_func_arity(MethodPredOrFunc, MethodArity, MethodPredArity), + predicate_table_search_pf_sym_arity(PredTable, is_fully_qualified, + MethodPredOrFunc, MethodName, MethodPredArity, MatchingPredIds), + some [PredId] ( + list__member(PredId, MatchingPredIds), + list__member(PredId, ClassPredIds) + ) + ), + list__filter(DefnIsOK, InstanceMethods, _OKInstanceMethods, + BogusInstanceMethods), + ( + BogusInstanceMethods = [] + ; + BogusInstanceMethods = [_ | _], + % There were one or more bogus methods. + % Construct an appropriate error message. + ClassId = class_id(ClassName, ClassArity), + ErrorMsgStart = [ + words("In instance declaration for"), + sym_name_and_arity(ClassName / ClassArity), + suffix(":"), + words("incorrect method name(s):") + ], + ErrorMsgBody0 = list.map(format_method_name, BogusInstanceMethods), + ErrorMsgBody1 = list.condense(ErrorMsgBody0), + ErrorMsgBody = list__append(ErrorMsgBody1, [suffix(".")]), + NewError = Context - ( ErrorMsgStart ++ ErrorMsgBody ), + !:Errors = [NewError | !.Errors] + ). :- func format_method_name(instance_method) = format_components. format_method_name(Method) = MethodName :- - Method = instance_method(PredOrFunc, Name, _Defn, Arity, _Context), - adjust_func_arity(PredOrFunc, Arity, PredArity), - MethodName = [ - pred_or_func(PredOrFunc), - sym_name_and_arity(Name / PredArity) - ]. + Method = instance_method(PredOrFunc, Name, _Defn, Arity, _Context), + adjust_func_arity(PredOrFunc, Arity, PredArity), + MethodName = [ + pred_or_func(PredOrFunc), + sym_name_and_arity(Name / PredArity) + ]. %----------------------------------------------------------------------------% -:- type instance_check_info ---> - instance_check_info( - hlds_instance_defn, - instance_methods, % The instance methods in reverse - % order of the methods in the class - % declaration. - error_messages, - module_info, - make_hlds_qual_info - ). +:- type instance_check_info + ---> instance_check_info( + hlds_instance_defn, + instance_methods, % The instance methods in reverse + % order of the methods in the class + % declaration. + error_messages, + module_info, + make_hlds_qual_info + ). - % This structure holds the information about a particular instance - % method -:- type instance_method_info ---> - instance_method_info( - module_info, - make_hlds_qual_info, - sym_name, % Name that the - % introduced pred - % should be given. - arity, % Arity of the method. - % (For funcs, this is - % the original arity, - % not the arity as a - % predicate.) - existq_tvars, % Existentially quant. - % type variables - list(type), % Expected types of - % arguments. - prog_constraints, % Constraints from - % class method. - list(modes_and_detism), % Modes and - % determinisms of the - % required procs. - error_messages, % Error messages - % that have been - % generated. - tvarset, - import_status, % Import status of - % instance decl. - pred_or_func % Is method pred or - % func? - ). + % This structure holds the information about a particular instance + % method. +:- type instance_method_info + ---> instance_method_info( + module_info, + make_hlds_qual_info, + sym_name, % Name that the introduced pred + % should be given. + arity, % Arity of the method. + % (For funcs, this is + % the original arity, + % not the arity as a + % predicate.) + existq_tvars, % Existentially quantified + % type variables. + list(type), % Expected types of arguments. + prog_constraints, % Constraints from class method. + list(modes_and_detism), % Modes and determinisms of the + % required procs. + error_messages, % Error messages that have been + % generated. + tvarset, + import_status, % Import status of instance decl. + pred_or_func % Is method pred or func? + ). %----------------------------------------------------------------------------% - % check one pred in one instance of one class + % Check one pred in one instance of one class. + % :- pred check_instance_pred(class_id::in, list(tvar)::in, - hlds_class_interface::in, pred_id::in, - instance_check_info::in, instance_check_info::out, - io::di, io::uo) is det. + hlds_class_interface::in, pred_id::in, + instance_check_info::in, instance_check_info::out, + io::di, io::uo) is det. check_instance_pred(ClassId, ClassVars, ClassInterface, PredId, - !InstanceCheckInfo, !IO) :- - !.InstanceCheckInfo = instance_check_info(InstanceDefn0, - OrderedMethods0, Errors0, ModuleInfo0, QualInfo0), - solutions((pred(ProcId::out) is nondet :- - list__member(ClassProc, ClassInterface), - ClassProc = hlds_class_proc(PredId, ProcId) - ), ProcIds), - module_info_pred_info(ModuleInfo0, PredId, PredInfo), - pred_info_arg_types(PredInfo, ArgTypeVars, ExistQVars, ArgTypes), - pred_info_get_class_context(PredInfo, ClassContext0), - pred_info_get_markers(PredInfo, Markers0), - remove_marker(class_method, Markers0, Markers), - % The first constraint in the class context of a class method - % is always the constraint for the class of which it is - % a member. Seeing that we are checking an instance - % declaration, we don't check that constraint... the instance - % declaration itself satisfies it! - ( ClassContext0 = constraints([_ | OtherUnivCs], ExistCs) -> - UnivCs = OtherUnivCs, - ClassContext = constraints(UnivCs, ExistCs) - ; - unexpected(this_file, - "check_instance_pred: no constraint on class method") - ), + !InstanceCheckInfo, !IO) :- + !.InstanceCheckInfo = instance_check_info(InstanceDefn0, + OrderedMethods0, Errors0, ModuleInfo0, QualInfo0), + solutions((pred(ProcId::out) is nondet :- + list__member(ClassProc, ClassInterface), + ClassProc = hlds_class_proc(PredId, ProcId) + ), ProcIds), + module_info_pred_info(ModuleInfo0, PredId, PredInfo), + pred_info_arg_types(PredInfo, ArgTypeVars, ExistQVars, ArgTypes), + pred_info_get_class_context(PredInfo, ClassContext0), + pred_info_get_markers(PredInfo, Markers0), + remove_marker(class_method, Markers0, Markers), + % The first constraint in the class context of a class method is always + % the constraint for the class of which it is a member. Seeing that we are + % checking an instance declaration, we don't check that constraint... + % the instance declaration itself satisfies it! + ( ClassContext0 = constraints([_ | OtherUnivCs], ExistCs) -> + UnivCs = OtherUnivCs, + ClassContext = constraints(UnivCs, ExistCs) + ; + unexpected(this_file, + "check_instance_pred: no constraint on class method") + ), + MethodName0 = pred_info_name(PredInfo), + PredModule = pred_info_module(PredInfo), + MethodName = qualified(PredModule, MethodName0), + PredArity = pred_info_orig_arity(PredInfo), + PredOrFunc = pred_info_is_pred_or_func(PredInfo), + adjust_func_arity(PredOrFunc, Arity, PredArity), + pred_info_procedures(PredInfo, ProcTable), + list__map( + (pred(TheProcId::in, ModesAndDetism::out) is det :- + map__lookup(ProcTable, TheProcId, ProcInfo), + proc_info_argmodes(ProcInfo, Modes), + % If the determinism declaration on the method was omitted, + % then make_hlds will have already issued an error message, + % so don't complain here. + proc_info_declared_determinism(ProcInfo, MaybeDetism), + proc_info_inst_varset(ProcInfo, InstVarSet), + ModesAndDetism = modes_and_detism(Modes, InstVarSet, MaybeDetism) + ), ProcIds, ArgModes), - MethodName0 = pred_info_name(PredInfo), - PredModule = pred_info_module(PredInfo), - MethodName = qualified(PredModule, MethodName0), - PredArity = pred_info_orig_arity(PredInfo), - PredOrFunc = pred_info_is_pred_or_func(PredInfo), - adjust_func_arity(PredOrFunc, Arity, PredArity), - pred_info_procedures(PredInfo, ProcTable), - list__map((pred(TheProcId::in, ModesAndDetism::out) is det :- - map__lookup(ProcTable, TheProcId, ProcInfo), - proc_info_argmodes(ProcInfo, Modes), - % if the determinism declaration on the method - % was omitted, then make_hlds.m will have - % already issued an error message, so - % don't complain here. - proc_info_declared_determinism(ProcInfo, - MaybeDetism), - proc_info_inst_varset(ProcInfo, InstVarSet), - ModesAndDetism = modes_and_detism(Modes, - InstVarSet, MaybeDetism) - ), ProcIds, ArgModes), + InstanceDefn0 = hlds_instance_defn(_, Status, _, _, InstanceTypes, + _, _, _, _), - InstanceDefn0 = hlds_instance_defn(_, Status, _, _, InstanceTypes, - _, _, _, _), + % Work out the name of the predicate that we will generate + % to check this instance method. + make_introduced_pred_name(ClassId, MethodName, Arity, + InstanceTypes, PredName), - % Work out the name of the predicate that we will generate - % to check this instance method. - make_introduced_pred_name(ClassId, MethodName, Arity, - InstanceTypes, PredName), + MethodInfo0 = instance_method_info(ModuleInfo0, QualInfo0, PredName, + Arity, ExistQVars, ArgTypes, ClassContext, ArgModes, + Errors0, ArgTypeVars, Status, PredOrFunc), - MethodInfo0 = instance_method_info(ModuleInfo0, QualInfo0, PredName, - Arity, ExistQVars, ArgTypes, ClassContext, ArgModes, - Errors0, ArgTypeVars, Status, PredOrFunc), + check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers, + InstanceDefn0, InstanceDefn, OrderedMethods0, OrderedMethods, + MethodInfo0, MethodInfo, !IO), - check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers, - InstanceDefn0, InstanceDefn, OrderedMethods0, OrderedMethods, - MethodInfo0, MethodInfo, !IO), + MethodInfo = instance_method_info(ModuleInfo, QualInfo, _PredName, + _Arity, _ExistQVars, _ArgTypes, _ClassContext, _ArgModes, + Errors, _ArgTypeVars, _Status, _PredOrFunc), - MethodInfo = instance_method_info(ModuleInfo, QualInfo, _PredName, - _Arity, _ExistQVars, _ArgTypes, _ClassContext, _ArgModes, - Errors, _ArgTypeVars, _Status, _PredOrFunc), - - !:InstanceCheckInfo = instance_check_info(InstanceDefn, - OrderedMethods, Errors, ModuleInfo, QualInfo). + !:InstanceCheckInfo = instance_check_info(InstanceDefn, + OrderedMethods, Errors, ModuleInfo, QualInfo). :- type modes_and_detism - ---> modes_and_detism(list(mode), inst_varset, maybe(determinism)). + ---> modes_and_detism( + list(mode), + inst_varset, + maybe(determinism) + ). :- pred check_instance_pred_procs(class_id::in, list(tvar)::in, sym_name::in, - pred_markers::in, hlds_instance_defn::in, hlds_instance_defn::out, - instance_methods::in, instance_methods::out, - instance_method_info::in, instance_method_info::out, - io::di, io::uo) is det. + pred_markers::in, hlds_instance_defn::in, hlds_instance_defn::out, + instance_methods::in, instance_methods::out, + instance_method_info::in, instance_method_info::out, + io::di, io::uo) is det. check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers, - InstanceDefn0, InstanceDefn, OrderedInstanceMethods0, - OrderedInstanceMethods, Info0, Info, !IO) :- - InstanceDefn0 = hlds_instance_defn(InstanceModuleName, B, - InstanceContext, InstanceConstraints, InstanceTypes, - InstanceBody, MaybeInstancePredProcs, InstanceVarSet, I), - Info0 = instance_method_info(ModuleInfo, QualInfo, PredName, Arity, - ExistQVars, ArgTypes, ClassContext, ArgModes, Errors0, - ArgTypeVars, Status, PredOrFunc), - get_matching_instance_defns(InstanceBody, PredOrFunc, MethodName, - Arity, MatchingInstanceMethods), - ( - MatchingInstanceMethods = [InstanceMethod], - OrderedInstanceMethods = - [InstanceMethod | OrderedInstanceMethods0], - InstanceMethod = instance_method(_, _, InstancePredDefn, - _, Context), - produce_auxiliary_procs(ClassId, ClassVars, Markers, - InstanceTypes, InstanceConstraints, - InstanceVarSet, InstanceModuleName, - InstancePredDefn, Context, - InstancePredId, InstanceProcIds, Info0, Info, !IO), + InstanceDefn0, InstanceDefn, OrderedInstanceMethods0, + OrderedInstanceMethods, Info0, Info, !IO) :- + InstanceDefn0 = hlds_instance_defn(InstanceModuleName, B, + InstanceContext, InstanceConstraints, InstanceTypes, + InstanceBody, MaybeInstancePredProcs, InstanceVarSet, I), + Info0 = instance_method_info(ModuleInfo, QualInfo, PredName, Arity, + ExistQVars, ArgTypes, ClassContext, ArgModes, Errors0, + ArgTypeVars, Status, PredOrFunc), + get_matching_instance_defns(InstanceBody, PredOrFunc, MethodName, + Arity, MatchingInstanceMethods), + ( + MatchingInstanceMethods = [InstanceMethod], + OrderedInstanceMethods = [InstanceMethod | OrderedInstanceMethods0], + InstanceMethod = instance_method(_, _, InstancePredDefn, _, Context), + produce_auxiliary_procs(ClassId, ClassVars, Markers, + InstanceTypes, InstanceConstraints, + InstanceVarSet, InstanceModuleName, + InstancePredDefn, Context, + InstancePredId, InstanceProcIds, Info0, Info, !IO), - MakeClassProc = (pred(TheProcId::in, PredProcId::out) is det :- - PredProcId = hlds_class_proc(InstancePredId, - TheProcId) - ), - list__map(MakeClassProc, InstanceProcIds, InstancePredProcs1), - ( - MaybeInstancePredProcs = yes(InstancePredProcs0), - list__append(InstancePredProcs0, - InstancePredProcs1, InstancePredProcs) - ; - MaybeInstancePredProcs = no, - InstancePredProcs = InstancePredProcs1 - ), - InstanceDefn = hlds_instance_defn(InstanceModuleName, B, - Context, InstanceConstraints, InstanceTypes, - InstanceBody, yes(InstancePredProcs), InstanceVarSet, I) - ; - MatchingInstanceMethods = [I1, I2 | Is], - % - % duplicate method definition error - % - OrderedInstanceMethods = OrderedInstanceMethods0, - InstanceDefn = InstanceDefn0, - ClassId = class_id(ClassName, _ClassArity), - mdbcomp__prim_data__sym_name_to_string(MethodName, - MethodNameString), - mdbcomp__prim_data__sym_name_to_string(ClassName, - ClassNameString), - PredOrFuncString = pred_or_func_to_string(PredOrFunc), - string__int_to_string(Arity, ArityString), - InstanceTypesString = mercury_type_list_to_string( - InstanceVarSet, InstanceTypes), - string__append_list([ - "In instance declaration for `", - ClassNameString, "(", InstanceTypesString, ")': ", - "multiple implementations of type class ", - PredOrFuncString, " method `", - MethodNameString, "/", ArityString, "'."], - ErrorHeader), - I1 = instance_method(_, _, _, _, I1Context), - Heading = - [I1Context - [words("First definition appears here.")], - InstanceContext - [words(ErrorHeader)]], - list__map((pred(Definition::in, ContextAndError::out) is det :- - Definition = instance_method(_, _, _, _, TheContext), - Error = [words("Subsequent definition appears here.")], - ContextAndError = TheContext - Error - ), [I2 | Is], SubsequentErrors), + MakeClassProc = (pred(TheProcId::in, PredProcId::out) is det :- + PredProcId = hlds_class_proc(InstancePredId, TheProcId) + ), + list__map(MakeClassProc, InstanceProcIds, InstancePredProcs1), + ( + MaybeInstancePredProcs = yes(InstancePredProcs0), + list__append(InstancePredProcs0, + InstancePredProcs1, InstancePredProcs) + ; + MaybeInstancePredProcs = no, + InstancePredProcs = InstancePredProcs1 + ), + InstanceDefn = hlds_instance_defn(InstanceModuleName, B, + Context, InstanceConstraints, InstanceTypes, + InstanceBody, yes(InstancePredProcs), InstanceVarSet, I) + ; + MatchingInstanceMethods = [I1, I2 | Is], + % Duplicate method definition error. + OrderedInstanceMethods = OrderedInstanceMethods0, + InstanceDefn = InstanceDefn0, + ClassId = class_id(ClassName, _ClassArity), + sym_name_to_string(MethodName, MethodNameString), + sym_name_to_string(ClassName, ClassNameString), + PredOrFuncString = pred_or_func_to_string(PredOrFunc), + string__int_to_string(Arity, ArityString), + InstanceTypesString = mercury_type_list_to_string(InstanceVarSet, + InstanceTypes), + string__append_list([ + "In instance declaration for `", + ClassNameString, "(", InstanceTypesString, ")': ", + "multiple implementations of type class ", + PredOrFuncString, " method `", + MethodNameString, "/", ArityString, "'."], + ErrorHeader), + I1 = instance_method(_, _, _, _, I1Context), + Heading = + [I1Context - [words("First definition appears here.")], + InstanceContext - [words(ErrorHeader)]], + list__map((pred(Definition::in, ContextAndError::out) is det :- + Definition = instance_method(_, _, _, _, TheContext), + Error = [words("Subsequent definition appears here.")], + ContextAndError = TheContext - Error + ), [I2 | Is], SubsequentErrors), - % errors are built up in reverse. - list__append(SubsequentErrors, Heading, NewErrors), - list__append(NewErrors, Errors0, Errors), - Info = instance_method_info(ModuleInfo, QualInfo, PredName, - Arity, ExistQVars, ArgTypes, ClassContext, - ArgModes, Errors, ArgTypeVars, Status, PredOrFunc) - ; - MatchingInstanceMethods = [], - % - % undefined method error - % - OrderedInstanceMethods = OrderedInstanceMethods0, - InstanceDefn = InstanceDefn0, - ClassId = class_id(ClassName, _ClassArity), - mdbcomp__prim_data__sym_name_to_string(ClassName, - ClassNameString), - InstanceTypesString = mercury_type_list_to_string( - InstanceVarSet, InstanceTypes), - - Error = [words("In instance declaration for"), - fixed("`" ++ ClassNameString - ++ "(" ++ InstanceTypesString - ++ ")'"), - suffix(":"), - words("no implementation for type class"), - pred_or_func(PredOrFunc), - words("method"), - sym_name_and_arity(MethodName / Arity), - suffix(".") - ], - Errors = [InstanceContext - Error | Errors0], - Info = instance_method_info(ModuleInfo, QualInfo, PredName, - Arity, ExistQVars, ArgTypes, ClassContext, - ArgModes, Errors, - ArgTypeVars, Status, PredOrFunc) - ). + % Errors are built up in reverse. + list__append(SubsequentErrors, Heading, NewErrors), + list__append(NewErrors, Errors0, Errors), + Info = instance_method_info(ModuleInfo, QualInfo, PredName, Arity, + ExistQVars, ArgTypes, ClassContext, ArgModes, Errors, ArgTypeVars, + Status, PredOrFunc) + ; + MatchingInstanceMethods = [], + % Undefined method error. + OrderedInstanceMethods = OrderedInstanceMethods0, + InstanceDefn = InstanceDefn0, + ClassId = class_id(ClassName, _ClassArity), + sym_name_to_string(ClassName, ClassNameString), + InstanceTypesString = mercury_type_list_to_string(InstanceVarSet, + InstanceTypes), + + Error = [words("In instance declaration for"), + fixed("`" ++ ClassNameString + ++ "(" ++ InstanceTypesString + ++ ")'"), + suffix(":"), + words("no implementation for type class"), + pred_or_func(PredOrFunc), + words("method"), + sym_name_and_arity(MethodName / Arity), + suffix(".") + ], + Errors = [InstanceContext - Error | Errors0], + Info = instance_method_info(ModuleInfo, QualInfo, PredName, + Arity, ExistQVars, ArgTypes, ClassContext, + ArgModes, Errors, + ArgTypeVars, Status, PredOrFunc) + ). - % - % Get all the instance definitions which match the specified - % predicate/function name/arity, with multiple clause definitions - % being combined into a single definition. - % + % Get all the instance definitions which match the specified + % predicate/function name/arity, with multiple clause definitions + % being combined into a single definition. + % :- pred get_matching_instance_defns(instance_body::in, pred_or_func::in, - sym_name::in, arity::in, list(instance_method)::out) is det. + sym_name::in, arity::in, list(instance_method)::out) is det. get_matching_instance_defns(abstract, _, _, _, []). get_matching_instance_defns(concrete(InstanceMethods), PredOrFunc, MethodName, - MethodArity, ResultList) :- - % - % First find the instance method definitions that match this - % predicate/function's name and arity - % - list__filter( - (pred(Method::in) is semidet :- - Method = instance_method(PredOrFunc, - MethodName, _MethodDefn, - MethodArity, _Context) - ), - InstanceMethods, MatchingMethods), - ( - MatchingMethods = [First, _Second | _], - First = instance_method(_, _, _, _, FirstContext), - \+ ( - list__member(DefnViaName, MatchingMethods), - DefnViaName = instance_method(_, _, name(_), _, _) - ) - -> - % - % If all of the instance method definitions for this - % pred/func are clauses, and there are more than one - % of them, then we must combine them all into a - % single definition. - % - MethodToClause = (pred(Method::in, Clauses::out) is semidet :- - Method = instance_method(_, _, Defn, _, _), - Defn = clauses(Clauses)), - list__filter_map(MethodToClause, MatchingMethods, ClausesList), - list__condense(ClausesList, FlattenedClauses), - CombinedMethod = instance_method(PredOrFunc, - MethodName, clauses(FlattenedClauses), - MethodArity, FirstContext), - ResultList = [CombinedMethod] - ; - % - % If there are less than two matching method definitions, - % or if any of the instance method definitions is a method - % name, then we're done. - % - ResultList = MatchingMethods - ). + MethodArity, ResultList) :- + % First find the instance method definitions that match this + % predicate/function's name and arity + list__filter( + (pred(Method::in) is semidet :- + Method = instance_method(PredOrFunc, MethodName, _MethodDefn, + MethodArity, _Context) + ), + InstanceMethods, MatchingMethods), + ( + MatchingMethods = [First, _Second | _], + First = instance_method(_, _, _, _, FirstContext), + \+ ( + list__member(DefnViaName, MatchingMethods), + DefnViaName = instance_method(_, _, name(_), _, _) + ) + -> + % If all of the instance method definitions for this pred/func + % are clauses, and there are more than one of them, then we must + % combine them all into a single definition. + MethodToClause = (pred(Method::in, Clauses::out) is semidet :- + Method = instance_method(_, _, Defn, _, _), + Defn = clauses(Clauses)), + list__filter_map(MethodToClause, MatchingMethods, ClausesList), + list__condense(ClausesList, FlattenedClauses), + CombinedMethod = instance_method(PredOrFunc, MethodName, + clauses(FlattenedClauses), MethodArity, FirstContext), + ResultList = [CombinedMethod] + ; + % If there are less than two matching method definitions, + % or if any of the instance method definitions is a method name, + % then we're done. + ResultList = MatchingMethods + ). :- pred produce_auxiliary_procs(class_id::in, list(tvar)::in, pred_markers::in, - list(type)::in, list(prog_constraint)::in, tvarset::in, - module_name::in, instance_proc_def::in, prog_context::in, - pred_id::out, list(proc_id)::out, - instance_method_info::in, instance_method_info::out, - io::di, io::uo) is det. + list(type)::in, list(prog_constraint)::in, tvarset::in, + module_name::in, instance_proc_def::in, prog_context::in, + pred_id::out, list(proc_id)::out, + instance_method_info::in, instance_method_info::out, + io::di, io::uo) is det. produce_auxiliary_procs(ClassId, ClassVars, Markers0, - InstanceTypes0, InstanceConstraints0, InstanceVarSet, - InstanceModuleName, InstancePredDefn, Context, PredId, - InstanceProcIds, Info0, Info, !IO) :- + InstanceTypes0, InstanceConstraints0, InstanceVarSet, + InstanceModuleName, InstancePredDefn, Context, PredId, + InstanceProcIds, Info0, Info, !IO) :- - Info0 = instance_method_info(ModuleInfo0, QualInfo0, PredName, - Arity, ExistQVars0, ArgTypes0, ClassMethodClassContext0, - ArgModes, Errors, ArgTypeVars0, Status0, PredOrFunc), + Info0 = instance_method_info(ModuleInfo0, QualInfo0, PredName, + Arity, ExistQVars0, ArgTypes0, ClassMethodClassContext0, + ArgModes, Errors, ArgTypeVars0, Status0, PredOrFunc), - % Rename the instance variables apart from the class variables - tvarset_merge_renaming(ArgTypeVars0, InstanceVarSet, ArgTypeVars1, - Renaming), - apply_variable_renaming_to_type_list(Renaming, InstanceTypes0, - InstanceTypes1), - apply_variable_renaming_to_prog_constraint_list(Renaming, - InstanceConstraints0, InstanceConstraints1), + % Rename the instance variables apart from the class variables. + tvarset_merge_renaming(ArgTypeVars0, InstanceVarSet, ArgTypeVars1, + Renaming), + apply_variable_renaming_to_type_list(Renaming, InstanceTypes0, + InstanceTypes1), + apply_variable_renaming_to_prog_constraint_list(Renaming, + InstanceConstraints0, InstanceConstraints1), - % Work out what the type variables are bound to for this - % instance, and update the class types appropriately. - map__from_corresponding_lists(ClassVars, InstanceTypes1, TypeSubst), - apply_subst_to_type_list(TypeSubst, ArgTypes0, ArgTypes1), - apply_subst_to_prog_constraints(TypeSubst, ClassMethodClassContext0, - ClassMethodClassContext1), + % Work out what the type variables are bound to for this + % instance, and update the class types appropriately. + map__from_corresponding_lists(ClassVars, InstanceTypes1, TypeSubst), + apply_subst_to_type_list(TypeSubst, ArgTypes0, ArgTypes1), + apply_subst_to_prog_constraints(TypeSubst, ClassMethodClassContext0, + ClassMethodClassContext1), - % Get rid of any unwanted type variables - prog_type__vars_list(ArgTypes1, VarsToKeep0), - list__sort_and_remove_dups(VarsToKeep0, VarsToKeep), - varset__squash(ArgTypeVars1, VarsToKeep, ArgTypeVars, SquashSubst), - apply_variable_renaming_to_type_list(SquashSubst, ArgTypes1, ArgTypes), - apply_variable_renaming_to_prog_constraints(SquashSubst, - ClassMethodClassContext1, ClassMethodClassContext), - apply_partial_map_to_list(ExistQVars0, SquashSubst, ExistQVars), - apply_variable_renaming_to_type_list(SquashSubst, InstanceTypes1, - InstanceTypes), - apply_variable_renaming_to_prog_constraint_list(SquashSubst, - InstanceConstraints1, InstanceConstraints), + % Get rid of any unwanted type variables. + prog_type__vars_list(ArgTypes1, VarsToKeep0), + list__sort_and_remove_dups(VarsToKeep0, VarsToKeep), + varset__squash(ArgTypeVars1, VarsToKeep, ArgTypeVars, SquashSubst), + apply_variable_renaming_to_type_list(SquashSubst, ArgTypes1, ArgTypes), + apply_variable_renaming_to_prog_constraints(SquashSubst, + ClassMethodClassContext1, ClassMethodClassContext), + apply_partial_map_to_list(ExistQVars0, SquashSubst, ExistQVars), + apply_variable_renaming_to_type_list(SquashSubst, InstanceTypes1, + InstanceTypes), + apply_variable_renaming_to_prog_constraint_list(SquashSubst, + InstanceConstraints1, InstanceConstraints), - % Add the constraints from the instance declaration to the - % constraints from the class method. This allows an instance - % method to have constraints on it which are not part of the - % instance declaration as a whole. - ClassMethodClassContext = constraints(UnivConstraints1, - ExistConstraints), - list__append(InstanceConstraints, UnivConstraints1, UnivConstraints), - ClassContext = constraints(UnivConstraints, ExistConstraints), + % Add the constraints from the instance declaration to the constraints + % from the class method. This allows an instance method to have constraints + % on it which are not part of the instance declaration as a whole. + ClassMethodClassContext = constraints(UnivConstraints1, ExistConstraints), + list__append(InstanceConstraints, UnivConstraints1, UnivConstraints), + ClassContext = constraints(UnivConstraints, ExistConstraints), - % Introduce a new predicate which calls the implementation - % given in the instance declaration. - map__init(Proofs), - map__init(ConstraintMap), - add_marker(class_instance_method, Markers0, Markers1), - ( InstancePredDefn = name(_) -> - % For instance methods which are defined using the named - % syntax (e.g. "pred(...) is ...") rather than the clauses - % syntax, we record an additional marker; the only effect - % of this marker is that we output slightly different - % error messages for such predicates. - add_marker(named_class_instance_method, Markers1, Markers) - ; - Markers = Markers1 - ), - module_info_get_globals(ModuleInfo0, Globals), - globals__lookup_string_option(Globals, aditi_user, User), + % Introduce a new predicate which calls the implementation + % given in the instance declaration. + map__init(Proofs), + map__init(ConstraintMap), + add_marker(class_instance_method, Markers0, Markers1), + ( InstancePredDefn = name(_) -> + % For instance methods which are defined using the named syntax + % (e.g. "pred(...) is ...") rather than the clauses syntax, we record + % an additional marker; the only effect of this marker is that we + % output slightly different error messages for such predicates. + add_marker(named_class_instance_method, Markers1, Markers) + ; + Markers = Markers1 + ), + module_info_get_globals(ModuleInfo0, Globals), + globals__lookup_string_option(Globals, aditi_user, User), - ( status_is_imported(Status0, yes) -> - Status = opt_imported - ; - Status = Status0 - ), + ( status_is_imported(Status0, yes) -> + Status = opt_imported + ; + Status = Status0 + ), - adjust_func_arity(PredOrFunc, Arity, PredArity), - produce_instance_method_clauses(InstancePredDefn, PredOrFunc, - PredArity, ArgTypes, Markers, Context, Status, ClausesInfo, - ModuleInfo0, ModuleInfo1, QualInfo0, QualInfo, !IO), + adjust_func_arity(PredOrFunc, Arity, PredArity), + produce_instance_method_clauses(InstancePredDefn, PredOrFunc, + PredArity, ArgTypes, Markers, Context, Status, ClausesInfo, + ModuleInfo0, ModuleInfo1, QualInfo0, QualInfo, !IO), - % Fill in some information in the pred_info which is - % used by polymorphism to make sure the type-infos - % and typeclass-infos are added in the correct order. - MethodConstraints = instance_method_constraints(ClassId, - InstanceTypes, InstanceConstraints, ClassMethodClassContext), - pred_info_init(InstanceModuleName, PredName, PredArity, PredOrFunc, - Context, instance_method(MethodConstraints), Status, none, - Markers, ArgTypes, ArgTypeVars, ExistQVars, ClassContext, - Proofs, ConstraintMap, User, ClausesInfo, PredInfo0), - pred_info_set_clauses_info(ClausesInfo, PredInfo0, PredInfo1), + % Fill in some information in the pred_info which is used by polymorphism + % to make sure the type-infos and typeclass-infos are added in the correct + % order. + MethodConstraints = instance_method_constraints(ClassId, + InstanceTypes, InstanceConstraints, ClassMethodClassContext), + pred_info_init(InstanceModuleName, PredName, PredArity, PredOrFunc, + Context, instance_method(MethodConstraints), Status, none, + Markers, ArgTypes, ArgTypeVars, ExistQVars, ClassContext, + Proofs, ConstraintMap, User, ClausesInfo, PredInfo0), + pred_info_set_clauses_info(ClausesInfo, PredInfo0, PredInfo1), - % Add procs with the expected modes and determinisms - AddProc = (pred(ModeAndDet::in, NewProcId::out, - OldPredInfo::in, NewPredInfo::out) is det :- - ModeAndDet = modes_and_detism(Modes, InstVarSet, MaybeDet), - add_new_proc(InstVarSet, PredArity, Modes, yes(Modes), no, - MaybeDet, Context, address_is_taken, - OldPredInfo, NewPredInfo, NewProcId) - ), - list__map_foldl(AddProc, ArgModes, InstanceProcIds, - PredInfo1, PredInfo), + % Add procs with the expected modes and determinisms + AddProc = (pred(ModeAndDet::in, NewProcId::out, + OldPredInfo::in, NewPredInfo::out) is det :- + ModeAndDet = modes_and_detism(Modes, InstVarSet, MaybeDet), + add_new_proc(InstVarSet, PredArity, Modes, yes(Modes), no, + MaybeDet, Context, address_is_taken, + OldPredInfo, NewPredInfo, NewProcId) + ), + list__map_foldl(AddProc, ArgModes, InstanceProcIds, PredInfo1, PredInfo), - module_info_get_predicate_table(ModuleInfo1, PredicateTable1), - module_info_get_partial_qualifier_info(ModuleInfo1, PQInfo), - % XXX why do we need to pass may_be_unqualified here, - % rather than passing must_be_qualified or calling the /4 version? - predicate_table_insert(PredInfo, may_be_unqualified, PQInfo, - PredId, PredicateTable1, PredicateTable), - module_info_set_predicate_table(PredicateTable, - ModuleInfo1, ModuleInfo), + module_info_get_predicate_table(ModuleInfo1, PredicateTable1), + module_info_get_partial_qualifier_info(ModuleInfo1, PQInfo), + % XXX Why do we need to pass may_be_unqualified here, + % rather than passing must_be_qualified or calling the /4 version? + predicate_table_insert(PredInfo, may_be_unqualified, PQInfo, PredId, + PredicateTable1, PredicateTable), + module_info_set_predicate_table(PredicateTable, ModuleInfo1, ModuleInfo), - Info = instance_method_info(ModuleInfo, QualInfo, PredName, Arity, - ExistQVars, ArgTypes, ClassContext, ArgModes, Errors, - ArgTypeVars, Status, PredOrFunc). + Info = instance_method_info(ModuleInfo, QualInfo, PredName, Arity, + ExistQVars, ArgTypes, ClassContext, ArgModes, Errors, + ArgTypeVars, Status, PredOrFunc). %---------------------------------------------------------------------------% - % Make the name of the introduced pred used to check a particular - % instance of a particular class method - % - % XXX This isn't quite perfect, I suspect - + % Make the name of the introduced pred used to check a particular + % instance of a particular class method + % + % XXX This isn't quite perfect, I suspect + % :- pred make_introduced_pred_name(class_id::in, sym_name::in, arity::in, - list(type)::in, sym_name::out) is det. + list(type)::in, sym_name::out) is det. -make_introduced_pred_name(ClassId, MethodName, Arity, - InstanceTypes, PredName) :- - ClassId = class_id(ClassName, _ClassArity), - mdbcomp__prim_data__sym_name_to_string(ClassName, "__", - ClassNameString), - mdbcomp__prim_data__sym_name_to_string(MethodName, "__", - MethodNameString), - % Perhaps we should include the arity in this mangled - % string? - string__int_to_string(Arity, ArityString), - make_instance_string(InstanceTypes, InstanceString), - string__append_list( - [check_typeclass__introduced_pred_name_prefix, - ClassNameString, "____", - InstanceString, "____", - MethodNameString, "_", - ArityString], - PredNameString), - PredName = unqualified(PredNameString). +make_introduced_pred_name(ClassId, MethodName, Arity, InstanceTypes, + PredName) :- + ClassId = class_id(ClassName, _ClassArity), + sym_name_to_string(ClassName, "__", ClassNameString), + sym_name_to_string(MethodName, "__", MethodNameString), + % Perhaps we should include the arity in this mangled string? + string__int_to_string(Arity, ArityString), + make_instance_string(InstanceTypes, InstanceString), + string__append_list( + [check_typeclass__introduced_pred_name_prefix, + ClassNameString, "____", + InstanceString, "____", + MethodNameString, "_", + ArityString], + PredNameString), + PredName = unqualified(PredNameString). - % The prefix added to the class method name for the predicate - % used to call a class method for a specific instance. + % The prefix added to the class method name for the predicate + % used to call a class method for a specific instance. + % :- func check_typeclass__introduced_pred_name_prefix = string. check_typeclass__introduced_pred_name_prefix = "ClassMethod_for_". %---------------------------------------------------------------------------% - % Check that the superclass constraints are satisfied for the - % types in this instance declaration. - + % Check that the superclass constraints are satisfied for the + % types in this instance declaration. + % :- pred check_superclass_conformance(class_id::in, list(prog_constraint)::in, - list(tvar)::in, tvarset::in, module_info::in, - hlds_instance_defn::in, hlds_instance_defn::out, - error_messages::in, error_messages::out) is det. + list(tvar)::in, tvarset::in, module_info::in, + hlds_instance_defn::in, hlds_instance_defn::out, + error_messages::in, error_messages::out) is det. check_superclass_conformance(ClassId, ProgSuperClasses0, ClassVars0, - ClassVarSet, ModuleInfo, InstanceDefn0, InstanceDefn, - Errors0, Errors) :- + ClassVarSet, ModuleInfo, InstanceDefn0, InstanceDefn, !Errors) :- - InstanceDefn0 = hlds_instance_defn(A, B, Context, - InstanceProgConstraints, InstanceTypes, F, G, InstanceVarSet0, - Proofs0), - tvarset_merge_renaming(InstanceVarSet0, ClassVarSet, InstanceVarSet1, - Renaming), + InstanceDefn0 = hlds_instance_defn(A, B, Context, InstanceProgConstraints, + InstanceTypes, F, G, InstanceVarSet0, Proofs0), + tvarset_merge_renaming(InstanceVarSet0, ClassVarSet, InstanceVarSet1, + Renaming), - % Make the constraints in terms of the instance variables - apply_variable_renaming_to_prog_constraint_list(Renaming, - ProgSuperClasses0, ProgSuperClasses), + % Make the constraints in terms of the instance variables. + apply_variable_renaming_to_prog_constraint_list(Renaming, + ProgSuperClasses0, ProgSuperClasses), - % Now handle the class variables - apply_variable_renaming_to_tvar_list(Renaming, ClassVars0, ClassVars), + % Now handle the class variables. + apply_variable_renaming_to_tvar_list(Renaming, ClassVars0, ClassVars), - % Calculate the bindings - map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst), + % Calculate the bindings. + map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst), - module_info_get_class_table(ModuleInfo, ClassTable), - module_info_get_instance_table(ModuleInfo, InstanceTable), - module_info_get_superclass_table(ModuleInfo, SuperClassTable), + module_info_get_class_table(ModuleInfo, ClassTable), + module_info_get_instance_table(ModuleInfo, InstanceTable), + module_info_get_superclass_table(ModuleInfo, SuperClassTable), - % Build a suitable constraint context for checking the - % instance. To do this, we assume any constraints on the - % instance declaration (that is, treat them as universal - % constraints on a predicate) and try to prove the constraints - % on the class declaration (that is, treat them as existential - % constraints on a predicate). - % - % We don't bother assigning ids to these constraints, since - % the resulting constraint map is not used anyway. - % - init_hlds_constraint_list(ProgSuperClasses, SuperClasses), - init_hlds_constraint_list(InstanceProgConstraints, - InstanceConstraints), - make_hlds_constraints(ClassTable, InstanceVarSet1, SuperClasses, - InstanceConstraints, Constraints0), - - % Try to reduce the superclass constraints, using the declared - % instance constraints and the usual context reduction rules. - % - map__init(ConstraintMap0), - typeclasses__reduce_context_by_rule_application(ClassTable, - InstanceTable, SuperClassTable, ClassVars, TypeSubst, _, - InstanceVarSet1, InstanceVarSet2, - Proofs0, Proofs1, ConstraintMap0, _, - Constraints0, Constraints), - UnprovenConstraints = Constraints ^ unproven, + % Build a suitable constraint context for checking the instance. + % To do this, we assume any constraints on the instance declaration + % (that is, treat them as universal constraints on a predicate) and try + % to prove the constraints on the class declaration (that is, treat them + % as existential constraints on a predicate). + % + % We don't bother assigning ids to these constraints, since the resulting + % constraint map is not used anyway. + % + init_hlds_constraint_list(ProgSuperClasses, SuperClasses), + init_hlds_constraint_list(InstanceProgConstraints, InstanceConstraints), + make_hlds_constraints(ClassTable, InstanceVarSet1, SuperClasses, + InstanceConstraints, Constraints0), + + % Try to reduce the superclass constraints, using the declared instance + % constraints and the usual context reduction rules. + map__init(ConstraintMap0), + typeclasses__reduce_context_by_rule_application(ClassTable, + InstanceTable, SuperClassTable, ClassVars, TypeSubst, _, + InstanceVarSet1, InstanceVarSet2, + Proofs0, Proofs1, ConstraintMap0, _, + Constraints0, Constraints), + UnprovenConstraints = Constraints ^ unproven, - ( - UnprovenConstraints = [], - Errors = Errors0, - InstanceDefn = hlds_instance_defn(A, B, Context, - InstanceProgConstraints, InstanceTypes, F, G, - InstanceVarSet2, Proofs1) - ; - UnprovenConstraints = [_ | _], - ClassId = class_id(ClassName, _ClassArity), - mdbcomp__prim_data__sym_name_to_string(ClassName, - ClassNameString), - InstanceTypesString = mercury_type_list_to_string( - InstanceVarSet2, InstanceTypes), - constraint_list_to_string(ClassVarSet, UnprovenConstraints, - ConstraintsString), - string__append_list([ - "In instance declaration for `", - ClassNameString, "(", InstanceTypesString, ")': ", - "superclass constraint(s) not satisfied: ", - ConstraintsString, "."], - NewError), - Errors = [Context - [words(NewError)] | Errors0], - InstanceDefn = InstanceDefn0 - ). + ( + UnprovenConstraints = [], + InstanceDefn = hlds_instance_defn(A, B, Context, + InstanceProgConstraints, InstanceTypes, F, G, + InstanceVarSet2, Proofs1) + ; + UnprovenConstraints = [_ | _], + ClassId = class_id(ClassName, _ClassArity), + sym_name_to_string(ClassName, ClassNameString), + InstanceTypesString = mercury_type_list_to_string(InstanceVarSet2, + InstanceTypes), + constraint_list_to_string(ClassVarSet, UnprovenConstraints, + ConstraintsString), + string__append_list([ + "In instance declaration for `", + ClassNameString, "(", InstanceTypesString, ")': ", + "superclass constraint(s) not satisfied: ", + ConstraintsString, "."], + NewError), + !:Errors = [Context - [words(NewError)] | !.Errors], + InstanceDefn = InstanceDefn0 + ). :- pred constraint_list_to_string(tvarset::in, list(hlds_constraint)::in, - string::out) is det. + string::out) is det. constraint_list_to_string(_, [], ""). constraint_list_to_string(VarSet, [C | Cs], String) :- - retrieve_prog_constraint(C, P), - String0 = mercury_constraint_to_string(VarSet, P), - constraint_list_to_string_2(VarSet, Cs, String1), - string__append_list(["`", String0, "'", String1], String). + retrieve_prog_constraint(C, P), + String0 = mercury_constraint_to_string(VarSet, P), + constraint_list_to_string_2(VarSet, Cs, String1), + string__append_list(["`", String0, "'", String1], String). :- pred constraint_list_to_string_2(tvarset::in, list(hlds_constraint)::in, - string::out) is det. + string::out) is det. constraint_list_to_string_2(_VarSet, [], ""). constraint_list_to_string_2(VarSet, [C | Cs], String) :- - retrieve_prog_constraint(C, P), - String0 = mercury_constraint_to_string(VarSet, P), - constraint_list_to_string_2(VarSet, Cs, String1), - string__append_list([", `", String0, "'", String1], String). + retrieve_prog_constraint(C, P), + String0 = mercury_constraint_to_string(VarSet, P), + constraint_list_to_string_2(VarSet, Cs, String1), + string__append_list([", `", String0, "'", String1], String). %---------------------------------------------------------------------------% -% -% Check that every abstract instance in the interface of a module -% has a corresponding concrete instance in the implementation. -% + % Check that every abstract instance in the interface of a module + % has a corresponding concrete instance in the implementation. + % :- pred check_for_missing_concrete_instances( - module_info::in, module_info::out, bool::out, io::di, io::uo) is det. + module_info::in, module_info::out, bool::out, io::di, io::uo) is det. check_for_missing_concrete_instances(!ModuleInfo, FoundError, !IO) :- - module_info_get_instance_table(!.ModuleInfo, InstanceTable), - % - % Grab all the abstract instance declarations in the interface - % of this module and all the concrete instances defined in the - % implementation. - % - gather_abstract_and_concrete_instances(InstanceTable, - AbstractInstances, ConcreteInstances), - map.foldl2(check_for_corresponding_instances(ConcreteInstances), - AbstractInstances, no, FoundError, !IO). + module_info_get_instance_table(!.ModuleInfo, InstanceTable), + % Grab all the abstract instance declarations in the interface of this + % module and all the concrete instances defined in the implementation. + gather_abstract_and_concrete_instances(InstanceTable, + AbstractInstances, ConcreteInstances), + map.foldl2(check_for_corresponding_instances(ConcreteInstances), + AbstractInstances, no, FoundError, !IO). - % gather_abstract_and_concrete_instances(Table, - % AbstractInstances, ConcreteInstances). - % - % Search the instance_table and create a table of abstract - % instances that occur in the module interface and a table of - % concrete instances that occur in the module implementation. - % Imported instances are not included at all. - % + % gather_abstract_and_concrete_instances(Table, + % AbstractInstances, ConcreteInstances). + % + % Search the instance_table and create a table of abstract + % instances that occur in the module interface and a table of + % concrete instances that occur in the module implementation. + % Imported instances are not included at all. + % :- pred gather_abstract_and_concrete_instances(instance_table::in, - instance_table::out, instance_table::out) is det. + instance_table::out, instance_table::out) is det. gather_abstract_and_concrete_instances(InstanceTable, Abstracts, - Concretes) :- - map.foldl2(partition_instances_for_class, InstanceTable, - multi_map.init, Abstracts, multi_map.init, Concretes). + Concretes) :- + map.foldl2(partition_instances_for_class, InstanceTable, + multi_map.init, Abstracts, multi_map.init, Concretes). - % Partition all the non-imported instances for a particular - % class into two groups, those that are abstract and in the - % module interface and those that are concrete and in the module - % implementation. Concrete instances cannot occur in the - % interface and we ignore abstract instances in the - % implementation. - % + % Partition all the non-imported instances for a particular + % class into two groups, those that are abstract and in the + % module interface and those that are concrete and in the module + % implementation. Concrete instances cannot occur in the + % interface and we ignore abstract instances in the implementation. + % :- pred partition_instances_for_class(class_id::in, - list(hlds_instance_defn)::in, instance_table::in, instance_table::out, - instance_table::in, instance_table::out) is det. + list(hlds_instance_defn)::in, instance_table::in, instance_table::out, + instance_table::in, instance_table::out) is det. partition_instances_for_class(ClassId, Instances, !Abstracts, !Concretes) :- - list.foldl2(partition_instances_for_class_2(ClassId), Instances, - !Abstracts, !Concretes). + list.foldl2(partition_instances_for_class_2(ClassId), Instances, + !Abstracts, !Concretes). :- pred partition_instances_for_class_2(class_id::in, hlds_instance_defn::in, - instance_table::in, instance_table::out, - instance_table::in, instance_table::out) is det. + instance_table::in, instance_table::out, + instance_table::in, instance_table::out) is det. partition_instances_for_class_2(ClassId, InstanceDefn, !Abstracts, - !Concretes) :- - ImportStatus = InstanceDefn ^ instance_status, - status_is_imported(ImportStatus, IsImported), - ( - IsImported = no, - Body = InstanceDefn ^ instance_body, - ( - Body = abstract, - status_is_exported_to_non_submodules(ImportStatus, - IsExported), - ( - IsExported = yes, - svmulti_map.add(ClassId, InstanceDefn, - !Abstracts) - ; - IsExported = no - ) - ; - Body = concrete(_), - svmulti_map.add(ClassId, InstanceDefn, - !Concretes) - ) - ; - IsImported = yes - ). + !Concretes) :- + ImportStatus = InstanceDefn ^ instance_status, + status_is_imported(ImportStatus, IsImported), + ( + IsImported = no, + Body = InstanceDefn ^ instance_body, + ( + Body = abstract, + status_is_exported_to_non_submodules(ImportStatus, IsExported), + ( + IsExported = yes, + svmulti_map.add(ClassId, InstanceDefn, !Abstracts) + ; + IsExported = no + ) + ; + Body = concrete(_), + svmulti_map.add(ClassId, InstanceDefn, !Concretes) + ) + ; + IsImported = yes + ). :- pred check_for_corresponding_instances(instance_table::in, - class_id::in, list(hlds_instance_defn)::in, bool::in, bool::out, - io::di, io::uo) is det. + class_id::in, list(hlds_instance_defn)::in, bool::in, bool::out, + io::di, io::uo) is det. check_for_corresponding_instances(Concretes, ClassId, InstanceDefns, - !FoundError, !IO) :- - list.foldl2(check_for_corresponding_instances_2(Concretes, ClassId), - InstanceDefns, !FoundError, !IO). + !FoundError, !IO) :- + list.foldl2(check_for_corresponding_instances_2(Concretes, ClassId), + InstanceDefns, !FoundError, !IO). :- pred check_for_corresponding_instances_2(instance_table::in, class_id::in, - hlds_instance_defn::in, bool::in, bool::out, io::di, io::uo) is det. + hlds_instance_defn::in, bool::in, bool::out, io::di, io::uo) is det. check_for_corresponding_instances_2(Concretes, ClassId, AbstractInstance, - !FoundError, !IO) :- - AbstractTypes = AbstractInstance ^ instance_types, - ( multi_map.search(Concretes, ClassId, ConcreteInstances) -> - ( - list.member(ConcreteInstance, ConcreteInstances), - ConcreteTypes = ConcreteInstance ^ instance_types, - ConcreteTypes = AbstractTypes - -> - MissingConcreteError = no - ; - % There were concrete instances for ClassId in the - % implementation but none of them matches the - % abstract instance we have. - MissingConcreteError = yes - ) - ; - % There were no concrete instances for ClassId in the - % implementation. - MissingConcreteError = yes - ), - ( - MissingConcreteError = yes, - ClassId = class_id(ClassName, _), - prim_data.sym_name_to_string(ClassName, ClassNameString), - AbstractTypesString = mercury_type_list_to_string( - AbstractInstance ^ instance_tvarset, AbstractTypes), - AbstractInstanceName = "`" ++ ClassNameString ++ - "(" ++ AbstractTypesString ++ ")'", - % XXX Should we mention any constraints on the instance - % declaration here? - ErrorPieces = [words("Error: abstract instance declaration"), - words("for"), fixed(AbstractInstanceName), - words("has no corresponding concrete"), - words("instance in the implementation.") - ], - AbstractInstanceContext = AbstractInstance ^ instance_context, - write_error_pieces(AbstractInstanceContext, 0, ErrorPieces, - !IO), - !:FoundError = yes, - io.set_exit_status(1, !IO) - ; - MissingConcreteError = no - ). + !FoundError, !IO) :- + AbstractTypes = AbstractInstance ^ instance_types, + ( multi_map.search(Concretes, ClassId, ConcreteInstances) -> + ( + list.member(ConcreteInstance, ConcreteInstances), + ConcreteTypes = ConcreteInstance ^ instance_types, + ConcreteTypes = AbstractTypes + -> + MissingConcreteError = no + ; + % There were concrete instances for ClassId in the implementation + % but none of them matches the abstract instance we have. + MissingConcreteError = yes + ) + ; + % There were no concrete instances for ClassId in the implementation. + MissingConcreteError = yes + ), + ( + MissingConcreteError = yes, + ClassId = class_id(ClassName, _), + sym_name_to_string(ClassName, ClassNameString), + AbstractTypesString = mercury_type_list_to_string( + AbstractInstance ^ instance_tvarset, AbstractTypes), + AbstractInstanceName = "`" ++ ClassNameString ++ + "(" ++ AbstractTypesString ++ ")'", + % XXX Should we mention any constraints on the instance + % declaration here? + ErrorPieces = [words("Error: abstract instance declaration"), + words("for"), fixed(AbstractInstanceName), + words("has no corresponding concrete"), + words("instance in the implementation.") + ], + AbstractInstanceContext = AbstractInstance ^ instance_context, + write_error_pieces(AbstractInstanceContext, 0, ErrorPieces, !IO), + !:FoundError = yes, + io.set_exit_status(1, !IO) + ; + MissingConcreteError = no + ). %-----------------------------------------------------------------------------% -% -% Check for cyclic classes in the class table by traversing the -% class hierarchy for each class. While we are doing this, calculate -% the set of ancestors with functional dependencies for each class, -% and enter this information in the class table. -% + % Check for cyclic classes in the class table by traversing the class + % hierarchy for each class. While we are doing this, calculate the set + % of ancestors with functional dependencies for each class, and enter + % this information in the class table. + % :- pred check_for_cyclic_classes(module_info::in, module_info::out, bool::out, - io::di, io::uo) is det. + io::di, io::uo) is det. check_for_cyclic_classes(!ModuleInfo, Errors, !IO) :- - module_info_get_class_table(!.ModuleInfo, ClassTable0), - ClassIds = map__keys(ClassTable0), - foldl3(find_cycles([]), ClassIds, ClassTable0, ClassTable, set.init, _, - [], Cycles), - ( - Cycles = [], - Errors = no - ; - Cycles = [_ | _], - Errors = yes, - foldl(report_cyclic_classes(ClassTable), Cycles, !IO) - ), - module_info_set_class_table(ClassTable, !ModuleInfo). + module_info_get_class_table(!.ModuleInfo, ClassTable0), + ClassIds = map__keys(ClassTable0), + foldl3(find_cycles([]), ClassIds, ClassTable0, ClassTable, set.init, _, + [], Cycles), + ( + Cycles = [], + Errors = no + ; + Cycles = [_ | _], + Errors = yes, + foldl(report_cyclic_classes(ClassTable), Cycles, !IO) + ), + module_info_set_class_table(ClassTable, !ModuleInfo). :- type class_path == list(class_id). - % find_cycles(Path, ClassId, !ClassTable, !Visited, !Cycles) - % - % Perform a depth first traversal of the class hierarchy, starting - % from ClassId. Path contains a list of nodes joining the current - % node to the root. When we reach a node that has already been - % visited, check whether there is a cycle in the Path. - % + % find_cycles(Path, ClassId, !ClassTable, !Visited, !Cycles) + % + % Perform a depth first traversal of the class hierarchy, starting + % from ClassId. Path contains a list of nodes joining the current + % node to the root. When we reach a node that has already been visited, + % check whether there is a cycle in the Path. + % :- pred find_cycles(class_path::in, class_id::in, - class_table::in, class_table::out, - set(class_id)::in, set(class_id)::out, - list(class_path)::in, list(class_path)::out) is det. + class_table::in, class_table::out, + set(class_id)::in, set(class_id)::out, + list(class_path)::in, list(class_path)::out) is det. find_cycles(Path, ClassId, !ClassTable, !Visited, !Cycles) :- - find_cycles_2(Path, ClassId, _, _, !ClassTable, !Visited, !Cycles). + find_cycles_2(Path, ClassId, _, _, !ClassTable, !Visited, !Cycles). - % As above, but also return this class's parameters and ancestor list. - % + % As above, but also return this class's parameters and ancestor list. + % :- pred find_cycles_2(class_path::in, class_id::in, list(tvar)::out, - list(prog_constraint)::out, class_table::in, class_table::out, - set(class_id)::in, set(class_id)::out, - list(class_path)::in, list(class_path)::out) is det. + list(prog_constraint)::out, class_table::in, class_table::out, + set(class_id)::in, set(class_id)::out, + list(class_path)::in, list(class_path)::out) is det. find_cycles_2(Path, ClassId, Params, Ancestors, !ClassTable, !Visited, - !Cycles) :- - ClassDefn0 = map.lookup(!.ClassTable, ClassId), - Params = ClassDefn0 ^ class_vars, - Kinds = ClassDefn0 ^ class_kinds, - ( set.member(ClassId, !.Visited) -> - ( - find_cycle(ClassId, Path, [ClassId], Cycle) - -> - !:Cycles = [Cycle | !.Cycles] - ; - true - ), - Ancestors = ClassDefn0 ^ class_fundep_ancestors - ; - svset.insert(ClassId, !Visited), + !Cycles) :- + ClassDefn0 = map.lookup(!.ClassTable, ClassId), + Params = ClassDefn0 ^ class_vars, + Kinds = ClassDefn0 ^ class_kinds, + ( set.member(ClassId, !.Visited) -> + ( find_cycle(ClassId, Path, [ClassId], Cycle) -> + !:Cycles = [Cycle | !.Cycles] + ; + true + ), + Ancestors = ClassDefn0 ^ class_fundep_ancestors + ; + svset.insert(ClassId, !Visited), - % - % Make this class its own ancestor, but only if it - % has fundeps on it. - % - FunDeps = ClassDefn0 ^ class_fundeps, - ( - FunDeps = [], - Ancestors0 = [] - ; - FunDeps = [_ | _], - ClassId = class_id(ClassName, _), - prog_type.var_list_to_type_list(Kinds, Params, Args), - Ancestors0 = [constraint(ClassName, Args)] - ), - Superclasses = ClassDefn0 ^ class_supers, - foldl4(find_cycles_3([ClassId | Path]), Superclasses, - !ClassTable, !Visited, !Cycles, Ancestors0, Ancestors), - ClassDefn = ClassDefn0 ^ class_fundep_ancestors := Ancestors, - svmap.det_update(ClassId, ClassDefn, !ClassTable) - ). + % Make this class its own ancestor, but only if it has fundeps on it. + FunDeps = ClassDefn0 ^ class_fundeps, + ( + FunDeps = [], + Ancestors0 = [] + ; + FunDeps = [_ | _], + ClassId = class_id(ClassName, _), + prog_type.var_list_to_type_list(Kinds, Params, Args), + Ancestors0 = [constraint(ClassName, Args)] + ), + Superclasses = ClassDefn0 ^ class_supers, + foldl4(find_cycles_3([ClassId | Path]), Superclasses, + !ClassTable, !Visited, !Cycles, Ancestors0, Ancestors), + ClassDefn = ClassDefn0 ^ class_fundep_ancestors := Ancestors, + svmap.det_update(ClassId, ClassDefn, !ClassTable) + ). - % As we go, accumulate the ancestors from all the superclasses, - % with the class parameters bound to the corresponding arguments. - % Note that we don't need to merge varsets because typeclass - % parameters are guaranteed to be distinct variables. - % + % As we go, accumulate the ancestors from all the superclasses, + % with the class parameters bound to the corresponding arguments. + % Note that we don't need to merge varsets because typeclass + % parameters are guaranteed to be distinct variables. + % :- pred find_cycles_3(class_path::in, prog_constraint::in, - class_table::in, class_table::out, - set(class_id)::in, set(class_id)::out, - list(class_path)::in, list(class_path)::out, - list(prog_constraint)::in, list(prog_constraint)::out) is det. + class_table::in, class_table::out, + set(class_id)::in, set(class_id)::out, + list(class_path)::in, list(class_path)::out, + list(prog_constraint)::in, list(prog_constraint)::out) is det. find_cycles_3(Path, Constraint, !ClassTable, !Visited, !Cycles, !Ancestors) :- - Constraint = constraint(Name, Args), - list.length(Args, Arity), - ClassId = class_id(Name, Arity), - find_cycles_2(Path, ClassId, Params, NewAncestors0, !ClassTable, - !Visited, !Cycles), - map.from_corresponding_lists(Params, Args, Binding), - apply_subst_to_prog_constraint_list(Binding, NewAncestors0, - NewAncestors), - list.append(NewAncestors, !Ancestors). + Constraint = constraint(Name, Args), + list.length(Args, Arity), + ClassId = class_id(Name, Arity), + find_cycles_2(Path, ClassId, Params, NewAncestors0, !ClassTable, + !Visited, !Cycles), + map.from_corresponding_lists(Params, Args, Binding), + apply_subst_to_prog_constraint_list(Binding, NewAncestors0, + NewAncestors), + list.append(NewAncestors, !Ancestors). - % find_cycle(ClassId, PathRemaining, PathSoFar, Cycle) - % - % Check if ClassId is present in PathRemaining, and if so then make - % a cycle out of the front part of the path up to the point where - % the ClassId is found. The part of the path checked so far is - % accumulated in PathSoFar. - % + % find_cycle(ClassId, PathRemaining, PathSoFar, Cycle): + % + % Check if ClassId is present in PathRemaining, and if so then make + % a cycle out of the front part of the path up to the point where + % the ClassId is found. The part of the path checked so far is + % accumulated in PathSoFar. + % :- pred find_cycle(class_id::in, class_path::in, class_path::in, - class_path::out) is semidet. + class_path::out) is semidet. find_cycle(ClassId, [Head | Tail], Path0, Cycle) :- - Path = [Head | Path0], - ( ClassId = Head -> - Cycle = Path - ; - find_cycle(ClassId, Tail, Path, Cycle) - ). + Path = [Head | Path0], + ( ClassId = Head -> + Cycle = Path + ; + find_cycle(ClassId, Tail, Path, Cycle) + ). - % Report an error using the format - % - % module.m:NNN: Error: cyclic superclass relation detected: - % module.m:NNN: `foo/N' <= `bar/N' <= `baz/N' <= `foo/N' - % + % Report an error using the format + % + % module.m:NNN: Error: cyclic superclass relation detected: + % module.m:NNN: `foo/N' <= `bar/N' <= `baz/N' <= `foo/N' + % :- pred report_cyclic_classes(class_table::in, class_path::in, io::di, io::uo) - is det. + is det. report_cyclic_classes(ClassTable, ClassPath, !IO) :- - ( - ClassPath = [], - unexpected(this_file, - "report_cyclic_classes: empty cycle found.") - ; - ClassPath = [ClassId | Tail], - Context = map.lookup(ClassTable, ClassId) ^ class_context, - ClassId = class_id(Name, Arity), - RevPieces0 = [ - sym_name_and_arity(Name/Arity), - words("Error: cyclic superclass relation detected:") - ], - RevPieces1 = foldl(add_path_element, Tail, RevPieces0), - Pieces = list.reverse(RevPieces1), - write_error_pieces(Context, 0, Pieces, !IO) - ). + ( + ClassPath = [], + unexpected(this_file, "report_cyclic_classes: empty cycle found.") + ; + ClassPath = [ClassId | Tail], + Context = map.lookup(ClassTable, ClassId) ^ class_context, + ClassId = class_id(Name, Arity), + RevPieces0 = [ + sym_name_and_arity(Name/Arity), + words("Error: cyclic superclass relation detected:") + ], + RevPieces1 = foldl(add_path_element, Tail, RevPieces0), + Pieces = list.reverse(RevPieces1), + write_error_pieces(Context, 0, Pieces, !IO) + ). :- func add_path_element(class_id, list(format_component)) - = list(format_component). + = list(format_component). add_path_element(class_id(Name, Arity), RevPieces0) = - [sym_name_and_arity(Name/Arity), words("<=") | RevPieces0]. + [sym_name_and_arity(Name/Arity), words("<=") | RevPieces0]. %---------------------------------------------------------------------------% - % Check that all instances are range restricted with respect to the - % functional dependencies. This means that, for each functional - % dependency, the set of tvars in the range arguments must be a - % subset of the set of tvars in the domain arguments. - % (Note that with the requirement of distinct variables as arguments, - % this implies that all range arguments must be ground. However, - % this code should work even if that requirement is lifted in future.) - % - % Also, check that all pairs of visible instances are mutually - % consistent with respect to the functional dependencies. This is - % true iff the most general unifier of corresponding domain arguments - % (if it exists) is also a unifier of the corresponding range - % arguments. - % + % Check that all instances are range restricted with respect to the + % functional dependencies. This means that, for each functional + % dependency, the set of tvars in the range arguments must be a + % subset of the set of tvars in the domain arguments. + % (Note that with the requirement of distinct variables as arguments, + % this implies that all range arguments must be ground. However, + % this code should work even if that requirement is lifted in future.) + % + % Also, check that all pairs of visible instances are mutually + % consistent with respect to the functional dependencies. This is + % true iff the most general unifier of corresponding domain arguments + % (if it exists) is also a unifier of the corresponding range + % arguments. + % :- pred check_functional_dependencies(module_info::in, module_info::out, - bool::out, io::di, io::uo) is det. + bool::out, io::di, io::uo) is det. check_functional_dependencies(!ModuleInfo, FoundError, !IO) :- - module_info_get_instance_table(!.ModuleInfo, InstanceTable), - map.keys(InstanceTable, ClassIds), - list.foldl3(check_fundeps_class, ClassIds, !ModuleInfo, no, FoundError, - !IO). + module_info_get_instance_table(!.ModuleInfo, InstanceTable), + map.keys(InstanceTable, ClassIds), + list.foldl3(check_fundeps_class, ClassIds, !ModuleInfo, no, FoundError, + !IO). :- pred check_fundeps_class(class_id::in, module_info::in, module_info::out, - bool::in, bool::out, io::di, io::uo) is det. + bool::in, bool::out, io::di, io::uo) is det. check_fundeps_class(ClassId, !ModuleInfo, !FoundError, !IO) :- - module_info_get_class_table(!.ModuleInfo, ClassTable), - map.lookup(ClassTable, ClassId, ClassDefn), - module_info_get_instance_table(!.ModuleInfo, InstanceTable), - map.lookup(InstanceTable, ClassId, InstanceDefns), - FunDeps = ClassDefn ^ class_fundeps, - check_range_restrictedness(ClassId, InstanceDefns, FunDeps, - !ModuleInfo, !FoundError, !IO), - check_consistency(ClassId, ClassDefn, InstanceDefns, FunDeps, - !ModuleInfo, !FoundError, !IO). + module_info_get_class_table(!.ModuleInfo, ClassTable), + map.lookup(ClassTable, ClassId, ClassDefn), + module_info_get_instance_table(!.ModuleInfo, InstanceTable), + map.lookup(InstanceTable, ClassId, InstanceDefns), + FunDeps = ClassDefn ^ class_fundeps, + check_range_restrictedness(ClassId, InstanceDefns, FunDeps, + !ModuleInfo, !FoundError, !IO), + check_consistency(ClassId, ClassDefn, InstanceDefns, FunDeps, + !ModuleInfo, !FoundError, !IO). :- pred check_range_restrictedness(class_id::in, list(hlds_instance_defn)::in, - hlds_class_fundeps::in, module_info::in, module_info::out, - bool::in, bool::out, io::di, io::uo) is det. + hlds_class_fundeps::in, module_info::in, module_info::out, + bool::in, bool::out, io::di, io::uo) is det. check_range_restrictedness(_, [], _, !ModuleInfo, !FoundError, !IO). check_range_restrictedness(ClassId, [InstanceDefn | InstanceDefns], FunDeps, - !ModuleInfo, !FoundError, !IO) :- - list.foldl3(check_range_restrictedness_2(ClassId, InstanceDefn), - FunDeps, !ModuleInfo, !FoundError, !IO), - check_range_restrictedness(ClassId, InstanceDefns, FunDeps, - !ModuleInfo, !FoundError, !IO). + !ModuleInfo, !FoundError, !IO) :- + list.foldl3(check_range_restrictedness_2(ClassId, InstanceDefn), + FunDeps, !ModuleInfo, !FoundError, !IO), + check_range_restrictedness(ClassId, InstanceDefns, FunDeps, + !ModuleInfo, !FoundError, !IO). :- pred check_range_restrictedness_2(class_id::in, hlds_instance_defn::in, - hlds_class_fundep::in, module_info::in, module_info::out, - bool::in, bool::out, io::di, io::uo) is det. + hlds_class_fundep::in, module_info::in, module_info::out, + bool::in, bool::out, io::di, io::uo) is det. check_range_restrictedness_2(ClassId, InstanceDefn, FunDep, !ModuleInfo, - !FoundError, !IO) :- - Types = InstanceDefn ^ instance_types, - FunDep = fundep(Domain, Range), - DomainTypes = restrict_list_elements(Domain, Types), - prog_type.vars_list(DomainTypes, DomainVars), - RangeTypes = restrict_list_elements(Range, Types), - prog_type.vars_list(RangeTypes, RangeVars), - solutions((pred(V::out) is nondet :- - list.member(V, RangeVars), - \+ list.member(V, DomainVars) - ), UnboundVars), - ( - UnboundVars = [] - ; - UnboundVars = [_ | _], - report_range_restriction_error(ClassId, InstanceDefn, - UnboundVars, !IO), - !:FoundError = yes, - module_info_incr_errors(!ModuleInfo) - ). + !FoundError, !IO) :- + Types = InstanceDefn ^ instance_types, + FunDep = fundep(Domain, Range), + DomainTypes = restrict_list_elements(Domain, Types), + prog_type.vars_list(DomainTypes, DomainVars), + RangeTypes = restrict_list_elements(Range, Types), + prog_type.vars_list(RangeTypes, RangeVars), + solutions((pred(V::out) is nondet :- + list.member(V, RangeVars), + \+ list.member(V, DomainVars) + ), UnboundVars), + ( + UnboundVars = [] + ; + UnboundVars = [_ | _], + report_range_restriction_error(ClassId, InstanceDefn, UnboundVars, + !IO), + !:FoundError = yes, + module_info_incr_errors(!ModuleInfo) + ). -% The error message is intended to look like this: -% -% very_long_module_name:001: In instance for typeclass `long_class/2': -% very_long_module_name:001: functional dependency not satisfied: type -% very_long_module_name:001: variables T1, T2 and T3 occur in the range of a -% very_long_module_name:001: functional dependency, but are not in the -% very_long_module_name:001: domain. + % The error message is intended to look like this: + % + % long_module_name:001: In instance for typeclass `long_class/2': + % long_module_name:001: functional dependency not satisfied: type + % long_module_name:001: variables T1, T2 and T3 occur in the range of a + % long_module_name:001: functional dependency, but are not in the + % long_module_name:001: domain. :- pred report_range_restriction_error(class_id::in, hlds_instance_defn::in, - list(tvar)::in, io::di, io::uo) is det. + list(tvar)::in, io::di, io::uo) is det. report_range_restriction_error(ClassId, InstanceDefn, Vars, !IO) :- - ClassId = class_id(SymName, Arity), - TVarSet = InstanceDefn ^ instance_tvarset, - Context = InstanceDefn ^ instance_context, + ClassId = class_id(SymName, Arity), + TVarSet = InstanceDefn ^ instance_tvarset, + Context = InstanceDefn ^ instance_context, - VarsStrs = list.map( - (func(Var) = mercury_var_to_string(Var, TVarSet, no)), - Vars), + VarsStrs = list.map((func(Var) = mercury_var_to_string(Var, TVarSet, no)), + Vars), - Msg = [ words("In instance for typeclass"), - sym_name_and_arity(SymName / Arity), - suffix(":"), nl, - words("functional dependency not satisfied:"), - words(choose_number(Vars, "type variable", "type variables"))] - ++ list_to_pieces(VarsStrs) ++ - [words(choose_number(Vars, "occurs", "occur")), - words("in the range of the functional dependency, but"), - words(choose_number(Vars, "is", "are")), - words("not in the domain.")], - write_error_pieces(Context, 0, Msg, !IO), - io__set_exit_status(1, !IO). + Msg = [ words("In instance for typeclass"), + sym_name_and_arity(SymName / Arity), + suffix(":"), nl, + words("functional dependency not satisfied:"), + words(choose_number(Vars, "type variable", "type variables"))] + ++ list_to_pieces(VarsStrs) ++ + [words(choose_number(Vars, "occurs", "occur")), + words("in the range of the functional dependency, but"), + words(choose_number(Vars, "is", "are")), + words("not in the domain.")], + write_error_pieces(Context, 0, Msg, !IO), + io__set_exit_status(1, !IO). - % Check the consistency of each (unordered) pair of instances. - % + % Check the consistency of each (unordered) pair of instances. + % :- pred check_consistency(class_id::in, hlds_class_defn::in, - list(hlds_instance_defn)::in, hlds_class_fundeps::in, - module_info::in, module_info::out, bool::in, bool::out, - io::di, io::uo) is det. + list(hlds_instance_defn)::in, hlds_class_fundeps::in, + module_info::in, module_info::out, bool::in, bool::out, + io::di, io::uo) is det. check_consistency(_, _, [], _, !ModuleInfo, !FoundError, !IO). check_consistency(ClassId, ClassDefn, [Instance | Instances], FunDeps, - !ModuleInfo, !FoundError, !IO) :- - list.foldl3( - check_consistency_pair(ClassId, ClassDefn, FunDeps, Instance), - Instances, !ModuleInfo, !FoundError, !IO), - check_consistency(ClassId, ClassDefn, Instances, FunDeps, !ModuleInfo, - !FoundError, !IO). + !ModuleInfo, !FoundError, !IO) :- + list.foldl3(check_consistency_pair(ClassId, ClassDefn, FunDeps, Instance), + Instances, !ModuleInfo, !FoundError, !IO), + check_consistency(ClassId, ClassDefn, Instances, FunDeps, !ModuleInfo, + !FoundError, !IO). :- pred check_consistency_pair(class_id::in, hlds_class_defn::in, - hlds_class_fundeps::in, hlds_instance_defn::in, hlds_instance_defn::in, - module_info::in, module_info::out, bool::in, bool::out, io::di, io::uo) - is det. + hlds_class_fundeps::in, hlds_instance_defn::in, hlds_instance_defn::in, + module_info::in, module_info::out, bool::in, bool::out, io::di, io::uo) + is det. check_consistency_pair(ClassId, ClassDefn, FunDeps, InstanceA, InstanceB, - !ModuleInfo, !FoundError, !IO) :- - list.foldl3( - check_consistency_pair_2(ClassId, ClassDefn, InstanceA, - InstanceB), - FunDeps, !ModuleInfo, !FoundError, !IO). + !ModuleInfo, !FoundError, !IO) :- + list.foldl3( + check_consistency_pair_2(ClassId, ClassDefn, InstanceA, InstanceB), + FunDeps, !ModuleInfo, !FoundError, !IO). :- pred check_consistency_pair_2(class_id::in, hlds_class_defn::in, - hlds_instance_defn::in, hlds_instance_defn::in, hlds_class_fundep::in, - module_info::in, module_info::out, bool::in, bool::out, io::di, io::uo) - is det. + hlds_instance_defn::in, hlds_instance_defn::in, hlds_class_fundep::in, + module_info::in, module_info::out, bool::in, bool::out, io::di, io::uo) + is det. check_consistency_pair_2(ClassId, ClassDefn, InstanceA, InstanceB, FunDep, - !ModuleInfo, !FoundError, !IO) :- - TVarSetA = InstanceA ^ instance_tvarset, - TVarSetB = InstanceB ^ instance_tvarset, - tvarset_merge_renaming(TVarSetA, TVarSetB, _, Renaming), + !ModuleInfo, !FoundError, !IO) :- + TVarSetA = InstanceA ^ instance_tvarset, + TVarSetB = InstanceB ^ instance_tvarset, + tvarset_merge_renaming(TVarSetA, TVarSetB, _, Renaming), - TypesA = InstanceA ^ instance_types, - TypesB0 = InstanceB ^ instance_types, - apply_variable_renaming_to_type_list(Renaming, TypesB0, TypesB), + TypesA = InstanceA ^ instance_types, + TypesB0 = InstanceB ^ instance_types, + apply_variable_renaming_to_type_list(Renaming, TypesB0, TypesB), - FunDep = fundep(Domain, Range), - DomainA = restrict_list_elements(Domain, TypesA), - DomainB = restrict_list_elements(Domain, TypesB), + FunDep = fundep(Domain, Range), + DomainA = restrict_list_elements(Domain, TypesA), + DomainB = restrict_list_elements(Domain, TypesB), - ( - type_unify_list(DomainA, DomainB, [], map.init, Subst) - -> - RangeA0 = restrict_list_elements(Range, TypesA), - RangeB0 = restrict_list_elements(Range, TypesB), - apply_rec_subst_to_type_list(Subst, RangeA0, RangeA), - apply_rec_subst_to_type_list(Subst, RangeB0, RangeB), - ( - RangeA = RangeB - -> - true - ; - report_consistency_error(ClassId, ClassDefn, InstanceA, - InstanceB, FunDep, !IO), - !:FoundError = yes, - module_info_incr_errors(!ModuleInfo) - ) - ; - true - ). + ( type_unify_list(DomainA, DomainB, [], map.init, Subst) -> + RangeA0 = restrict_list_elements(Range, TypesA), + RangeB0 = restrict_list_elements(Range, TypesB), + apply_rec_subst_to_type_list(Subst, RangeA0, RangeA), + apply_rec_subst_to_type_list(Subst, RangeB0, RangeB), + ( RangeA = RangeB -> + true + ; + report_consistency_error(ClassId, ClassDefn, InstanceA, + InstanceB, FunDep, !IO), + !:FoundError = yes, + module_info_incr_errors(!ModuleInfo) + ) + ; + true + ). :- pred report_consistency_error(class_id::in, hlds_class_defn::in, - hlds_instance_defn::in, hlds_instance_defn::in, hlds_class_fundep::in, - io::di, io::uo) is det. + hlds_instance_defn::in, hlds_instance_defn::in, hlds_class_fundep::in, + io::di, io::uo) is det. report_consistency_error(ClassId, ClassDefn, InstanceA, InstanceB, FunDep, - !IO) :- - ClassId = class_id(SymName, Arity), - Params = ClassDefn ^ class_vars, - TVarSet = ClassDefn ^ class_tvarset, - ContextA = InstanceA ^ instance_context, - ContextB = InstanceB ^ instance_context, + !IO) :- + ClassId = class_id(SymName, Arity), + Params = ClassDefn ^ class_vars, + TVarSet = ClassDefn ^ class_tvarset, + ContextA = InstanceA ^ instance_context, + ContextB = InstanceB ^ instance_context, - FunDep = fundep(Domain, Range), - DomainParams = restrict_list_elements(Domain, Params), - RangeParams = restrict_list_elements(Range, Params), - DomainList = mercury_vars_to_string(DomainParams, TVarSet, no), - RangeList = mercury_vars_to_string(RangeParams, TVarSet, no), - FunDepStr = "`(" ++ DomainList ++ " -> " ++ RangeList ++ ")'", + FunDep = fundep(Domain, Range), + DomainParams = restrict_list_elements(Domain, Params), + RangeParams = restrict_list_elements(Range, Params), + DomainList = mercury_vars_to_string(DomainParams, TVarSet, no), + RangeList = mercury_vars_to_string(RangeParams, TVarSet, no), + FunDepStr = "`(" ++ DomainList ++ " -> " ++ RangeList ++ ")'", - ErrorPiecesA = [ - words("Inconsistent instance declaration for typeclass"), - sym_name_and_arity(SymName / Arity), - words("with functional dependency"), - fixed(FunDepStr), - suffix(".") - ], - ErrorPiecesB = [ - words("Here is the conflicting instance.") - ], - - write_error_pieces(ContextA, 0, ErrorPiecesA, !IO), - write_error_pieces(ContextB, 0, ErrorPiecesB, !IO), - io__set_exit_status(1, !IO). + ErrorPiecesA = [ + words("Inconsistent instance declaration for typeclass"), + sym_name_and_arity(SymName / Arity), + words("with functional dependency"), + fixed(FunDepStr), + suffix(".") + ], + ErrorPiecesB = [ + words("Here is the conflicting instance.") + ], + + write_error_pieces(ContextA, 0, ErrorPiecesA, !IO), + write_error_pieces(ContextB, 0, ErrorPiecesB, !IO), + io__set_exit_status(1, !IO). %---------------------------------------------------------------------------% - % Look for pred or func declarations for which the type variables in - % the constraints are not all determined by the type variables in the - % type and the functional dependencies. Likewise look for - % constructors for which the existential type variables in the - % constraints are not all determined by the type variables in the - % constructor arguments and the functional dependencies. - % + % Look for pred or func declarations for which the type variables in + % the constraints are not all determined by the type variables in the + % type and the functional dependencies. Likewise look for + % constructors for which the existential type variables in the + % constraints are not all determined by the type variables in the + % constructor arguments and the functional dependencies. + % :- pred check_typeclass.check_constraints(module_info::in, - module_info::out, bool::out, io::di, io::uo) is det. + module_info::out, bool::out, io::di, io::uo) is det. check_typeclass.check_constraints(!ModuleInfo, FoundError, !IO) :- - module_info_predids(!.ModuleInfo, PredIds), - list.foldl3(check_pred_constraints, PredIds, !ModuleInfo, - no, FoundError0, !IO), - module_info_get_type_table(!.ModuleInfo, TypeTable), - map.keys(TypeTable, TypeCtors), - list.foldl3(check_ctor_constraints(TypeTable), TypeCtors, !ModuleInfo, - FoundError0, FoundError, !IO). + module_info_predids(!.ModuleInfo, PredIds), + list.foldl3(check_pred_constraints, PredIds, !ModuleInfo, + no, FoundError0, !IO), + module_info_get_type_table(!.ModuleInfo, TypeTable), + map.keys(TypeTable, TypeCtors), + list.foldl3(check_ctor_constraints(TypeTable), TypeCtors, !ModuleInfo, + FoundError0, FoundError, !IO). :- pred check_pred_constraints(pred_id::in, module_info::in, - module_info::out, bool::in, bool::out, io::di, io::uo) is det. + module_info::out, bool::in, bool::out, io::di, io::uo) is det. check_pred_constraints(PredId, !ModuleInfo, !FoundError, !IO) :- - module_info_pred_info(!.ModuleInfo, PredId, PredInfo), - ( - pred_info_import_status(PredInfo, ImportStatus), - needs_no_ambiguity_check(ImportStatus) - -> - true - ; - write_pred_progress_message( - "% Checking typeclass constraints on ", - PredId, !.ModuleInfo, !IO), - check_pred_type_ambiguities(PredInfo, !ModuleInfo, !FoundError, - !IO), - check_constraint_quant(PredInfo, !ModuleInfo, !FoundError, !IO) - ). + module_info_pred_info(!.ModuleInfo, PredId, PredInfo), + ( + pred_info_import_status(PredInfo, ImportStatus), + needs_no_ambiguity_check(ImportStatus) + -> + true + ; + write_pred_progress_message("% Checking typeclass constraints on ", + PredId, !.ModuleInfo, !IO), + check_pred_type_ambiguities(PredInfo, !ModuleInfo, !FoundError, !IO), + check_constraint_quant(PredInfo, !ModuleInfo, !FoundError, !IO) + ). :- pred needs_no_ambiguity_check(import_status::in) is semidet. @@ -1516,123 +1427,117 @@ needs_no_ambiguity_check(abstract_imported). needs_no_ambiguity_check(pseudo_imported). :- pred check_pred_type_ambiguities(pred_info::in, module_info::in, - module_info::out, bool::in, bool::out, io::di, io::uo) is det. + module_info::out, bool::in, bool::out, io::di, io::uo) is det. check_pred_type_ambiguities(PredInfo, !ModuleInfo, !FoundError, !IO) :- - pred_info_arg_types(PredInfo, ArgTypes), - pred_info_get_class_context(PredInfo, Constraints), - prog_type.vars_list(ArgTypes, TVars), - get_unbound_tvars(TVars, Constraints, !.ModuleInfo, UnboundTVars), - ( - UnboundTVars = [] - -> - true - ; - report_unbound_tvars_in_pred_context(UnboundTVars, PredInfo, - !IO), - !:FoundError = yes, - module_info_incr_errors(!ModuleInfo) - ). + pred_info_arg_types(PredInfo, ArgTypes), + pred_info_get_class_context(PredInfo, Constraints), + prog_type.vars_list(ArgTypes, TVars), + get_unbound_tvars(TVars, Constraints, !.ModuleInfo, UnboundTVars), + ( + UnboundTVars = [] + ; + UnboundTVars = [_ | _], + report_unbound_tvars_in_pred_context(UnboundTVars, PredInfo, !IO), + !:FoundError = yes, + module_info_incr_errors(!ModuleInfo) + ). :- pred check_ctor_constraints(type_table::in, type_ctor::in, module_info::in, - module_info::out, bool::in, bool::out, io::di, io::uo) is det. + module_info::out, bool::in, bool::out, io::di, io::uo) is det. check_ctor_constraints(TypeTable, TypeCtor, !ModuleInfo, !FoundError, !IO) :- - map.lookup(TypeTable, TypeCtor, TypeDefn), - get_type_defn_body(TypeDefn, Body), - ( - Body = du_type(Ctors, _, _, _, _, _) - -> - list.foldl3(check_ctor_type_ambiguities(TypeCtor, TypeDefn), - Ctors, !ModuleInfo, !FoundError, !IO) - ; - true - ). + map.lookup(TypeTable, TypeCtor, TypeDefn), + get_type_defn_body(TypeDefn, Body), + ( Body = du_type(Ctors, _, _, _, _, _) -> + list.foldl3(check_ctor_type_ambiguities(TypeCtor, TypeDefn), + Ctors, !ModuleInfo, !FoundError, !IO) + ; + true + ). :- pred check_ctor_type_ambiguities(type_ctor::in, hlds_type_defn::in, - constructor::in, module_info::in, module_info::out, - bool::in, bool::out, io::di, io::uo) is det. + constructor::in, module_info::in, module_info::out, + bool::in, bool::out, io::di, io::uo) is det. check_ctor_type_ambiguities(TypeCtor, TypeDefn, Ctor, !ModuleInfo, - !FoundError, !IO) :- - Ctor = ctor(ExistQVars, Constraints, _, CtorArgs), - assoc_list.values(CtorArgs, ArgTypes), - prog_type.vars_list(ArgTypes, ArgTVars), - list.filter((pred(V::in) is semidet :- list.member(V, ExistQVars)), - ArgTVars, ExistQArgTVars), - get_unbound_tvars(ExistQArgTVars, constraints([], Constraints), - !.ModuleInfo, UnboundTVars), - ( - UnboundTVars = [] - -> - true - ; - report_unbound_tvars_in_ctor_context(UnboundTVars, TypeCtor, - TypeDefn, !IO), - !:FoundError = yes, - module_info_incr_errors(!ModuleInfo) - ). + !FoundError, !IO) :- + Ctor = ctor(ExistQVars, Constraints, _, CtorArgs), + assoc_list.values(CtorArgs, ArgTypes), + prog_type.vars_list(ArgTypes, ArgTVars), + list.filter((pred(V::in) is semidet :- list.member(V, ExistQVars)), + ArgTVars, ExistQArgTVars), + get_unbound_tvars(ExistQArgTVars, constraints([], Constraints), + !.ModuleInfo, UnboundTVars), + ( + UnboundTVars = [] + ; + UnboundTVars = [_ | _], + report_unbound_tvars_in_ctor_context(UnboundTVars, TypeCtor, + TypeDefn, !IO), + !:FoundError = yes, + module_info_incr_errors(!ModuleInfo) + ). :- pred get_unbound_tvars(list(tvar)::in, prog_constraints::in, - module_info::in, list(tvar)::out) is det. + module_info::in, list(tvar)::out) is det. get_unbound_tvars(TVars, Constraints, ModuleInfo, UnboundTVars) :- - module_info_get_class_table(ModuleInfo, ClassTable), - InducedFunDeps = induced_fundeps(ClassTable, Constraints), - FunDepsClosure = fundeps_closure(InducedFunDeps, list_to_set(TVars)), - solutions(constrained_var_not_in_closure(Constraints, FunDepsClosure), - UnboundTVars). + module_info_get_class_table(ModuleInfo, ClassTable), + InducedFunDeps = induced_fundeps(ClassTable, Constraints), + FunDepsClosure = fundeps_closure(InducedFunDeps, list_to_set(TVars)), + solutions(constrained_var_not_in_closure(Constraints, FunDepsClosure), + UnboundTVars). :- pred constrained_var_not_in_closure(prog_constraints::in, set(tvar)::in, - tvar::out) is nondet. + tvar::out) is nondet. constrained_var_not_in_closure(ClassContext, Closure, UnboundTVar) :- - ClassContext = constraints(UnivCs, ExistCs), - ( - Constraints = UnivCs - ; - Constraints = ExistCs - ), - prog_type.constraint_list_get_tvars(Constraints, TVars), - list.member(UnboundTVar, TVars), - \+ set.member(UnboundTVar, Closure). + ClassContext = constraints(UnivCs, ExistCs), + ( + Constraints = UnivCs + ; + Constraints = ExistCs + ), + prog_type.constraint_list_get_tvars(Constraints, TVars), + list.member(UnboundTVar, TVars), + \+ set.member(UnboundTVar, Closure). :- type induced_fundeps == list(induced_fundep). :- type induced_fundep - ---> fundep( - domain :: set(tvar), - range :: set(tvar) - ). + ---> fundep( + domain :: set(tvar), + range :: set(tvar) + ). :- func induced_fundeps(class_table, prog_constraints) = induced_fundeps. induced_fundeps(ClassTable, constraints(UnivCs, ExistCs)) - = foldl(induced_fundeps_2(ClassTable), UnivCs, - foldl(induced_fundeps_2(ClassTable), ExistCs, [])). + = foldl(induced_fundeps_2(ClassTable), UnivCs, + foldl(induced_fundeps_2(ClassTable), ExistCs, [])). :- func induced_fundeps_2(class_table, prog_constraint, induced_fundeps) - = induced_fundeps. + = induced_fundeps. induced_fundeps_2(ClassTable, constraint(Name, Args), FunDeps0) = FunDeps :- - Arity = length(Args), - ClassDefn = map.lookup(ClassTable, class_id(Name, Arity)), - FunDeps = foldl(induced_fundep(Args), ClassDefn ^ class_fundeps, - FunDeps0). + Arity = length(Args), + ClassDefn = map.lookup(ClassTable, class_id(Name, Arity)), + FunDeps = foldl(induced_fundep(Args), ClassDefn ^ class_fundeps, FunDeps0). :- func induced_fundep(list(type), hlds_class_fundep, induced_fundeps) - = induced_fundeps. + = induced_fundeps. induced_fundep(Args, fundep(Domain0, Range0), FunDeps) - = [fundep(Domain, Range) | FunDeps] :- - Domain = set.fold(induced_vars(Args), Domain0, set.init), - Range = set.fold(induced_vars(Args), Range0, set.init). + = [fundep(Domain, Range) | FunDeps] :- + Domain = set.fold(induced_vars(Args), Domain0, set.init), + Range = set.fold(induced_vars(Args), Range0, set.init). :- func induced_vars(list(type), int, set(tvar)) = set(tvar). induced_vars(Args, ArgNum, Vars) = union(Vars, NewVars) :- - Arg = list.index1_det(Args, ArgNum), - prog_type.vars(Arg, ArgVars), - NewVars = set.list_to_set(ArgVars). + Arg = list.index1_det(Args, ArgNum), + prog_type.vars(Arg, ArgVars), + NewVars = set.list_to_set(ArgVars). :- func fundeps_closure(induced_fundeps, set(tvar)) = set(tvar). @@ -1641,234 +1546,226 @@ fundeps_closure(FunDeps, TVars) = fundeps_closure_2(FunDeps, TVars, set.init). :- func fundeps_closure_2(induced_fundeps, set(tvar), set(tvar)) = set(tvar). fundeps_closure_2(FunDeps0, NewVars0, Result0) = Result :- - ( - set.empty(NewVars0) - -> - Result = Result0 - ; - Result1 = set.union(Result0, NewVars0), - FunDeps1 = list.map(remove_vars(NewVars0), FunDeps0), - list.foldl2(collect_determined_vars, FunDeps1, [], FunDeps, - set.init, NewVars), - Result = fundeps_closure_2(FunDeps, NewVars, Result1) - ). + ( set.empty(NewVars0) -> + Result = Result0 + ; + Result1 = set.union(Result0, NewVars0), + FunDeps1 = list.map(remove_vars(NewVars0), FunDeps0), + list.foldl2(collect_determined_vars, FunDeps1, [], FunDeps, + set.init, NewVars), + Result = fundeps_closure_2(FunDeps, NewVars, Result1) + ). :- func remove_vars(set(tvar), induced_fundep) = induced_fundep. remove_vars(Vars, fundep(Domain0, Range0)) = fundep(Domain, Range) :- - Domain = set.difference(Domain0, Vars), - Range = set.difference(Range0, Vars). + Domain = set.difference(Domain0, Vars), + Range = set.difference(Range0, Vars). :- pred collect_determined_vars(induced_fundep::in, induced_fundeps::in, - induced_fundeps::out, set(tvar)::in, set(tvar)::out) is det. + induced_fundeps::out, set(tvar)::in, set(tvar)::out) is det. collect_determined_vars(FunDep @ fundep(Domain, Range), !FunDeps, !Vars) :- - ( - set.empty(Domain) - -> - !:Vars = set.union(Range, !.Vars) - ; - !:FunDeps = [FunDep | !.FunDeps] - ). + ( set.empty(Domain) -> + !:Vars = set.union(Range, !.Vars) + ; + !:FunDeps = [FunDep | !.FunDeps] + ). -% The error message is intended to look like this: -% -% very_long_module_name:001: In declaration for function `long_function/2': -% very_long_module_name:001: error in type class constraints: type variables -% very_long_module_name:001: T1, T2 and T3 occur in the constraints, but are -% very_long_module_name:001: not determined by the function's argument or -% very_long_module_name:001: result types. -% -% very_long_module_name:002: In declaration for predicate `long_predicate/3': -% very_long_module_name:002: error in type class constraints: type variable -% very_long_module_name:002: T occurs in the constraints, but is not -% very_long_module_name:002: determined by the predicate's argument types. -% -% very_long_module_name:002: In declaration for type `long_type/3': -% very_long_module_name:002: error in type class constraints: type variable -% very_long_module_name:002: T occurs in the constraints, but is not -% very_long_module_name:002: determined by the constructor's argument types. + % The error message is intended to look like this: + % + % long_module_name:001: In declaration for function `long_function/2': + % long_module_name:001: error in type class constraints: type variables + % long_module_name:001: T1, T2 and T3 occur in the constraints, but are + % long_module_name:001: not determined by the function's argument or + % long_module_name:001: result types. + % + % long_module_name:002: In declaration for predicate `long_predicate/3': + % long_module_name:002: error in type class constraints: type variable + % long_module_name:002: T occurs in the constraints, but is not + % long_module_name:002: determined by the predicate's argument types. + % + % long_module_name:002: In declaration for type `long_type/3': + % long_module_name:002: error in type class constraints: type variable + % long_module_name:002: T occurs in the constraints, but is not + % long_module_name:002: determined by the constructor's argument types. :- pred report_unbound_tvars_in_pred_context(list(tvar)::in, pred_info::in, - io::di, io::uo) is det. + io::di, io::uo) is det. report_unbound_tvars_in_pred_context(Vars, PredInfo, !IO) :- - pred_info_context(PredInfo, Context), - pred_info_arg_types(PredInfo, TVarSet, _, ArgTypes), - PredName = pred_info_name(PredInfo), - Module = pred_info_module(PredInfo), - SymName = qualified(Module, PredName), - Arity = length(ArgTypes), - PredOrFunc = pred_info_is_pred_or_func(PredInfo), + pred_info_context(PredInfo, Context), + pred_info_arg_types(PredInfo, TVarSet, _, ArgTypes), + PredName = pred_info_name(PredInfo), + Module = pred_info_module(PredInfo), + SymName = qualified(Module, PredName), + Arity = length(ArgTypes), + PredOrFunc = pred_info_is_pred_or_func(PredInfo), - VarsStrs = list.map( - (func(Var) = mercury_var_to_string(Var, TVarSet, no)), - Vars), + VarsStrs = list.map((func(Var) = mercury_var_to_string(Var, TVarSet, no)), + Vars), - Msg0 = [words("In declaration for"), - words(simple_call_id_to_string(PredOrFunc, SymName, Arity)), - suffix(":"), nl, - words("error in type class constraints:"), - words(choose_number(Vars, "type variable", "type variables"))] - ++ list_to_pieces(VarsStrs) ++ - [words(choose_number(Vars, "occurs", "occur")), - words("in the constraints, but"), - words(choose_number(Vars, "is", "are")), - words("not determined by the")], - ( - PredOrFunc = predicate, - Msg = Msg0 ++ [words("predicate's argument types.")] - ; - PredOrFunc = function, - Msg = Msg0 ++ [words("function's argument or result types.")] - ), - write_error_pieces(Context, 0, Msg, !IO), - maybe_report_unbound_tvars_explanation(Context, !IO), - io__set_exit_status(1, !IO). + Msg0 = [words("In declaration for"), + words(simple_call_id_to_string(PredOrFunc, SymName, Arity)), + suffix(":"), nl, + words("error in type class constraints:"), + words(choose_number(Vars, "type variable", "type variables"))] + ++ list_to_pieces(VarsStrs) ++ + [words(choose_number(Vars, "occurs", "occur")), + words("in the constraints, but"), + words(choose_number(Vars, "is", "are")), + words("not determined by the")], + ( + PredOrFunc = predicate, + Msg = Msg0 ++ [words("predicate's argument types.")] + ; + PredOrFunc = function, + Msg = Msg0 ++ [words("function's argument or result types.")] + ), + write_error_pieces(Context, 0, Msg, !IO), + maybe_report_unbound_tvars_explanation(Context, !IO), + io__set_exit_status(1, !IO). :- pred report_unbound_tvars_in_ctor_context(list(tvar)::in, type_ctor::in, - hlds_type_defn::in, io::di, io::uo) is det. + hlds_type_defn::in, io::di, io::uo) is det. report_unbound_tvars_in_ctor_context(Vars, TypeCtor, TypeDefn, !IO) :- - get_type_defn_context(TypeDefn, Context), - get_type_defn_tvarset(TypeDefn, TVarSet), - TypeCtor = SymName - Arity, + get_type_defn_context(TypeDefn, Context), + get_type_defn_tvarset(TypeDefn, TVarSet), + TypeCtor = SymName - Arity, - VarsStrs = list.map( - (func(Var) = mercury_var_to_string(Var, TVarSet, no)), - Vars), + VarsStrs = list.map((func(Var) = mercury_var_to_string(Var, TVarSet, no)), + Vars), - Msg = [words("In declaration for type"), - sym_name_and_arity(SymName / Arity), - suffix(":"), nl, - words("error in type class constraints:"), - words(choose_number(Vars, "type variable", "type variables"))] - ++ list_to_pieces(VarsStrs) ++ - [words(choose_number(Vars, "occurs", "occur")), - words("in the constraints, but"), - words(choose_number(Vars, "is", "are")), - words("not determined by the constructor's argument types.")], - write_error_pieces(Context, 0, Msg, !IO), - maybe_report_unbound_tvars_explanation(Context, !IO), - io__set_exit_status(1, !IO). + Msg = [words("In declaration for type"), + sym_name_and_arity(SymName / Arity), + suffix(":"), nl, + words("error in type class constraints:"), + words(choose_number(Vars, "type variable", "type variables"))] + ++ list_to_pieces(VarsStrs) ++ + [words(choose_number(Vars, "occurs", "occur")), + words("in the constraints, but"), + words(choose_number(Vars, "is", "are")), + words("not determined by the constructor's argument types.")], + write_error_pieces(Context, 0, Msg, !IO), + maybe_report_unbound_tvars_explanation(Context, !IO), + io__set_exit_status(1, !IO). :- pred maybe_report_unbound_tvars_explanation(prog_context::in, - io::di, io::uo) is det. + io::di, io::uo) is det. maybe_report_unbound_tvars_explanation(Context, !IO) :- - globals.io_lookup_bool_option(verbose_errors, VerboseErrors, !IO), - ( - VerboseErrors = yes, - Msg = [words("All types occurring in typeclass constraints"), - words("must be fully determined."), - words("A type is fully determined if one of the"), - words("following holds:"), - nl, - words("1) All type variables occurring in the type"), - words("are determined."), - nl, - words("2) The type occurs in a constraint argument,"), - words("that argument is in the range of some"), - words("functional dependency for that class, and"), - words("the types in all of the domain arguments for"), - words("that functional dependency are fully"), - words("determined."), - nl, - words("A type variable is determined if one of the"), - words("following holds:"), - nl, - words("1) The type variable occurs in the argument"), - words("types of the predicate, function, or"), - words("constructor which is constrained."), - nl, - words("2) The type variable occurs in a type which"), - words("is fully determined."), - nl, - words("See the ""Functional dependencies"" section"), - words("of the reference manual for details.") - ], - write_error_pieces_not_first_line(Context, 0, Msg, !IO) - ; - VerboseErrors = no, - globals.io_set_extra_error_info(yes, !IO) - ). + globals.io_lookup_bool_option(verbose_errors, VerboseErrors, !IO), + ( + VerboseErrors = yes, + Msg = [words("All types occurring in typeclass constraints"), + words("must be fully determined."), + words("A type is fully determined if one of the"), + words("following holds:"), + nl, + words("1) All type variables occurring in the type"), + words("are determined."), + nl, + words("2) The type occurs in a constraint argument,"), + words("that argument is in the range of some"), + words("functional dependency for that class, and"), + words("the types in all of the domain arguments for"), + words("that functional dependency are fully"), + words("determined."), + nl, + words("A type variable is determined if one of the"), + words("following holds:"), + nl, + words("1) The type variable occurs in the argument"), + words("types of the predicate, function, or"), + words("constructor which is constrained."), + nl, + words("2) The type variable occurs in a type which"), + words("is fully determined."), + nl, + words("See the ""Functional dependencies"" section"), + words("of the reference manual for details.") + ], + write_error_pieces_not_first_line(Context, 0, Msg, !IO) + ; + VerboseErrors = no, + globals.io_set_extra_error_info(yes, !IO) + ). %---------------------------------------------------------------------------% -% -% Check that all types appearing in universal (existential) constraints are -% universally (existentially) quantified. -% + % Check that all types appearing in universal (existential) constraints are + % universally (existentially) quantified. + % :- pred check_constraint_quant(pred_info::in, - module_info::in, module_info::out, bool::in, bool::out, - io::di, io::uo) is det. + module_info::in, module_info::out, bool::in, bool::out, + io::di, io::uo) is det. check_constraint_quant(PredInfo, !ModuleInfo, !FoundError, !IO) :- - pred_info_get_exist_quant_tvars(PredInfo, ExistQVars), - pred_info_get_class_context(PredInfo, Constraints), - Constraints = constraints(UnivCs, ExistCs), - prog_type.constraint_list_get_tvars(UnivCs, UnivTVars), - solutions((pred(V::out) is nondet :- - list.member(V, UnivTVars), - list.member(V, ExistQVars) - ), BadUnivTVars), - maybe_report_badly_quantified_vars(PredInfo, universal_constraint, - BadUnivTVars, !ModuleInfo, !FoundError, !IO), - prog_type.constraint_list_get_tvars(ExistCs, ExistTVars), - list.delete_elems(ExistTVars, ExistQVars, BadExistTVars), - maybe_report_badly_quantified_vars(PredInfo, existential_constraint, - BadExistTVars, !ModuleInfo, !FoundError, !IO). + pred_info_get_exist_quant_tvars(PredInfo, ExistQVars), + pred_info_get_class_context(PredInfo, Constraints), + Constraints = constraints(UnivCs, ExistCs), + prog_type.constraint_list_get_tvars(UnivCs, UnivTVars), + solutions((pred(V::out) is nondet :- + list.member(V, UnivTVars), + list.member(V, ExistQVars) + ), BadUnivTVars), + maybe_report_badly_quantified_vars(PredInfo, universal_constraint, + BadUnivTVars, !ModuleInfo, !FoundError, !IO), + prog_type.constraint_list_get_tvars(ExistCs, ExistTVars), + list.delete_elems(ExistTVars, ExistQVars, BadExistTVars), + maybe_report_badly_quantified_vars(PredInfo, existential_constraint, + BadExistTVars, !ModuleInfo, !FoundError, !IO). :- type quant_error_type - ---> universal_constraint - ; existential_constraint. + ---> universal_constraint + ; existential_constraint. :- pred maybe_report_badly_quantified_vars(pred_info::in, quant_error_type::in, - list(tvar)::in, module_info::in, module_info::out, - bool::in, bool::out, io::di, io::uo) is det. + list(tvar)::in, module_info::in, module_info::out, + bool::in, bool::out, io::di, io::uo) is det. maybe_report_badly_quantified_vars(PredInfo, QuantErrorType, TVars, - !ModuleInfo, !FoundError, !IO) :- - ( - TVars = [] - ; - TVars = [_ | _], - report_badly_quantified_vars(PredInfo, QuantErrorType, TVars, - !IO), - module_info_incr_errors(!ModuleInfo), - !:FoundError = yes, - io.set_exit_status(1, !IO) - ). + !ModuleInfo, !FoundError, !IO) :- + ( + TVars = [] + ; + TVars = [_ | _], + report_badly_quantified_vars(PredInfo, QuantErrorType, TVars, !IO), + module_info_incr_errors(!ModuleInfo), + !:FoundError = yes, + io.set_exit_status(1, !IO) + ). :- pred report_badly_quantified_vars(pred_info::in, quant_error_type::in, - list(tvar)::in, io::di, io::uo) is det. + list(tvar)::in, io::di, io::uo) is det. report_badly_quantified_vars(PredInfo, QuantErrorType, TVars, !IO) :- - pred_info_typevarset(PredInfo, TVarSet), - pred_info_context(PredInfo, Context), + pred_info_typevarset(PredInfo, TVarSet), + pred_info_context(PredInfo, Context), - InDeclaration = [words("In declaration of")] ++ - describe_one_pred_info_name(should_module_qualify, PredInfo) ++ - [suffix(":")], - TypeVariables = [words("type variable"), - suffix(choose_number(TVars, "", "s"))], - TVarsStrs = list.map((func(V) = mercury_var_to_string(V, TVarSet, no)), - TVars), - TVarsPart = list_to_pieces(TVarsStrs), - Are = words(choose_number(TVars, "is", "are")), - ( - QuantErrorType = universal_constraint, - BlahConstrained = words("universally constrained"), - BlahQuantified = words("existentially quantified") - ; - QuantErrorType = existential_constraint, - BlahConstrained = words("existentially constrained"), - BlahQuantified = words("universally quantified") - ), - Pieces = InDeclaration ++ TypeVariables ++ TVarsPart ++ - [Are, BlahConstrained, suffix(","), words("but"), Are, - BlahQuantified, suffix(".")], - write_error_pieces(Context, 0, Pieces, !IO). + InDeclaration = [words("In declaration of")] ++ + describe_one_pred_info_name(should_module_qualify, PredInfo) ++ + [suffix(":")], + TypeVariables = [words("type variable"), + suffix(choose_number(TVars, "", "s"))], + TVarsStrs = list.map((func(V) = mercury_var_to_string(V, TVarSet, no)), + TVars), + TVarsPart = list_to_pieces(TVarsStrs), + Are = words(choose_number(TVars, "is", "are")), + ( + QuantErrorType = universal_constraint, + BlahConstrained = words("universally constrained"), + BlahQuantified = words("existentially quantified") + ; + QuantErrorType = existential_constraint, + BlahConstrained = words("existentially constrained"), + BlahQuantified = words("universally quantified") + ), + Pieces = InDeclaration ++ TypeVariables ++ TVarsPart ++ + [Are, BlahConstrained, suffix(","), words("but"), Are, + BlahQuantified, suffix(".")], + write_error_pieces(Context, 0, Pieces, !IO). %---------------------------------------------------------------------------% diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m index 0853b37ed..4d8c9a2fb 100644 --- a/compiler/equiv_type.m +++ b/compiler/equiv_type.m @@ -779,7 +779,7 @@ equiv_type__replace_in_inst(Inst0, EqvInstMap, ExpandedInstIds, map__search(EqvInstMap, InstId, eqv_inst_body(_, EqvInstParams, EqvInst)) -> - inst_substitute_arg_list(EqvInst, EqvInstParams, ArgInsts, Inst1), + inst_substitute_arg_list(EqvInstParams, ArgInsts, EqvInst, Inst1), equiv_type__record_expanded_item(item_id(inst, InstId), !Info), equiv_type__replace_in_inst(Inst1, EqvInstMap, set__insert(ExpandedInstIds, InstId), Inst, !Info) diff --git a/compiler/hlds_goal.m b/compiler/hlds_goal.m index 9cf2c9dba..ce98f14ed 100644 --- a/compiler/hlds_goal.m +++ b/compiler/hlds_goal.m @@ -1045,7 +1045,9 @@ ; first ; later. -:- type maybe_cut ---> cut ; no_cut. +:- type maybe_cut + ---> cut + ; no_cut. % Convert a goal path to a string, using the format documented % in the Mercury user's guide. diff --git a/compiler/mode_util.m b/compiler/mode_util.m index d8423cb1b..b1652c41c 100644 --- a/compiler/mode_util.m +++ b/compiler/mode_util.m @@ -883,7 +883,7 @@ apply_type_subst(Type0, Subst, Type) :- sym_name::in, list(inst)::in, (inst)::out) is det. inst_lookup_subst_args(eqv_inst(Inst0), Params, _Name, Args, Inst) :- - inst_substitute_arg_list(Inst0, Params, Args, Inst). + inst_substitute_arg_list(Params, Args, Inst0, Inst). inst_lookup_subst_args(abstract_inst, _Params, Name, Args, abstract_inst(Name, Args)). @@ -1263,7 +1263,7 @@ recompute_instmap_delta_call(PredId, ProcId, Args, VarTypes, InstMap, InitialInsts, InstVarSub0), InstVarSub, !RI), % Apply the inst_var substitution to the argument modes. - mode_list_apply_substitution(ArgModes1, InstVarSub, ArgModes2), + mode_list_apply_substitution(InstVarSub, ArgModes1, ArgModes2), % Calculate the final insts of the argument variables from their % initial insts and the final insts of the called procedure diff --git a/compiler/modecheck_call.m b/compiler/modecheck_call.m index 5f1f923c7..f367f6b42 100644 --- a/compiler/modecheck_call.m +++ b/compiler/modecheck_call.m @@ -315,7 +315,7 @@ modecheck_arg_list(ArgOffset, Modes, ExtraGoals, Args0, Args, !ModeInfo) :- modecheck_var_has_inst_list(Args0, InitialInsts, NeedExactMatch, ArgOffset, InstVarSub, !ModeInfo), mode_list_get_final_insts(ModuleInfo0, Modes, FinalInsts0), - inst_list_apply_substitution(FinalInsts0, InstVarSub, FinalInsts), + inst_list_apply_substitution(InstVarSub, FinalInsts0, FinalInsts), modecheck_set_var_inst_list(Args0, InitialInsts, FinalInsts, ArgOffset, Args, ExtraGoals, !ModeInfo). @@ -439,9 +439,9 @@ modecheck_end_of_call(ProcInfo, Purity, ProcArgModes, ArgVars0, ArgOffset, mode_info_get_module_info(!.ModeInfo, ModuleInfo), mode_list_get_initial_insts(ModuleInfo, ProcArgModes, InitialInsts0), - inst_list_apply_substitution(InitialInsts0, InstVarSub, InitialInsts), + inst_list_apply_substitution(InstVarSub, InitialInsts0, InitialInsts), mode_list_get_final_insts(ModuleInfo, ProcArgModes, FinalInsts0), - inst_list_apply_substitution(FinalInsts0, InstVarSub, FinalInsts), + inst_list_apply_substitution(InstVarSub, FinalInsts0, FinalInsts), modecheck_set_var_inst_list(ArgVars0, InitialInsts, FinalInsts, ArgOffset, ArgVars, ExtraGoals, !ModeInfo), proc_info_never_succeeds(ProcInfo, NeverSucceeds), diff --git a/compiler/post_typecheck.m b/compiler/post_typecheck.m index 74e351c2c..ec1e998b2 100644 --- a/compiler/post_typecheck.m +++ b/compiler/post_typecheck.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 1997-2005 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. @@ -10,25 +12,24 @@ % % This module does the final parts of type analysis: % -% - it resolves predicate overloading -% - it resolves function overloading -% - it expands field access functions -% - it propagates type information into the modes of procedures -% - it checks for unbound type variables and if there are any, -% it reports an error (or a warning, binding them to the type `void'). -% - it reports errors for unbound inst variables in predicate or -% function mode declarations -% - it reports errors for unsatisfied type class constraints -% - it reports an error if there are indistinguishable modes for -% a predicate of function. -% - it checks that declarations for abstract types also have a -% corresponding definition somewhere in the module. +% - it resolves predicate overloading +% - it resolves function overloading +% - it expands field access functions +% - it propagates type information into the modes of procedures +% - it checks for unbound type variables and if there are any, +% it reports an error (or a warning, binding them to the type `void'). +% - it reports errors for unbound inst variables in predicate or +% function mode declarations +% - it reports errors for unsatisfied type class constraints +% - it reports an error if there are indistinguishable modes for +% a predicate of function. +% - it checks that declarations for abstract types also have a +% corresponding definition somewhere in the module. % % These actions cannot be done until after type inference is complete, % so they need to be a separate "post-typecheck pass". For efficiency % reasons, this is in fact done at the same time as purity analysis -- % the routines here are called from purity.m rather than mercury_compile.m. -% :- module check_hlds__post_typecheck. :- interface. @@ -45,79 +46,77 @@ :- import_module std_util. :- import_module term. - % post_typecheck__finish_preds(PredIds, ReportTypeErrors, - % NumErrors, FoundTypeError, Module0, Module) - % - % Check that all Aditi predicates have an `aditi__state' argument. - % Check that the all of the types which have been inferred - % for the variables in the clause do not contain any unbound type - % variables other than those that occur in the types of head - % variables, and that there are no unsatisfied type class - % constraints, and if ReportErrors = yes, print appropriate - % warning/error messages. - % Also bind any unbound type variables to the type `void'. - % Note that when checking assertions we take the conservative - % approach of warning about unbound type variables. There may - % be cases for which this doesn't make sense. - % FoundTypeError will be `yes' if there were errors which - % should prevent further processing (e.g. polymorphism or - % mode analysis). - % -:- pred post_typecheck__finish_preds(list(pred_id)::in, bool::in, - int::out, bool::out, module_info::in, module_info::out, - io::di, io::uo) is det. + % finish_preds(PredIds, ReportTypeErrors, NumErrors, FoundTypeError, + % !Module): + % + % Check that all Aditi predicates have an `aditi__state' argument. + % Check that the all of the types which have been inferred for the + % variables in the clause do not contain any unbound type variables + % other than those that occur in the types of head variables, and that + % there are no unsatisfied type class constraints, and if + % ReportErrors = yes, print appropriate warning/error messages. + % Also bind any unbound type variables to the type `void'. Note that + % when checking assertions we take the conservative approach of warning + % about unbound type variables. There may be cases for which this doesn't + % make sense. FoundTypeError will be `yes' if there were errors which + % should prevent further processing (e.g. polymorphism or mode analysis). + % +:- pred finish_preds(list(pred_id)::in, bool::in, int::out, bool::out, + module_info::in, module_info::out, io::di, io::uo) is det. - % As above, but don't check for `aditi__state's and return - % the list of procedures containing unbound inst variables - % instead of reporting the errors directly. - % -:- pred post_typecheck__finish_pred_no_io(module_info::in, list(proc_id)::out, - pred_info::in, pred_info::out) is det. + % As above, but don't check for `aditi__state's and return + % the list of procedures containing unbound inst variables + % instead of reporting the errors directly. + % +:- pred finish_pred_no_io(module_info::in, list(proc_id)::out, + pred_info::in, pred_info::out) is det. -:- pred post_typecheck__finish_imported_pred_no_io(module_info::in, - list(proc_id)::out, pred_info::in, pred_info::out) is det. +:- pred finish_imported_pred_no_io(module_info::in, + list(proc_id)::out, pred_info::in, pred_info::out) is det. -:- pred post_typecheck__finish_ill_typed_pred(module_info::in, pred_id::in, - pred_info::in, pred_info::out, io::di, io::uo) is det. +:- pred finish_ill_typed_pred(module_info::in, pred_id::in, + pred_info::in, pred_info::out, io::di, io::uo) is det. - % Now that the assertion has finished being typechecked, - % remove it from further processing and store it in the - % assertion_table. -:- pred post_typecheck__finish_promise(promise_type::in, pred_id::in, - module_info::in, module_info::out, io::di, io::uo) is det. + % Now that the assertion has finished being typechecked, remove it + % from further processing and store it in the assertion_table. + % +:- pred finish_promise(promise_type::in, pred_id::in, + module_info::in, module_info::out, io::di, io::uo) is det. - % Handle any unresolved overloading for a predicate call. - % -:- pred post_typecheck__resolve_pred_overloading(list(prog_var)::in, - pred_info::in, module_info::in, sym_name::in, sym_name::out, - pred_id::in, pred_id::out) is det. + % Handle any unresolved overloading for a predicate call. + % +:- pred resolve_pred_overloading(list(prog_var)::in, + pred_info::in, module_info::in, sym_name::in, sym_name::out, + pred_id::in, pred_id::out) is det. - % Resolve overloading and fill in the argument modes - % of a call to an Aditi builtin. - % Check that a relation modified by one of the Aditi update - % goals is a base relation. - % -:- pred post_typecheck__finish_aditi_builtin(module_info::in, pred_info::in, - list(prog_var)::in, term__context::in, - aditi_builtin::in, aditi_builtin::out, - simple_call_id::in, simple_call_id::out, list(mode)::out, - maybe(aditi_builtin_error)::out) is det. + % Resolve overloading and fill in the argument modes of a call + % to an Aditi builtin. Check that a relation modified by one of the + % Aditi update goals is a base relation. + % +:- pred finish_aditi_builtin(module_info::in, pred_info::in, + list(prog_var)::in, term__context::in, + aditi_builtin::in, aditi_builtin::out, + simple_call_id::in, simple_call_id::out, list(mode)::out, + maybe(aditi_builtin_error)::out) is det. :- type aditi_builtin_error - ---> aditi_update_of_derived_relation(prog_context, - aditi_builtin, simple_call_id). + ---> aditi_update_of_derived_relation( + prog_context, + aditi_builtin, + simple_call_id + ). :- pred report_aditi_builtin_error(aditi_builtin_error::in, io::di, io::uo) - is det. + is det. - % Work out whether a var-functor unification is actually a function - % call. If so, replace the unification goal with a call. - % -:- pred post_typecheck__resolve_unify_functor(prog_var::in, cons_id::in, - list(prog_var)::in, unify_mode::in, unification::in, unify_context::in, - hlds_goal_info::in, module_info::in, pred_info::in, pred_info::out, - vartypes::in, vartypes::out, prog_varset::in, prog_varset::out, - hlds_goal::out) is det. + % Work out whether a var-functor unification is actually a function call. + % If so, replace the unification goal with a call. + % +:- pred resolve_unify_functor(prog_var::in, cons_id::in, + list(prog_var)::in, unify_mode::in, unification::in, unify_context::in, + hlds_goal_info::in, module_info::in, pred_info::in, pred_info::out, + vartypes::in, vartypes::out, prog_varset::in, prog_varset::out, + hlds_goal::out) is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -125,14 +124,15 @@ :- implementation. :- import_module check_hlds__inst_match. +:- import_module check_hlds__modecheck_call. :- import_module check_hlds__mode_errors. :- import_module check_hlds__mode_util. -:- import_module check_hlds__modecheck_call. -:- import_module check_hlds__type_util. :- import_module check_hlds__typecheck. +:- import_module check_hlds__type_util. :- import_module hlds__assertion. :- import_module hlds__goal_util. :- import_module hlds__hlds_data. +:- import_module hlds__hlds_error_util. :- import_module hlds__hlds_out. :- import_module hlds__special_pred. :- import_module libs__globals. @@ -141,8 +141,8 @@ :- import_module parse_tree__mercury_to_mercury. :- import_module parse_tree__prog_mode. :- import_module parse_tree__prog_out. -:- import_module parse_tree__prog_util. :- import_module parse_tree__prog_type. +:- import_module parse_tree__prog_util. :- import_module assoc_list. :- import_module int. @@ -154,262 +154,237 @@ %-----------------------------------------------------------------------------% -post_typecheck__finish_preds(PredIds, ReportTypeErrors, NumErrors, - FoundTypeError, !ModuleInfo, !IO) :- - post_typecheck__finish_preds(PredIds, ReportTypeErrors, - !ModuleInfo, 0, NumErrors0, no, FoundTypeError0, !IO), - check_for_missing_definitions(!.ModuleInfo, - NumErrors0, NumErrors, FoundTypeError0, FoundTypeError, - !IO). +finish_preds(PredIds, ReportTypeErrors, NumErrors, + FoundTypeError, !ModuleInfo, !IO) :- + finish_preds(PredIds, ReportTypeErrors, !ModuleInfo, + 0, NumErrors0, no, FoundTypeError0, !IO), + check_for_missing_definitions(!.ModuleInfo, NumErrors0, NumErrors, + FoundTypeError0, FoundTypeError, !IO). -:- pred post_typecheck__finish_preds(list(pred_id)::in, bool::in, - module_info::in, module_info::out, int::in, int::out, - bool::in, bool::out, io::di, io::uo) is det. +:- pred finish_preds(list(pred_id)::in, bool::in, + module_info::in, module_info::out, int::in, int::out, + bool::in, bool::out, io::di, io::uo) is det. -post_typecheck__finish_preds([], _, !ModuleInfo, !NumErrors, - !PostTypecheckError, !IO). -post_typecheck__finish_preds([PredId | PredIds], ReportTypeErrors, - !ModuleInfo, !NumErrors, !FoundTypeError, !IO) :- - module_info_pred_info(!.ModuleInfo, PredId, PredInfo0), - ( - ( pred_info_is_imported(PredInfo0) - ; pred_info_is_pseudo_imported(PredInfo0) - ) - -> - post_typecheck__finish_imported_pred(!.ModuleInfo, PredId, - PredInfo0, PredInfo, !IO) - ; - % - % Only report error messages for unbound type variables - % if we didn't get any type errors already; this avoids - % a lot of spurious diagnostics. - % - post_typecheck__check_type_bindings(!.ModuleInfo, PredId, - PredInfo0, PredInfo1, ReportTypeErrors, - UnboundTypeErrsInThisPred, !IO), +finish_preds([], _, !ModuleInfo, !NumErrors, !PostTypecheckError, !IO). +finish_preds([PredId | PredIds], ReportTypeErrors, !ModuleInfo, !NumErrors, + !FoundTypeError, !IO) :- + some [!PredInfo] ( + module_info_pred_info(!.ModuleInfo, PredId, !:PredInfo), + ( + ( pred_info_is_imported(!.PredInfo) + ; pred_info_is_pseudo_imported(!.PredInfo) + ) + -> + finish_imported_pred(!.ModuleInfo, PredId, !PredInfo, !IO) + ; + % Only report error messages for unbound type variables + % if we didn't get any type errors already; this avoids + % a lot of spurious diagnostics. + check_type_bindings(!.ModuleInfo, PredId, !PredInfo, + ReportTypeErrors, UnboundTypeErrsInThisPred, !IO), - % - % if there were any unsatisfied type class constraints, - % then that can cause internal errors in polymorphism.m - % if we try to continue, so we need to halt compilation - % after this pass. - % - ( UnboundTypeErrsInThisPred \= 0 -> - !:FoundTypeError = yes - ; - true - ), + % If there were any unsatisfied type class constraints, then that + % can cause internal errors in polymorphism.m if we try to continue, + % so we need to halt compilation after this pass. + ( UnboundTypeErrsInThisPred \= 0 -> + !:FoundTypeError = yes + ; + true + ), - post_typecheck__finish_pred_no_io(!.ModuleInfo, - ErrorProcs, PredInfo1, PredInfo2), - report_unbound_inst_vars(!.ModuleInfo, PredId, - ErrorProcs, PredInfo2, PredInfo3, !IO), - check_for_indistinguishable_modes(!.ModuleInfo, PredId, - PredInfo3, PredInfo, !IO), + finish_pred_no_io(!.ModuleInfo, ErrorProcs, !PredInfo), + report_unbound_inst_vars(!.ModuleInfo, PredId, ErrorProcs, + !PredInfo, !IO), + check_for_indistinguishable_modes(!.ModuleInfo, PredId, + !PredInfo, !IO), - % - % check that main/2 has the right type - % - ( ReportTypeErrors = yes -> - check_type_of_main(PredInfo, !IO) - ; - true - ), + % Check that main/2 has the right type. + ( + ReportTypeErrors = yes, + check_type_of_main(!.PredInfo, !IO) + ; + ReportTypeErrors = no + ), - % - % Check that all Aditi predicates have an `aditi__state' - % argument. This must be done after typechecking because - % of type inference -- the types of some Aditi predicates - % may not be known before. - % - pred_info_get_markers(PredInfo, Markers), - ( ReportTypeErrors = yes, check_marker(Markers, aditi) -> - check_aditi_state(!.ModuleInfo, PredInfo, !IO) - ; - true - ), + % Check that all Aditi predicates have an `aditi__state' argument. + % This must be done after typechecking because of type inference + % -- the types of some Aditi predicates may not be known before. + pred_info_get_markers(!.PredInfo, Markers), + ( + ReportTypeErrors = yes, + check_marker(Markers, aditi) + -> + check_aditi_state(!.ModuleInfo, !.PredInfo, !IO) + ; + true + ), - !:NumErrors = !.NumErrors + UnboundTypeErrsInThisPred - ), - module_info_set_pred_info(PredId, PredInfo, !ModuleInfo), - post_typecheck__finish_preds(PredIds, ReportTypeErrors, - !ModuleInfo, !NumErrors, !FoundTypeError, !IO). + !:NumErrors = !.NumErrors + UnboundTypeErrsInThisPred + ), + module_info_set_pred_info(PredId, !.PredInfo, !ModuleInfo), + finish_preds(PredIds, ReportTypeErrors, + !ModuleInfo, !NumErrors, !FoundTypeError, !IO) + ). %-----------------------------------------------------------------------------% -% Check for unbound type variables -% -% Check that the all of the types which have been inferred -% for the variables in the clause do not contain any unbound type -% variables other than those that occur in the types of head -% variables, and that there are no unsatisfied type class constraints. -:- pred post_typecheck__check_type_bindings(module_info::in, pred_id::in, - pred_info::in, pred_info::out, bool::in, int::out, io::di, io::uo) - is det. + % Check that the all of the types which have been inferred for the + % variables in the clause do not contain any unbound type variables + % other than those that occur in the types of head variables, and that + % there are no unsatisfied type class constraints. + % +:- pred check_type_bindings(module_info::in, pred_id::in, + pred_info::in, pred_info::out, bool::in, int::out, io::di, io::uo) is det. -post_typecheck__check_type_bindings(ModuleInfo, PredId, !PredInfo, ReportErrs, - NumErrors, !IO) :- - ( - ReportErrs = yes, - pred_info_get_unproven_body_constraints(!.PredInfo, - UnprovenConstraints0), - UnprovenConstraints0 \= [] - -> - list__sort_and_remove_dups(UnprovenConstraints0, - UnprovenConstraints), - report_unsatisfied_constraints(UnprovenConstraints, - PredId, !.PredInfo, ModuleInfo, !IO), - list__length(UnprovenConstraints, NumErrors) - ; - NumErrors = 0 - ), +check_type_bindings(ModuleInfo, PredId, !PredInfo, ReportErrs, NumErrors, + !IO) :- + ( + ReportErrs = yes, + pred_info_get_unproven_body_constraints(!.PredInfo, + UnprovenConstraints0), + UnprovenConstraints0 = [_ | _] + -> + list__sort_and_remove_dups(UnprovenConstraints0, UnprovenConstraints), + report_unsatisfied_constraints(UnprovenConstraints, PredId, + !.PredInfo, ModuleInfo, !IO), + list__length(UnprovenConstraints, NumErrors) + ; + NumErrors = 0 + ), - pred_info_clauses_info(!.PredInfo, ClausesInfo0), - pred_info_get_head_type_params(!.PredInfo, HeadTypeParams), - clauses_info_varset(ClausesInfo0, VarSet), - clauses_info_vartypes(ClausesInfo0, VarTypesMap0), - map__to_assoc_list(VarTypesMap0, VarTypesList), - set__init(Set0), - check_type_bindings_2(VarTypesList, HeadTypeParams, [], Errs, - Set0, Set), - ( Errs = [] -> - true - ; - ( ReportErrs = yes -> - % - % report the warning - % - report_unresolved_type_warning(Errs, PredId, - !.PredInfo, ModuleInfo, VarSet, !IO) - ; - true - ), + pred_info_clauses_info(!.PredInfo, ClausesInfo0), + pred_info_get_head_type_params(!.PredInfo, HeadTypeParams), + clauses_info_varset(ClausesInfo0, VarSet), + clauses_info_vartypes(ClausesInfo0, VarTypesMap0), + map__to_assoc_list(VarTypesMap0, VarTypesList), + set__init(Set0), + check_type_bindings_2(VarTypesList, HeadTypeParams, [], Errs, Set0, Set), + ( + Errs = [] + ; + Errs = [_ | _], + ( + ReportErrs = yes, + report_unresolved_type_warning(Errs, PredId, !.PredInfo, + ModuleInfo, VarSet, !IO) + ; + ReportErrs = no + ), - % - % bind all the type variables in `Set' to `void' ... - % - pred_info_get_constraint_proofs(!.PredInfo, Proofs0), - pred_info_get_constraint_map(!.PredInfo, ConstraintMap0), - bind_type_vars_to_void(Set, VarTypesMap0, VarTypesMap, - Proofs0, Proofs, ConstraintMap0, ConstraintMap), - clauses_info_set_vartypes(VarTypesMap, - ClausesInfo0, ClausesInfo), - pred_info_set_clauses_info(ClausesInfo, !PredInfo), - pred_info_set_constraint_proofs(Proofs, !PredInfo), - pred_info_set_constraint_map(ConstraintMap, !PredInfo) - ). + % Bind all the type variables in `Set' to `void' ... + pred_info_get_constraint_proofs(!.PredInfo, Proofs0), + pred_info_get_constraint_map(!.PredInfo, ConstraintMap0), + bind_type_vars_to_void(Set, VarTypesMap0, VarTypesMap, Proofs0, Proofs, + ConstraintMap0, ConstraintMap), + clauses_info_set_vartypes(VarTypesMap, ClausesInfo0, ClausesInfo), + pred_info_set_clauses_info(ClausesInfo, !PredInfo), + pred_info_set_constraint_proofs(Proofs, !PredInfo), + pred_info_set_constraint_map(ConstraintMap, !PredInfo) + ). :- pred check_type_bindings_2(assoc_list(prog_var, (type))::in, list(tvar)::in, - assoc_list(prog_var, (type))::in, assoc_list(prog_var, (type))::out, - set(tvar)::in, set(tvar)::out) is det. + assoc_list(prog_var, (type))::in, assoc_list(prog_var, (type))::out, + set(tvar)::in, set(tvar)::out) is det. check_type_bindings_2([], _, !Errs, !Set). check_type_bindings_2([Var - Type | VarTypes], HeadTypeParams, !Errs, !Set) :- - prog_type__vars(Type, TVars), - set__list_to_set(TVars, TVarsSet0), - set__delete_list(TVarsSet0, HeadTypeParams, TVarsSet1), - ( \+ set__empty(TVarsSet1) -> - !:Errs = [Var - Type | !.Errs], - set__union(!.Set, TVarsSet1, !:Set) - ; - true - ), - check_type_bindings_2(VarTypes, HeadTypeParams, !Errs, !Set). + prog_type__vars(Type, TVars), + set__list_to_set(TVars, TVarsSet0), + set__delete_list(TVarsSet0, HeadTypeParams, TVarsSet1), + ( \+ set__empty(TVarsSet1) -> + !:Errs = [Var - Type | !.Errs], + set__union(!.Set, TVarsSet1, !:Set) + ; + true + ), + check_type_bindings_2(VarTypes, HeadTypeParams, !Errs, !Set). -% -% bind all the type variables in `UnboundTypeVarsSet' to the type `void' ... -% + % Bind all the type variables in `UnboundTypeVarsSet' to the type `void'. + % :- pred bind_type_vars_to_void(set(tvar)::in, vartypes::in, vartypes::out, - constraint_proof_map::in, constraint_proof_map::out, - constraint_map::in, constraint_map::out) is det. + constraint_proof_map::in, constraint_proof_map::out, + constraint_map::in, constraint_map::out) is det. bind_type_vars_to_void(UnboundTypeVarsSet, !VarTypesMap, !Proofs, - !ConstraintMap) :- - % - % Create a substitution that maps all of the unbound type variables - % to `void'. - % - MapToVoid = (pred(TVar::in, Subst0::in, Subst::out) is det :- - map__det_insert(Subst0, TVar, void_type, Subst) - ), - set__fold(MapToVoid, UnboundTypeVarsSet, map__init, VoidSubst), + !ConstraintMap) :- + % Create a substitution that maps all of the unbound type variables + % to `void'. + MapToVoid = (pred(TVar::in, Subst0::in, Subst::out) is det :- + map__det_insert(Subst0, TVar, void_type, Subst) + ), + set__fold(MapToVoid, UnboundTypeVarsSet, map__init, VoidSubst), - % - % Then apply the substitution we just created to the various maps. - % - apply_subst_to_type_map(VoidSubst, !VarTypesMap), - apply_subst_to_constraint_proofs(VoidSubst, !Proofs), - apply_subst_to_constraint_map(VoidSubst, !ConstraintMap). + % Then apply the substitution we just created to the various maps. + apply_subst_to_type_map(VoidSubst, !VarTypesMap), + apply_subst_to_constraint_proofs(VoidSubst, !Proofs), + apply_subst_to_constraint_map(VoidSubst, !ConstraintMap). %-----------------------------------------------------------------------------% -% -% report an error: unsatisfied type class constraints -% + + % Report an error: unsatisfied type class constraints. + % :- pred report_unsatisfied_constraints(list(prog_constraint)::in, - pred_id::in, pred_info::in, module_info::in, io::di, io::uo) is det. + pred_id::in, pred_info::in, module_info::in, io::di, io::uo) is det. -report_unsatisfied_constraints(Constraints, PredId, PredInfo, ModuleInfo) --> - io__set_exit_status(1), +report_unsatisfied_constraints(Constraints, PredId, PredInfo, ModuleInfo, + !IO) :- + io__set_exit_status(1, !IO), - { pred_info_typevarset(PredInfo, TVarSet) }, - { pred_info_context(PredInfo, Context) }, + pred_info_typevarset(PredInfo, TVarSet), + pred_info_context(PredInfo, Context), - prog_out__write_context(Context), - io__write_string("In "), - hlds_out__write_pred_id(ModuleInfo, PredId), - io__write_string(":\n"), + prog_out__write_context(Context, !IO), + io__write_string("In ", !IO), + hlds_out__write_pred_id(ModuleInfo, PredId, !IO), + io__write_string(":\n", !IO), - prog_out__write_context(Context), - io__write_string( - " type error: unsatisfied typeclass constraint(s):\n"), + prog_out__write_context(Context, !IO), + io__write_string(" type error: unsatisfied typeclass constraint(s):\n", + !IO), - prog_out__write_context(Context), - io__write_string(" "), - { AppendVarnums = no }, - io__write_list(Constraints, ", ", - mercury_output_constraint(TVarSet, AppendVarnums)), - io__write_string(".\n"). + prog_out__write_context(Context, !IO), + io__write_string(" ", !IO), + AppendVarnums = no, + io__write_list(Constraints, ", ", + mercury_output_constraint(TVarSet, AppendVarnums), !IO), + io__write_string(".\n", !IO). -% -% report a warning: uninstantiated type parameter -% + % Report a warning: uninstantiated type parameter. + % :- pred report_unresolved_type_warning(assoc_list(prog_var, (type))::in, - pred_id::in, pred_info::in, module_info::in, prog_varset::in, - io::di, io::uo) is det. + pred_id::in, pred_info::in, module_info::in, prog_varset::in, + io::di, io::uo) is det. -report_unresolved_type_warning(Errs, PredId, PredInfo, ModuleInfo, VarSet) --> - globals__io_lookup_bool_option(halt_at_warn, HaltAtWarn), - ( { HaltAtWarn = yes } -> - io__set_exit_status(1) - ; - [] - ), +report_unresolved_type_warning(Errs, PredId, PredInfo, ModuleInfo, VarSet, + !IO) :- + record_warning(!IO), - { pred_info_typevarset(PredInfo, TypeVarSet) }, - { pred_info_context(PredInfo, Context) }, + pred_info_typevarset(PredInfo, TypeVarSet), + pred_info_context(PredInfo, Context), - prog_out__write_context(Context), - io__write_string("In "), - hlds_out__write_pred_id(ModuleInfo, PredId), - io__write_string(":\n"), + prog_out__write_context(Context, !IO), + io__write_string("In ", !IO), + hlds_out__write_pred_id(ModuleInfo, PredId, !IO), + io__write_string(":\n", !IO), - prog_out__write_context(Context), - io__write_string(" warning: unresolved polymorphism.\n"), - prog_out__write_context(Context), - ( { Errs = [_] } -> - io__write_string(" The variable with an unbound type was:\n") - ; - io__write_string(" The variables with unbound types were:\n") - ), - write_type_var_list(Errs, Context, VarSet, TypeVarSet), - prog_out__write_context(Context), - io__write_string(" The unbound type variable(s) will be implicitly\n"), - prog_out__write_context(Context), - io__write_string(" bound to the builtin type `void'.\n"), - globals__io_lookup_bool_option(verbose_errors, VerboseErrors), - ( - { VerboseErrors = yes }, - io__write_strings([ + prog_out__write_context(Context, !IO), + io__write_string(" warning: unresolved polymorphism.\n", !IO), + prog_out__write_context(Context, !IO), + ( Errs = [_] -> + io__write_string(" The variable with an unbound type was:\n", !IO) + ; + io__write_string(" The variables with unbound types were:\n", !IO) + ), + write_type_var_list(Errs, Context, VarSet, TypeVarSet, !IO), + prog_out__write_context(Context, !IO), + io__write_string(" The unbound type variable(s) will be implicitly\n", + !IO), + prog_out__write_context(Context, !IO), + io__write_string(" bound to the builtin type `void'.\n", !IO), + globals__io_lookup_bool_option(verbose_errors, VerboseErrors, !IO), + ( + VerboseErrors = yes, + io__write_strings([ "\tThe body of the clause contains a call to a polymorphic predicate,\n", "\tbut I can't determine which version should be called,\n", "\tbecause the type variables listed above didn't get bound.\n", @@ -417,1308 +392,1206 @@ report_unresolved_type_warning(Errs, PredId, PredInfo, ModuleInfo, VarSet) --> % XXX improve error message "\t(I ought to tell you which call caused the problem, but I'm afraid\n", "\tyou'll have to work it out yourself. My apologies.)\n" - ]) - ; - { VerboseErrors = no }, - globals.io_set_extra_error_info(yes) - ). + ], !IO) + ; + VerboseErrors = no, + globals.io_set_extra_error_info(yes, !IO) + ). :- pred write_type_var_list(assoc_list(prog_var, (type))::in, prog_context::in, - prog_varset::in, tvarset::in, io::di, io::uo) is det. + prog_varset::in, tvarset::in, io::di, io::uo) is det. write_type_var_list([], _, _, _, !IO). write_type_var_list([Var - Type | Rest], Context, VarSet, TVarSet, !IO) :- - prog_out__write_context(Context, !IO), - io__write_string(" ", !IO), - mercury_output_var(Var, VarSet, no, !IO), - io__write_string(": ", !IO), - mercury_output_type(TVarSet, no, Type, !IO), - io__nl(!IO), - write_type_var_list(Rest, Context, VarSet, TVarSet, !IO). + prog_out__write_context(Context, !IO), + io__write_string(" ", !IO), + mercury_output_var(Var, VarSet, no, !IO), + io__write_string(": ", !IO), + mercury_output_type(TVarSet, no, Type, !IO), + io__nl(!IO), + write_type_var_list(Rest, Context, VarSet, TVarSet, !IO). %-----------------------------------------------------------------------------% -% resolve predicate overloading -% In the case of a call to an overloaded predicate, typecheck.m -% does not figure out the correct pred_id. We must do that here. +resolve_pred_overloading(Args0, CallerPredInfo, ModuleInfo, !PredName, + !PredId) :- + % In the case of a call to an overloaded predicate, typecheck.m + % does not figure out the correct pred_id. We must do that here. -post_typecheck__resolve_pred_overloading(Args0, CallerPredInfo, - ModuleInfo, PredName0, PredName, PredId0, PredId) :- - ( PredId0 = invalid_pred_id -> - % - % Find the set of candidate pred_ids for predicates which - % have the specified name and arity - % - pred_info_typevarset(CallerPredInfo, TVarSet), - pred_info_get_markers(CallerPredInfo, Markers), - pred_info_clauses_info(CallerPredInfo, ClausesInfo), - clauses_info_vartypes(ClausesInfo, VarTypes), - map__apply_to_list(Args0, VarTypes, ArgTypes), - typecheck__resolve_pred_overloading(ModuleInfo, Markers, - ArgTypes, TVarSet, PredName0, PredName, PredId) - ; - PredId = PredId0, - PredName = get_qualified_pred_name(ModuleInfo, PredId) - ). + ( !.PredId = invalid_pred_id -> + % Find the set of candidate pred_ids for predicates which + % have the specified name and arity. + pred_info_typevarset(CallerPredInfo, TVarSet), + pred_info_get_markers(CallerPredInfo, Markers), + pred_info_clauses_info(CallerPredInfo, ClausesInfo), + clauses_info_vartypes(ClausesInfo, VarTypes), + map__apply_to_list(Args0, VarTypes, ArgTypes), + typecheck__resolve_pred_overloading(ModuleInfo, Markers, + ArgTypes, TVarSet, !PredName, !:PredId) + ; + !:PredName = get_qualified_pred_name(ModuleInfo, !.PredId) + ). :- func get_qualified_pred_name(module_info, pred_id) = sym_name. get_qualified_pred_name(ModuleInfo, PredId) - = qualified(PredModule, PredName) :- - module_info_pred_info(ModuleInfo, PredId, PredInfo), - PredModule = pred_info_module(PredInfo), - PredName = pred_info_name(PredInfo). + = qualified(PredModule, PredName) :- + module_info_pred_info(ModuleInfo, PredId, PredInfo), + PredModule = pred_info_module(PredInfo), + PredName = pred_info_name(PredInfo). %-----------------------------------------------------------------------------% -post_typecheck__finish_aditi_builtin(ModuleInfo, CallerPredInfo, Args, Context, - aditi_tuple_update(Update, PredId0), Builtin, - PredOrFunc - SymName0/Arity, InsertCallId, - Modes, MaybeError) :- - % make_hlds.m checks the arity, so this is guaranteed to succeed. - get_state_args_det(Args, OtherArgs, _, _), +finish_aditi_builtin(ModuleInfo, CallerPredInfo, Args, Context, + aditi_tuple_update(Update, PredId0), Builtin, + PredOrFunc - SymName0/Arity, InsertCallId, Modes, MaybeError) :- + % Make_hlds checks the arity, so this is guaranteed to succeed. + get_state_args_det(Args, OtherArgs, _, _), - % The tuple to insert has the same argument types as - % the relation being inserted into. - post_typecheck__resolve_pred_overloading(OtherArgs, CallerPredInfo, - ModuleInfo, SymName0, SymName, PredId0, PredId), + % The tuple to insert has the same argument types as the relation + % being inserted into. + resolve_pred_overloading(OtherArgs, CallerPredInfo, + ModuleInfo, SymName0, SymName, PredId0, PredId), - Builtin = aditi_tuple_update(Update, PredId), - InsertCallId = PredOrFunc - SymName/Arity, + Builtin = aditi_tuple_update(Update, PredId), + InsertCallId = PredOrFunc - SymName/Arity, - module_info_pred_info(ModuleInfo, PredId, RelationPredInfo), - check_base_relation(Context, RelationPredInfo, - Builtin, InsertCallId, MaybeError), + module_info_pred_info(ModuleInfo, PredId, RelationPredInfo), + check_base_relation(Context, RelationPredInfo, + Builtin, InsertCallId, MaybeError), - % `aditi_insert' calls do not use the `aditi_state' argument - % in the tuple to insert, so set its mode to `unused'. - % The other arguments all have mode `in'. - pred_info_arg_types(RelationPredInfo, ArgTypes), - in_mode(InMode), - unused_mode(AditiStateMode), - aditi_builtin_modes(InMode, AditiStateMode, ArgTypes, InsertArgModes), - list__append(InsertArgModes, [aditi_di_mode, aditi_uo_mode], Modes). + % `aditi_insert' calls do not use the `aditi_state' argument + % in the tuple to insert, so set its mode to `unused'. + % The other arguments all have mode `in'. + pred_info_arg_types(RelationPredInfo, ArgTypes), + in_mode(InMode), + unused_mode(AditiStateMode), + aditi_builtin_modes(InMode, AditiStateMode, ArgTypes, InsertArgModes), + list__append(InsertArgModes, [aditi_di_mode, aditi_uo_mode], Modes). -post_typecheck__finish_aditi_builtin(ModuleInfo, CallerPredInfo, Args, Context, - Builtin0, Builtin, PredOrFunc - SymName0/Arity, - UpdateCallId, Modes, MaybeError) :- - Builtin0 = aditi_bulk_update(Update, PredId0, Syntax), - UnchangedArgTypes = (pred(X::in, X::out) is det), - ( - Update = bulk_insert, - AdjustArgTypes = UnchangedArgTypes - ; - Update = bulk_delete, - AdjustArgTypes = UnchangedArgTypes - ; - Update = bulk_modify, - % The argument types of the closure passed to `aditi_modify' - % contain two copies of the arguments of the base relation - - % one set input and one set output. - AdjustArgTypes = - (pred(Types0::in, Types::out) is det :- - list__length(Types0, Length), - HalfLength = Length // 2, - ( list__split_list(HalfLength, Types0, Types1, _) -> - Types = Types1 - ; - error( - "post_typecheck__finish_aditi_builtin: aditi_modify") - ) - ) - ), - resolve_aditi_builtin_overloading(ModuleInfo, CallerPredInfo, Args, - AdjustArgTypes, PredId0, PredId, SymName0, SymName), - Builtin = aditi_bulk_update(Update, PredId, Syntax), +finish_aditi_builtin(ModuleInfo, CallerPredInfo, Args, Context, !Builtin, + PredOrFunc - SymName0/Arity, UpdateCallId, Modes, MaybeError) :- + !.Builtin = aditi_bulk_update(Update, PredId0, Syntax), + UnchangedArgTypes = (pred(X::in, X::out) is det), + ( + Update = bulk_insert, + AdjustArgTypes = UnchangedArgTypes + ; + Update = bulk_delete, + AdjustArgTypes = UnchangedArgTypes + ; + Update = bulk_modify, + % The argument types of the closure passed to `aditi_modify' + % contain two copies of the arguments of the base relation - + % one set input and one set output. + AdjustArgTypes = + (pred(Types0::in, Types::out) is det :- + list__length(Types0, Length), + HalfLength = Length // 2, + ( list__split_list(HalfLength, Types0, Types1, _) -> + Types = Types1 + ; + error("finish_aditi_builtin: aditi_modify") + ) + ) + ), + resolve_aditi_builtin_overloading(ModuleInfo, CallerPredInfo, Args, + AdjustArgTypes, PredId0, PredId, SymName0, SymName), + !:Builtin = aditi_bulk_update(Update, PredId, Syntax), - UpdateCallId = PredOrFunc - SymName/Arity, + UpdateCallId = PredOrFunc - SymName/Arity, - module_info_pred_info(ModuleInfo, PredId, RelationPredInfo), - check_base_relation(Context, RelationPredInfo, - Builtin, UpdateCallId, MaybeError), + module_info_pred_info(ModuleInfo, PredId, RelationPredInfo), + check_base_relation(Context, RelationPredInfo, !.Builtin, UpdateCallId, + MaybeError), - pred_info_arg_types(RelationPredInfo, ArgTypes), - post_typecheck__bulk_update_closure_info(Update, - PredOrFunc, ArgTypes, ClosurePredOrFunc, - ClosureArgModes, ClosureDetism), + pred_info_arg_types(RelationPredInfo, ArgTypes), + bulk_update_closure_info(Update, PredOrFunc, ArgTypes, + ClosurePredOrFunc, ClosureArgModes, ClosureDetism), - Inst = ground(shared, higher_order(pred_inst_info(ClosurePredOrFunc, - ClosureArgModes, ClosureDetism))), - Modes = [(Inst -> Inst), aditi_di_mode, aditi_uo_mode]. + Inst = ground(shared, higher_order(pred_inst_info(ClosurePredOrFunc, + ClosureArgModes, ClosureDetism))), + Modes = [(Inst -> Inst), aditi_di_mode, aditi_uo_mode]. -:- pred post_typecheck__bulk_update_closure_info(aditi_bulk_update::in, - pred_or_func::in, list(type)::in, pred_or_func::out, list(mode)::out, - determinism::out) is det. +:- pred bulk_update_closure_info(aditi_bulk_update::in, + pred_or_func::in, list(type)::in, pred_or_func::out, list(mode)::out, + determinism::out) is det. -post_typecheck__bulk_update_closure_info(bulk_insert, PredOrFunc, - ArgTypes, PredOrFunc, ClosureArgModes, nondet) :- - out_mode(OutMode), - AditiStateMode = aditi_mui_mode, - aditi_builtin_modes(OutMode, AditiStateMode, - ArgTypes, ClosureArgModes). -post_typecheck__bulk_update_closure_info(bulk_delete, - PredOrFunc, ArgTypes, PredOrFunc, ClosureArgModes, nondet) :- - ArgMode = out_mode, - AditiStateMode = aditi_mui_mode, - aditi_builtin_modes(ArgMode, AditiStateMode, - ArgTypes, ClosureArgModes). -post_typecheck__bulk_update_closure_info(bulk_modify, - _PredOrFunc, ArgTypes, LambdaPredOrFunc, - ClosureArgModes, nondet) :- - LambdaPredOrFunc = predicate, - out_mode(OutMode), - unused_mode(UnusedMode), - DeleteArgMode = OutMode, - DeleteAditiStateMode = aditi_mui_mode, - aditi_builtin_modes(DeleteArgMode, DeleteAditiStateMode, - ArgTypes, DeleteArgModes), +bulk_update_closure_info(bulk_insert, PredOrFunc, ArgTypes, PredOrFunc, + ClosureArgModes, nondet) :- + out_mode(OutMode), + AditiStateMode = aditi_mui_mode, + aditi_builtin_modes(OutMode, AditiStateMode, ArgTypes, ClosureArgModes). +bulk_update_closure_info(bulk_delete, PredOrFunc, ArgTypes, PredOrFunc, + ClosureArgModes, nondet) :- + ArgMode = out_mode, + AditiStateMode = aditi_mui_mode, + aditi_builtin_modes(ArgMode, AditiStateMode, + ArgTypes, ClosureArgModes). +bulk_update_closure_info(bulk_modify, _PredOrFunc, ArgTypes, LambdaPredOrFunc, + ClosureArgModes, nondet) :- + LambdaPredOrFunc = predicate, + out_mode(OutMode), + unused_mode(UnusedMode), + DeleteArgMode = OutMode, + DeleteAditiStateMode = aditi_mui_mode, + aditi_builtin_modes(DeleteArgMode, DeleteAditiStateMode, ArgTypes, + DeleteArgModes), - InsertArgMode = OutMode, - InsertAditiStateMode = UnusedMode, - aditi_builtin_modes(InsertArgMode, InsertAditiStateMode, - ArgTypes, InsertArgModes), - list__append(DeleteArgModes, InsertArgModes, ClosureArgModes). + InsertArgMode = OutMode, + InsertAditiStateMode = UnusedMode, + aditi_builtin_modes(InsertArgMode, InsertAditiStateMode, ArgTypes, + InsertArgModes), + list__append(DeleteArgModes, InsertArgModes, ClosureArgModes). - % Use the type of the closure passed to an `aditi_delete', - % `aditi_bulk_insert', `aditi_bulk_delete' or `aditi_modify' - % call to work out which predicate is being updated. + % Use the type of the closure passed to an `aditi_delete', + % `aditi_bulk_insert', `aditi_bulk_delete' or `aditi_modify' + % call to work out which predicate is being updated. + % :- pred resolve_aditi_builtin_overloading(module_info::in, pred_info::in, - list(prog_var)::in, - pred(list(type), list(type))::in(pred(in, out) is det), - pred_id::in, pred_id::out, sym_name::in, sym_name::out) is det. + list(prog_var)::in, + pred(list(type), list(type))::in(pred(in, out) is det), + pred_id::in, pred_id::out, sym_name::in, sym_name::out) is det. resolve_aditi_builtin_overloading(ModuleInfo, CallerPredInfo, Args, - AdjustArgTypes, PredId0, PredId, SymName0, SymName) :- - % make_hlds.m checks the arity, so this is guaranteed to succeed. - get_state_args_det(Args, OtherArgs, _, _), - ( PredId0 = invalid_pred_id -> - ( - OtherArgs = [HOArg], - pred_info_typevarset(CallerPredInfo, TVarSet), - pred_info_clauses_info(CallerPredInfo, ClausesInfo), - clauses_info_vartypes(ClausesInfo, VarTypes), - map__lookup(VarTypes, HOArg, HOArgType), - type_is_higher_order(HOArgType, _Purity, - _, EvalMethod, ArgTypes0), - EvalMethod \= normal - -> - call(AdjustArgTypes, ArgTypes0, ArgTypes), - pred_info_get_markers(CallerPredInfo, Markers), - typecheck__resolve_pred_overloading(ModuleInfo, - Markers, ArgTypes, TVarSet, - SymName0, SymName, PredId) - ; - error( - "post_typecheck__resolve_aditi_builtin_overloading") - ) - ; - PredId = PredId0, - SymName = get_qualified_pred_name(ModuleInfo, PredId) - ). + AdjustArgTypes, PredId0, PredId, SymName0, SymName) :- + % make_hlds.m checks the arity, so this is guaranteed to succeed. + get_state_args_det(Args, OtherArgs, _, _), + ( PredId0 = invalid_pred_id -> + ( + OtherArgs = [HOArg], + pred_info_typevarset(CallerPredInfo, TVarSet), + pred_info_clauses_info(CallerPredInfo, ClausesInfo), + clauses_info_vartypes(ClausesInfo, VarTypes), + map__lookup(VarTypes, HOArg, HOArgType), + type_is_higher_order(HOArgType, _Purity, _, EvalMethod, ArgTypes0), + EvalMethod \= normal + -> + call(AdjustArgTypes, ArgTypes0, ArgTypes), + pred_info_get_markers(CallerPredInfo, Markers), + typecheck__resolve_pred_overloading(ModuleInfo, Markers, ArgTypes, + TVarSet, SymName0, SymName, PredId) + ; + error("resolve_aditi_builtin_overloading") + ) + ; + PredId = PredId0, + SymName = get_qualified_pred_name(ModuleInfo, PredId) + ). - % Work out the modes of the arguments of a closure passed - % to an Aditi update. - % The `Mode' passed is the mode of all arguments apart - % from the `aditi__state'. + % Work out the modes of the arguments of a closure passed to an Aditi + % update. The `Mode' passed is the mode of all arguments apart from + % the `aditi__state'. + % :- pred aditi_builtin_modes((mode)::in, (mode)::in, list(type)::in, - list(mode)::out) is det. + list(mode)::out) is det. aditi_builtin_modes(_, _, [], []). aditi_builtin_modes(Mode, AditiStateMode, [ArgType | ArgTypes], - [ArgMode | ArgModes]) :- - ( type_is_aditi_state(ArgType) -> - ArgMode = AditiStateMode - ; - ArgMode = Mode - ), - aditi_builtin_modes(Mode, AditiStateMode, ArgTypes, ArgModes). + [ArgMode | ArgModes]) :- + ( type_is_aditi_state(ArgType) -> + ArgMode = AditiStateMode + ; + ArgMode = Mode + ), + aditi_builtin_modes(Mode, AditiStateMode, ArgTypes, ArgModes). - % Report an error if a predicate modified by an Aditi builtin - % is not a base relation. + % Report an error if a predicate modified by an Aditi builtin + % is not a base relation. + % :- pred check_base_relation(prog_context::in, pred_info::in, aditi_builtin::in, - simple_call_id::in, maybe(aditi_builtin_error)::out) is det. + simple_call_id::in, maybe(aditi_builtin_error)::out) is det. check_base_relation(Context, PredInfo, Builtin, CallId, MaybeError) :- - ( hlds_pred__pred_info_is_base_relation(PredInfo) -> - MaybeError = no - ; - MaybeError = yes(aditi_update_of_derived_relation(Context, - Builtin, CallId)) - ). + ( hlds_pred__pred_info_is_base_relation(PredInfo) -> + MaybeError = no + ; + MaybeError = yes(aditi_update_of_derived_relation(Context, Builtin, + CallId)) + ). report_aditi_builtin_error( - aditi_update_of_derived_relation(Context, Builtin, CallId)) --> - io__set_exit_status(1), - prog_out__write_context(Context), - io__write_string("In "), - hlds_out__write_call_id(generic_call(aditi_builtin(Builtin, CallId))), - io__write_string(":\n"), - prog_out__write_context(Context), - io__write_string(" error: the modified "), - { CallId = PredOrFunc - _ }, - prog_out__write_pred_or_func(PredOrFunc), - io__write_string(" is not a base relation.\n"). + aditi_update_of_derived_relation(Context, Builtin, CallId), !IO) :- + io__set_exit_status(1, !IO), + prog_out__write_context(Context, !IO), + io__write_string("In ", !IO), + hlds_out__write_call_id(generic_call(aditi_builtin(Builtin, CallId)), !IO), + io__write_string(":\n", !IO), + prog_out__write_context(Context, !IO), + io__write_string(" error: the modified ", !IO), + CallId = PredOrFunc - _, + prog_out__write_pred_or_func(PredOrFunc, !IO), + io__write_string(" is not a base relation.\n", !IO). %-----------------------------------------------------------------------------% -post_typecheck__finish_pred_no_io(ModuleInfo, ErrorProcs, - PredInfo0, PredInfo) :- - post_typecheck__propagate_types_into_modes(ModuleInfo, - ErrorProcs, PredInfo0, PredInfo). +finish_pred_no_io(ModuleInfo, ErrorProcs, !PredInfo) :- + propagate_types_into_modes(ModuleInfo, ErrorProcs, !PredInfo). - % - % For ill-typed preds, we just need to set the modes up correctly - % so that any calls to that pred from correctly-typed predicates - % won't result in spurious mode errors. - % -post_typecheck__finish_ill_typed_pred(ModuleInfo, PredId, !PredInfo, !IO) :- - post_typecheck__propagate_types_into_modes(ModuleInfo, ErrorProcs, - !PredInfo), - report_unbound_inst_vars(ModuleInfo, PredId, ErrorProcs, !PredInfo, - !IO), - check_for_indistinguishable_modes(ModuleInfo, PredId, !PredInfo, !IO). + % For ill-typed preds, we just need to set the modes up correctly + % so that any calls to that pred from correctly-typed predicates + % won't result in spurious mode errors. + % +finish_ill_typed_pred(ModuleInfo, PredId, !PredInfo, !IO) :- + propagate_types_into_modes(ModuleInfo, ErrorProcs, !PredInfo), + report_unbound_inst_vars(ModuleInfo, PredId, ErrorProcs, !PredInfo, !IO), + check_for_indistinguishable_modes(ModuleInfo, PredId, !PredInfo, !IO). - % - % For imported preds, we just need to ensure that all - % constructors occurring in predicate mode declarations are - % module qualified. - % -:- pred post_typecheck__finish_imported_pred(module_info::in, pred_id::in, - pred_info::in, pred_info::out, io::di, io::uo) is det. + % For imported preds, we just need to ensure that all constructors + % occurring in predicate mode declarations are module qualified. + % +:- pred finish_imported_pred(module_info::in, pred_id::in, + pred_info::in, pred_info::out, io::di, io::uo) is det. -post_typecheck__finish_imported_pred(ModuleInfo, PredId, !PredInfo, !IO) :- - pred_info_get_markers(!.PredInfo, Markers), - ( - check_marker(Markers, base_relation), - ModuleName = pred_info_module(!.PredInfo), - module_info_get_name(ModuleInfo, ModuleName) - -> - check_aditi_state(ModuleInfo, !.PredInfo, !IO) - ; - true - ), - % XXX maybe the rest should be replaced with a call to - % post_typecheck__finish_ill_typed_pred? [zs] - post_typecheck__finish_imported_pred_no_io(ModuleInfo, ErrorProcs, - !PredInfo), - report_unbound_inst_vars(ModuleInfo, PredId, ErrorProcs, !PredInfo, - !IO), - check_for_indistinguishable_modes(ModuleInfo, PredId, !PredInfo, !IO). +finish_imported_pred(ModuleInfo, PredId, !PredInfo, !IO) :- + pred_info_get_markers(!.PredInfo, Markers), + ( + check_marker(Markers, base_relation), + ModuleName = pred_info_module(!.PredInfo), + module_info_get_name(ModuleInfo, ModuleName) + -> + check_aditi_state(ModuleInfo, !.PredInfo, !IO) + ; + true + ), + % XXX Maybe the rest should be replaced with a call to + % finish_ill_typed_pred? [zs] + finish_imported_pred_no_io(ModuleInfo, ErrorProcs, !PredInfo), + report_unbound_inst_vars(ModuleInfo, PredId, ErrorProcs, !PredInfo, !IO), + check_for_indistinguishable_modes(ModuleInfo, PredId, !PredInfo, !IO). -post_typecheck__finish_imported_pred_no_io(ModuleInfo, Errors, !PredInfo) :- - % Make sure the var-types field in the clauses_info is - % valid for imported predicates. - % Unification procedures have clauses generated, so - % they already have valid var-types. - ( pred_info_is_pseudo_imported(!.PredInfo) -> - true - ; - pred_info_clauses_info(!.PredInfo, ClausesInfo0), - clauses_info_headvars(ClausesInfo0, HeadVars), - pred_info_arg_types(!.PredInfo, ArgTypes), - map__from_corresponding_lists(HeadVars, ArgTypes, VarTypes), - clauses_info_set_vartypes(VarTypes, ClausesInfo0, ClausesInfo), - pred_info_set_clauses_info(ClausesInfo, !PredInfo) - ), - post_typecheck__propagate_types_into_modes(ModuleInfo, Errors, - !PredInfo). +finish_imported_pred_no_io(ModuleInfo, Errors, !PredInfo) :- + % Make sure the var-types field in the clauses_info is valid for imported + % predicates. Unification procedures have clauses generated, so they + % already have valid var-types. + ( pred_info_is_pseudo_imported(!.PredInfo) -> + true + ; + pred_info_clauses_info(!.PredInfo, ClausesInfo0), + clauses_info_headvars(ClausesInfo0, HeadVars), + pred_info_arg_types(!.PredInfo, ArgTypes), + map__from_corresponding_lists(HeadVars, ArgTypes, VarTypes), + clauses_info_set_vartypes(VarTypes, ClausesInfo0, ClausesInfo), + pred_info_set_clauses_info(ClausesInfo, !PredInfo) + ), + propagate_types_into_modes(ModuleInfo, Errors, !PredInfo). - % - % Now that the promise has finished being typechecked, - % and has had all of its pred_ids identified, - % remove the promise from the list of pred ids to be processed - % in the future and place the pred_id associated with the - % promise into the assertion or promise_ex table. - % For each assertion that is in the interface, you need to check - % that it doesn't refer to any symbols which are local to that - % module. - % Also record for each predicate that is used in an assertion - % which assertion it is used in, or for a promise ex declaration - % record in the promise ex table the predicates used by the - % declaration. - % -post_typecheck__finish_promise(PromiseType, PromiseId, !Module, !IO) :- - % Store the declaration in the appropriate table and get - % the goal for the promise - store_promise(PromiseType, PromiseId, !Module, Goal), + % Now that the promise has finished being typechecked, and has had all + % of its pred_ids identified, remove the promise from the list of pred ids + % to be processed in the future and place the pred_id associated with the + % promise into the assertion or promise_ex table. For each assertion + % that is in the interface, you need to check that it doesn't refer + % to any symbols which are local to that module. Also record for each + % predicate that is used in an assertion which assertion it is used in, + % or for a promise ex declaration record in the promise ex table + % the predicates used by the declaration. + % +finish_promise(PromiseType, PromiseId, !Module, !IO) :- + % Store the declaration in the appropriate table and get the goal + % for the promise. + store_promise(PromiseType, PromiseId, !Module, Goal), - % Remove from further processing. - module_info_remove_predid(PromiseId, !Module), + % Remove from further processing. + module_info_remove_predid(PromiseId, !Module), - % If the promise is in the interface, then ensure that - % it doesn't refer to any local symbols. - module_info_pred_info(!.Module, PromiseId, PredInfo), - ( pred_info_is_exported(PredInfo) -> - assertion__in_interface_check(Goal, PredInfo, !Module, !IO) - ; - true - ). + % If the promise is in the interface, then ensure that it doesn't refer + % to any local symbols. + module_info_pred_info(!.Module, PromiseId, PredInfo), + ( pred_info_is_exported(PredInfo) -> + assertion__in_interface_check(Goal, PredInfo, !Module, !IO) + ; + true + ). - % store promise declaration, normalise goal and return new - % module_info and the goal for further processing + % Store promise declaration, normalise goal and return new module_info + % and the goal for further processing. + % :- pred store_promise(promise_type::in, pred_id::in, - module_info::in, module_info::out, hlds_goal::out) is det. + module_info::in, module_info::out, hlds_goal::out) is det. store_promise(PromiseType, PromiseId, !Module, Goal) :- - ( - % case for assertions - PromiseType = true - -> - module_info_get_assertion_table(!.Module, AssertTable0), - assertion_table_add_assertion(PromiseId, AssertionId, - AssertTable0, AssertTable), - module_info_set_assertion_table(AssertTable, !Module), - assertion__goal(AssertionId, !.Module, Goal), - assertion__record_preds_used_in(Goal, AssertionId, !Module) - ; - % case for exclusivity - ( - PromiseType = exclusive - ; - PromiseType = exclusive_exhaustive - ) - -> - promise_ex_goal(PromiseId, !.Module, Goal), - predids_from_goal(Goal, PredIds), - module_info_get_exclusive_table(!.Module, Table0), - list__foldl(exclusive_table_add(PromiseId), PredIds, - Table0, Table), - module_info_set_exclusive_table(Table, !Module) + ( + % Case for assertions. + PromiseType = true + -> + module_info_get_assertion_table(!.Module, AssertTable0), + assertion_table_add_assertion(PromiseId, AssertionId, + AssertTable0, AssertTable), + module_info_set_assertion_table(AssertTable, !Module), + assertion__goal(AssertionId, !.Module, Goal), + assertion__record_preds_used_in(Goal, AssertionId, !Module) + ; + % Case for exclusivity. + ( + PromiseType = exclusive + ; + PromiseType = exclusive_exhaustive + ) + -> + promise_ex_goal(PromiseId, !.Module, Goal), + predids_from_goal(Goal, PredIds), + module_info_get_exclusive_table(!.Module, Table0), + list__foldl(exclusive_table_add(PromiseId), PredIds, Table0, Table), + module_info_set_exclusive_table(Table, !Module) + ; + % Case for exhaustiveness -- XXX not yet implemented. + promise_ex_goal(PromiseId, !.Module, Goal) + ). - ; - % case for exhaustiveness -- XXX not yet implemented - promise_ex_goal(PromiseId, !.Module, Goal) - ). - - % get the goal from a promise_ex declaration + % Get the goal from a promise_ex declaration. + % :- pred promise_ex_goal(pred_id::in, module_info::in, hlds_goal::out) is det. promise_ex_goal(ExclusiveDecl, Module, Goal) :- - module_info_pred_info(Module, ExclusiveDecl, PredInfo), - pred_info_clauses_info(PredInfo, ClausesInfo), - clauses_info_clauses_only(ClausesInfo, Clauses), - ( - Clauses = [clause(_ProcIds, Goal0, _Lang, _Context)] - -> - assertion__normalise_goal(Goal0, Goal) - ; - error("promise_ex__goal: not an promise") - ). + module_info_pred_info(Module, ExclusiveDecl, PredInfo), + pred_info_clauses_info(PredInfo, ClausesInfo), + clauses_info_clauses_only(ClausesInfo, Clauses), + ( Clauses = [clause(_ProcIds, Goal0, _Lang, _Context)] -> + assertion__normalise_goal(Goal0, Goal) + ; + error("promise_ex__goal: not an promise") + ). %-----------------------------------------------------------------------------% :- pred check_type_of_main(pred_info::in, io::di, io::uo) is det. check_type_of_main(PredInfo, !IO) :- - ( - % - % Check if this predicate is the - % program entry point main/2. - % - pred_info_name(PredInfo) = "main", - pred_info_orig_arity(PredInfo) = 2, - pred_info_is_exported(PredInfo) - -> - % - % Check that the arguments of main/2 - % have type `io__state'. - % - pred_info_arg_types(PredInfo, ArgTypes), - ( - ArgTypes = [Arg1, Arg2], - type_is_io_state(Arg1), - type_is_io_state(Arg2) - -> - true - ; - pred_info_context(PredInfo, Context), - error_util__write_error_pieces(Context, 0, - [words("Error: arguments of main/2"), - words("must have type `io__state'.")], !IO), - io__set_exit_status(1, !IO) - ) - ; - true - ). + ( + % Check if this predicate is the program entry point main/2. + pred_info_name(PredInfo) = "main", + pred_info_orig_arity(PredInfo) = 2, + pred_info_is_exported(PredInfo) + -> + % Check that the arguments of main/2 have type `io__state'. + pred_info_arg_types(PredInfo, ArgTypes), + ( + ArgTypes = [Arg1, Arg2], + type_is_io_state(Arg1), + type_is_io_state(Arg2) + -> + true + ; + pred_info_context(PredInfo, Context), + error_util__write_error_pieces(Context, 0, + [words("Error: arguments of main/2"), + words("must have type `io__state'.")], !IO), + io__set_exit_status(1, !IO) + ) + ; + true + ). %-----------------------------------------------------------------------------% - % - % Ensure that all constructors occurring in predicate mode - % declarations are module qualified. - % -:- pred post_typecheck__propagate_types_into_modes(module_info::in, - list(proc_id)::out, pred_info::in, pred_info::out) is det. + % Ensure that all constructors occurring in predicate mode + % declarations are module qualified. + % +:- pred propagate_types_into_modes(module_info::in, + list(proc_id)::out, pred_info::in, pred_info::out) is det. -post_typecheck__propagate_types_into_modes(ModuleInfo, ErrorProcs, - !PredInfo) :- - pred_info_arg_types(!.PredInfo, ArgTypes), - pred_info_procedures(!.PredInfo, Procs0), - ProcIds = pred_info_procids(!.PredInfo), - propagate_types_into_proc_modes(ModuleInfo, ProcIds, ArgTypes, - [], ErrorProcs, Procs0, Procs), - pred_info_set_procedures(Procs, !PredInfo). +propagate_types_into_modes(ModuleInfo, ErrorProcs, !PredInfo) :- + pred_info_arg_types(!.PredInfo, ArgTypes), + pred_info_procedures(!.PredInfo, Procs0), + ProcIds = pred_info_procids(!.PredInfo), + propagate_types_into_proc_modes(ModuleInfo, ProcIds, ArgTypes, + [], ErrorProcs, Procs0, Procs), + pred_info_set_procedures(Procs, !PredInfo). %-----------------------------------------------------------------------------% :- pred propagate_types_into_proc_modes(module_info::in, list(proc_id)::in, - list(type)::in, list(proc_id)::in, list(proc_id)::out, - proc_table::in, proc_table::out) is det. + list(type)::in, list(proc_id)::in, list(proc_id)::out, + proc_table::in, proc_table::out) is det. propagate_types_into_proc_modes(_, [], _, - ErrorProcs, list__reverse(ErrorProcs), !Procs). + ErrorProcs, list__reverse(ErrorProcs), !Procs). propagate_types_into_proc_modes(ModuleInfo, [ProcId | ProcIds], ArgTypes, - !ErrorProcs, !Procs) :- - map__lookup(!.Procs, ProcId, ProcInfo0), - proc_info_argmodes(ProcInfo0, ArgModes0), - propagate_types_into_mode_list(ModuleInfo, ArgTypes, - ArgModes0, ArgModes), + !ErrorProcs, !Procs) :- + map__lookup(!.Procs, ProcId, ProcInfo0), + proc_info_argmodes(ProcInfo0, ArgModes0), + propagate_types_into_mode_list(ModuleInfo, ArgTypes, + ArgModes0, ArgModes), - % - % check for unbound inst vars - % (this needs to be done after propagate_types_into_mode_list, - % because we need the insts to be module-qualified; and it - % needs to be done before mode analysis, to avoid internal errors) - % - ( mode_list_contains_inst_var(ArgModes, ModuleInfo, _InstVar) -> - !:ErrorProcs = [ProcId | !.ErrorProcs] - ; - proc_info_set_argmodes(ArgModes, ProcInfo0, ProcInfo), - map__det_update(!.Procs, ProcId, ProcInfo, !:Procs) - ), - propagate_types_into_proc_modes(ModuleInfo, ProcIds, ArgTypes, - !ErrorProcs, !Procs). + % Check for unbound inst vars. (This needs to be done after + % propagate_types_into_mode_list, because we need the insts + % to be module-qualified; and it needs to be done before mode analysis, + % to avoid internal errors.) + ( mode_list_contains_inst_var(ArgModes, ModuleInfo, _InstVar) -> + !:ErrorProcs = [ProcId | !.ErrorProcs] + ; + proc_info_set_argmodes(ArgModes, ProcInfo0, ProcInfo), + map__det_update(!.Procs, ProcId, ProcInfo, !:Procs) + ), + propagate_types_into_proc_modes(ModuleInfo, ProcIds, ArgTypes, + !ErrorProcs, !Procs). :- pred report_unbound_inst_vars(module_info::in, pred_id::in, - list(proc_id)::in, pred_info::in, pred_info::out, - io::di, io::uo) is det. + list(proc_id)::in, pred_info::in, pred_info::out, + io::di, io::uo) is det. report_unbound_inst_vars(ModuleInfo, PredId, ErrorProcs, !PredInfo, !IO) :- - ( ErrorProcs = [] -> - true - ; - pred_info_procedures(!.PredInfo, ProcTable0), - list__foldl2(report_unbound_inst_var_error(ModuleInfo, PredId), - ErrorProcs, ProcTable0, ProcTable, !IO), - pred_info_set_procedures(ProcTable, !PredInfo) - ). + ( + ErrorProcs = [] + ; + ErrorProcs = [_ | _], + pred_info_procedures(!.PredInfo, ProcTable0), + list__foldl2(report_unbound_inst_var_error(ModuleInfo, PredId), + ErrorProcs, ProcTable0, ProcTable, !IO), + pred_info_set_procedures(ProcTable, !PredInfo) + ). :- pred report_unbound_inst_var_error(module_info::in, - pred_id::in, proc_id::in, proc_table::in, proc_table::out, - io::di, io::uo) is det. + pred_id::in, proc_id::in, proc_table::in, proc_table::out, + io::di, io::uo) is det. report_unbound_inst_var_error(ModuleInfo, PredId, ProcId, Procs0, Procs, - !IO) :- - map__lookup(Procs0, ProcId, ProcInfo), - unbound_inst_var_error(PredId, ProcInfo, ModuleInfo, !IO), - % delete this mode, to avoid internal errors - map__det_remove(Procs0, ProcId, _, Procs). + !IO) :- + map__lookup(Procs0, ProcId, ProcInfo), + unbound_inst_var_error(PredId, ProcInfo, ModuleInfo, !IO), + % delete this mode, to avoid internal errors + map__det_remove(Procs0, ProcId, _, Procs). :- pred unbound_inst_var_error(pred_id::in, proc_info::in, module_info::in, - io::di, io::uo) is det. + io::di, io::uo) is det. -unbound_inst_var_error(PredId, ProcInfo, ModuleInfo) --> - { proc_info_context(ProcInfo, Context) }, - io__set_exit_status(1), - prog_out__write_context(Context), - io__write_string("In mode declaration for "), - hlds_out__write_pred_id(ModuleInfo, PredId), - io__write_string(":\n"), - prog_out__write_context(Context), - io__write_string(" error: unbound inst variable(s).\n"), - prog_out__write_context(Context), - io__write_string(" (Sorry, polymorphic modes are not supported.)\n"). +unbound_inst_var_error(PredId, ProcInfo, ModuleInfo, !IO) :- + proc_info_context(ProcInfo, Context), + io__set_exit_status(1, !IO), + Pieces = [words("In mode declaration for")] ++ + describe_one_pred_name(ModuleInfo, should_not_module_qualify, PredId) + ++ [suffix(":"), nl, + words("error: unbound inst variable(s)."), nl, + words("(Sorry, polymorphic modes are not supported.)"), nl], + write_error_pieces(Context, 0, Pieces, !IO). %-----------------------------------------------------------------------------% :- pred check_for_indistinguishable_modes(module_info::in, pred_id::in, - pred_info::in, pred_info::out, io::di, io::uo) is det. + pred_info::in, pred_info::out, io::di, io::uo) is det. check_for_indistinguishable_modes(ModuleInfo, PredId, !PredInfo, !IO) :- - ( - % - % Don't check for indistinguishable modes in unification - % predicates. The default (in, in) mode must be - % semidet, but for single-value types we also want to - % create a det mode which will be indistinguishable - % from the semidet mode. - % (When the type is known, the det mode is called, - % but the polymorphic unify needs to be able to call - % the semidet mode.) - % - pred_info_get_origin(!.PredInfo, Origin), - Origin = special_pred(spec_pred_unify - _) - -> - true - ; - ProcIds = pred_info_procids(!.PredInfo), - check_for_indistinguishable_modes(ModuleInfo, PredId, - ProcIds, [], !PredInfo, !IO) - ). + ( + % Don't check for indistinguishable modes in unification predicates. + % The default (in, in) mode must be semidet, but for single-value types + % we also want to create a det mode which will be indistinguishable + % from the semidet mode. (When the type is known, the det mode is + % called, but the polymorphic unify needs to be able to call + % the semidet mode.) + pred_info_get_origin(!.PredInfo, Origin), + Origin = special_pred(spec_pred_unify - _) + -> + true + ; + ProcIds = pred_info_procids(!.PredInfo), + check_for_indistinguishable_modes(ModuleInfo, PredId, + ProcIds, [], !PredInfo, !IO) + ). :- pred check_for_indistinguishable_modes(module_info::in, pred_id::in, - list(proc_id)::in, list(proc_id)::in, pred_info::in, pred_info::out, - io::di, io::uo) is det. + list(proc_id)::in, list(proc_id)::in, pred_info::in, pred_info::out, + io::di, io::uo) is det. check_for_indistinguishable_modes(_, _, [], _, !PredInfo, !IO). check_for_indistinguishable_modes(ModuleInfo, PredId, [ProcId | ProcIds], - PrevProcIds, !PredInfo, !IO) :- - check_for_indistinguishable_mode(ModuleInfo, PredId, ProcId, - PrevProcIds, Removed, !PredInfo, !IO), - PrevProcIds1 = - ( if Removed = yes then PrevProcIds - else [ProcId | PrevProcIds] - ), - check_for_indistinguishable_modes(ModuleInfo, PredId, ProcIds, - PrevProcIds1, !PredInfo, !IO). + PrevProcIds, !PredInfo, !IO) :- + check_for_indistinguishable_mode(ModuleInfo, PredId, ProcId, + PrevProcIds, Removed, !PredInfo, !IO), + ( + Removed = yes, + PrevProcIds1 = PrevProcIds + ; + Removed = no, + PrevProcIds1 = [ProcId | PrevProcIds] + ), + check_for_indistinguishable_modes(ModuleInfo, PredId, ProcIds, + PrevProcIds1, !PredInfo, !IO). :- pred check_for_indistinguishable_mode(module_info::in, pred_id::in, - proc_id::in, list(proc_id)::in, bool::out, - pred_info::in, pred_info::out, io::di, io::uo) is det. + proc_id::in, list(proc_id)::in, bool::out, + pred_info::in, pred_info::out, io::di, io::uo) is det. check_for_indistinguishable_mode(_, _, _, [], no, !PredInfo, !IO). check_for_indistinguishable_mode(ModuleInfo, PredId, ProcId1, - [ProcId | ProcIds], Removed, !PredInfo, !IO) :- - ( - modes_are_indistinguishable(ProcId, ProcId1, - !.PredInfo, ModuleInfo) - -> - pred_info_import_status(!.PredInfo, Status), - globals__io_lookup_bool_option(intermodule_optimization, - Intermod, !IO), - globals__io_lookup_bool_option(make_optimization_interface, - MakeOptInt, !IO), - ( - % With `--intermodule-optimization' we can read - % the declarations for a predicate from the `.int' - % and `.int0' files, so ignore the error in that case. - ( - status_defined_in_this_module(Status, yes) - ; - Intermod = no - ; - MakeOptInt = yes - ) - -> - report_indistinguishable_modes_error(ProcId1, - ProcId, PredId, !.PredInfo, ModuleInfo, !IO) - ; - true - ), - pred_info_remove_procid(ProcId1, !PredInfo), - Removed = yes - ; - check_for_indistinguishable_mode(ModuleInfo, PredId, ProcId1, - ProcIds, Removed, !PredInfo, !IO) - ). + [ProcId | ProcIds], Removed, !PredInfo, !IO) :- + ( modes_are_indistinguishable(ProcId, ProcId1, !.PredInfo, ModuleInfo) -> + pred_info_import_status(!.PredInfo, Status), + globals__io_lookup_bool_option(intermodule_optimization, + Intermod, !IO), + globals__io_lookup_bool_option(make_optimization_interface, + MakeOptInt, !IO), + ( + % With `--intermodule-optimization' we can read + % the declarations for a predicate from the `.int' + % and `.int0' files, so ignore the error in that case. + ( + status_defined_in_this_module(Status, yes) + ; + Intermod = no + ; + MakeOptInt = yes + ) + -> + report_indistinguishable_modes_error(ProcId1, + ProcId, PredId, !.PredInfo, ModuleInfo, !IO) + ; + true + ), + pred_info_remove_procid(ProcId1, !PredInfo), + Removed = yes + ; + check_for_indistinguishable_mode(ModuleInfo, PredId, ProcId1, + ProcIds, Removed, !PredInfo, !IO) + ). %-----------------------------------------------------------------------------% :- pred check_aditi_state(module_info::in, pred_info::in, - io::di, io::uo) is det. + io::di, io::uo) is det. check_aditi_state(ModuleInfo, PredInfo, !IO) :- - pred_info_arg_types(PredInfo, ArgTypes), - list__filter(type_is_aditi_state, ArgTypes, AditiStateTypes), - ( AditiStateTypes = [] -> - report_no_aditi_state(PredInfo, !IO) - ; - ProcIds = pred_info_procids(PredInfo), - list__foldl( - check_aditi_state_modes(ModuleInfo, - PredInfo, ArgTypes), - ProcIds, !IO) - ). + pred_info_arg_types(PredInfo, ArgTypes), + list__filter(type_is_aditi_state, ArgTypes, AditiStateTypes), + ( + AditiStateTypes = [], + report_no_aditi_state(PredInfo, !IO) + ; + AditiStateTypes = [_ | _], + ProcIds = pred_info_procids(PredInfo), + list__foldl(check_aditi_state_modes(ModuleInfo, PredInfo, ArgTypes), + ProcIds, !IO) + ). - % If the procedure has declared modes, check that there - % is an input `aditi__state' argument. + % If the procedure has declared modes, check that there is an input + % `aditi__state' argument. + % :- pred check_aditi_state_modes(module_info::in, pred_info::in, list(type)::in, - proc_id::in, io::di, io::uo) is det. + proc_id::in, io::di, io::uo) is det. check_aditi_state_modes(ModuleInfo, PredInfo, ArgTypes, ProcId, !IO) :- - pred_info_procedures(PredInfo, Procs), - map__lookup(Procs, ProcId, ProcInfo), - proc_info_maybe_declared_argmodes(ProcInfo, MaybeArgModes), - ( - MaybeArgModes = yes(ArgModes), - AditiUi = aditi_mui_mode, - mode_get_insts(ModuleInfo, AditiUi, AditiUiInitialInst, _), - ( - check_aditi_state_modes_2(ModuleInfo, ArgTypes, - ArgModes, AditiUiInitialInst) - -> - true - ; - proc_info_context(ProcInfo, Context), - report_no_input_aditi_state(PredInfo, Context, !IO) - ) - ; - % XXX Handling procedures for which modes are inferred - % is a little tricky, because if the procedure doesn't - % directly or indirectly call any base relations, a mode - % of `unused' for the `aditi__state' argument may be inferred. - % In the worst case, a runtime error will be reported - % if the predicate is called outside of a transaction. - MaybeArgModes = no - ). + pred_info_procedures(PredInfo, Procs), + map__lookup(Procs, ProcId, ProcInfo), + proc_info_maybe_declared_argmodes(ProcInfo, MaybeArgModes), + ( + MaybeArgModes = yes(ArgModes), + AditiUi = aditi_mui_mode, + mode_get_insts(ModuleInfo, AditiUi, AditiUiInitialInst, _), + ( + check_aditi_state_modes_2(ModuleInfo, ArgTypes, + ArgModes, AditiUiInitialInst) + -> + true + ; + proc_info_context(ProcInfo, Context), + report_no_input_aditi_state(PredInfo, Context, !IO) + ) + ; + % XXX Handling procedures for which modes are inferred + % is a little tricky, because if the procedure doesn't + % directly or indirectly call any base relations, a mode + % of `unused' for the `aditi__state' argument may be inferred. + % In the worst case, a runtime error will be reported + % if the predicate is called outside of a transaction. + MaybeArgModes = no + ). :- pred check_aditi_state_modes_2(module_info::in, list(type)::in, - list(mode)::in, (inst)::in) is semidet. + list(mode)::in, (inst)::in) is semidet. check_aditi_state_modes_2(ModuleInfo, [Type | Types], [Mode | Modes], - InitialAditiStateInst) :- - ( - type_is_aditi_state(Type), - mode_get_insts(ModuleInfo, Mode, InitialInst, _), - % Mode analysis will check the final inst. - inst_matches_initial(InitialInst, InitialAditiStateInst, - Type, ModuleInfo) - ; - check_aditi_state_modes_2(ModuleInfo, Types, Modes, - InitialAditiStateInst) - ). + InitialAditiStateInst) :- + ( + type_is_aditi_state(Type), + mode_get_insts(ModuleInfo, Mode, InitialInst, _), + % Mode analysis will check the final inst. + inst_matches_initial(InitialInst, InitialAditiStateInst, + Type, ModuleInfo) + ; + check_aditi_state_modes_2(ModuleInfo, Types, Modes, + InitialAditiStateInst) + ). :- pred report_no_aditi_state(pred_info::in, io::di, io::uo) is det. report_no_aditi_state(PredInfo, !IO) :- - io__set_exit_status(1, !IO), - pred_info_context(PredInfo, Context), - report_aditi_pragma(PredInfo, PredErrorPieces), - list__append(PredErrorPieces, - [words("without an `aditi__state' argument.")], ErrorPieces), - error_util__write_error_pieces(Context, 0, ErrorPieces, !IO). + io__set_exit_status(1, !IO), + pred_info_context(PredInfo, Context), + report_aditi_pragma(PredInfo, PredErrorPieces), + list__append(PredErrorPieces, + [words("without an `aditi__state' argument.")], ErrorPieces), + write_error_pieces(Context, 0, ErrorPieces, !IO). :- pred report_no_input_aditi_state(pred_info::in, prog_context::in, - io::di, io::uo) is det. + io::di, io::uo) is det. report_no_input_aditi_state(PredInfo, Context, !IO) :- - io__set_exit_status(1, !IO), - report_aditi_pragma(PredInfo, PredErrorPieces), - list__append(PredErrorPieces, - [words( - "without an `aditi__state' argument with mode `aditi_mui'.")], - ErrorPieces), - error_util__write_error_pieces(Context, 0, ErrorPieces, !IO). + io__set_exit_status(1, !IO), + report_aditi_pragma(PredInfo, PredErrorPieces), + list__append(PredErrorPieces, + [words("without an `aditi__state' argument with mode `aditi_mui'.")], + ErrorPieces), + error_util__write_error_pieces(Context, 0, ErrorPieces, !IO). :- pred report_aditi_pragma(pred_info::in, list(format_component)::out) is det. report_aditi_pragma(PredInfo, ErrorPieces) :- - Module = pred_info_module(PredInfo), - Name = pred_info_name(PredInfo), - Arity = pred_info_orig_arity(PredInfo), - PredOrFunc = pred_info_is_pred_or_func(PredInfo), - pred_info_get_markers(PredInfo, Markers), - ( check_marker(Markers, base_relation) -> - Pragma = "base_relation" - ; - Pragma = "aditi" - ), - string__append_list(["`:- pragma ", Pragma, "'"], PragmaStr), - CallId = PredOrFunc - qualified(Module, Name)/Arity, - CallIdStr = simple_call_id_to_string(CallId), - ErrorPieces = [fixed("Error:"), fixed(PragmaStr), - words("declaration for"), fixed(CallIdStr)]. + Module = pred_info_module(PredInfo), + Name = pred_info_name(PredInfo), + Arity = pred_info_orig_arity(PredInfo), + PredOrFunc = pred_info_is_pred_or_func(PredInfo), + pred_info_get_markers(PredInfo, Markers), + ( check_marker(Markers, base_relation) -> + Pragma = "base_relation" + ; + Pragma = "aditi" + ), + string__append_list(["`:- pragma ", Pragma, "'"], PragmaStr), + CallId = PredOrFunc - qualified(Module, Name)/Arity, + CallIdStr = simple_call_id_to_string(CallId), + ErrorPieces = [fixed("Error:"), fixed(PragmaStr), + words("declaration for"), fixed(CallIdStr)]. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% -post_typecheck__resolve_unify_functor(X0, ConsId0, ArgVars0, Mode0, - Unification0, UnifyContext, GoalInfo0, - ModuleInfo, !PredInfo, !VarTypes, !VarSet, Goal) :- +resolve_unify_functor(X0, ConsId0, ArgVars0, Mode0, Unification0, UnifyContext, + GoalInfo0, ModuleInfo, !PredInfo, !VarTypes, !VarSet, Goal) :- + map__lookup(!.VarTypes, X0, TypeOfX), + list__length(ArgVars0, Arity), + ( + % Is the function symbol apply/N or ''/N, representing a higher-order + % function call? Or the impure/semipure equivalents impure_apply/N + % and semipure_apply/N? + % (XXX FIXME We should use nicer syntax for impure apply/N.) + ConsId0 = cons(unqualified(ApplyName), _), + ( ApplyName = "apply", Purity = (pure) + ; ApplyName = "", Purity = (pure) + ; ApplyName = "impure_apply", Purity = (impure) + ; ApplyName = "semipure_apply", Purity = (semipure) + ), + Arity >= 1, + ArgVars0 = [FuncVar | FuncArgVars] + -> + % Convert the higher-order function call (apply/N) into a higher-order + % predicate call (i.e., replace `X = apply(F, A, B, C)' + % with `call(F, A, B, C, X)') + list__append(FuncArgVars, [X0], ArgVars), + Modes = [], + Det = erroneous, + adjust_func_arity(function, Arity, FullArity), + HOCall = generic_call( + higher_order(FuncVar, Purity, function, FullArity), + ArgVars, Modes, Det), + Goal = HOCall - GoalInfo0 + ; + % Is the function symbol a user-defined function, rather than + % a functor which represents a data constructor? - map__lookup(!.VarTypes, X0, TypeOfX), - list__length(ArgVars0, Arity), - ( - % - % Is the function symbol apply/N or ''/N, - % representing a higher-order function call? - % Or the impure/semipure equivalents impure_apply/N - % and semipure_apply/N? - % (XXX FIXME We should use nicer syntax for impure apply/N.) - % - ConsId0 = cons(unqualified(ApplyName), _), - ( ApplyName = "apply", Purity = (pure) - ; ApplyName = "", Purity = (pure) - ; ApplyName = "impure_apply", Purity = (impure) - ; ApplyName = "semipure_apply", Purity = (semipure) - ), - Arity >= 1, - ArgVars0 = [FuncVar | FuncArgVars] - -> - % - % Convert the higher-order function call (apply/N) - % into a higher-order predicate call - % (i.e., replace `X = apply(F, A, B, C)' - % with `call(F, A, B, C, X)') - % - list__append(FuncArgVars, [X0], ArgVars), - Modes = [], - Det = erroneous, - adjust_func_arity(function, Arity, FullArity), - HOCall = generic_call( - higher_order(FuncVar, Purity, function, FullArity), - ArgVars, Modes, Det), - Goal = HOCall - GoalInfo0 - ; - % - % Is the function symbol a user-defined function, rather - % than a functor which represents a data constructor? - % + % Find the set of candidate predicates which have the + % specified name and arity (and module, if module-qualified) + ConsId0 = cons(PredName, _), - % Find the set of candidate predicates which have the - % specified name and arity (and module, if module-qualified) - ConsId0 = cons(PredName, _), + % We don't do this for compiler-generated predicates; they are assumed + % to have been generated with all functions already expanded. If we did + % this check for compiler-generated predicates, it would cause the + % wrong behaviour in the case where there is a user-defined function + % whose type is exactly the same as the type of a constructor. + % (Normally that would cause a type ambiguity error, but + % compiler-generated predicates are not type-checked.) + \+ is_unify_or_compare_pred(!.PredInfo), - % - % We don't do this for compiler-generated predicates; - % they are assumed to have been generated with all - % functions already expanded. - % If we did this check for compiler-generated - % predicates, it would cause the wrong behaviour - % in the case where there is a user-defined function - % whose type is exactly the same as the type of - % a constructor. (Normally that would cause - % a type ambiguity error, but compiler-generated - % predicates are not type-checked.) - % - \+ is_unify_or_compare_pred(!.PredInfo), + % We don't do this for the clause introduced by the compiler for a + % field access function -- that needs to be expanded into + % unifications below. + \+ pred_info_is_field_access_function(ModuleInfo, !.PredInfo), - % - % We don't do this for the clause introduced by the - % compiler for a field access function -- that needs - % to be expanded into unifications below. - % - \+ pred_info_is_field_access_function(ModuleInfo, !.PredInfo), + pred_info_get_markers(!.PredInfo, Markers), + module_info_get_predicate_table(ModuleInfo, PredTable), + predicate_table_search_func_sym_arity(PredTable, + calls_are_fully_qualified(Markers), + PredName, Arity, PredIds), - pred_info_get_markers(!.PredInfo, Markers), - module_info_get_predicate_table(ModuleInfo, PredTable), - predicate_table_search_func_sym_arity(PredTable, - calls_are_fully_qualified(Markers), - PredName, Arity, PredIds), + % Check if any of the candidate functions have argument/return types + % which subsume the actual argument/return types of this function call. + pred_info_typevarset(!.PredInfo, TVarSet), + map__apply_to_list(ArgVars0, !.VarTypes, ArgTypes0), + list__append(ArgTypes0, [TypeOfX], ArgTypes), + typecheck__find_matching_pred_id(PredIds, ModuleInfo, + TVarSet, ArgTypes, PredId, QualifiedFuncName) + -> + % Convert function calls into predicate calls: + % replace `X = f(A, B, C)' with `f(A, B, C, X)'. + % + ProcId = invalid_proc_id, + list__append(ArgVars0, [X0], ArgVars), + FuncCallUnifyContext = call_unify_context(X0, + functor(ConsId0, no, ArgVars0), UnifyContext), + FuncCall = call(PredId, ProcId, ArgVars, not_builtin, + yes(FuncCallUnifyContext), QualifiedFuncName), + Goal = FuncCall - GoalInfo0 + ; + % Is the function symbol a higher-order predicate + % or function constant? + ConsId0 = cons(Name, _), + type_is_higher_order(TypeOfX, _Purity, PredOrFunc, + EvalMethod, HOArgTypes), - % Check if any of the candidate functions have - % argument/return types which subsume the actual - % argument/return types of this function call + % We don't do this for the clause introduced by the compiler + % for a field access function -- that needs to be expanded + % into unifications below. + \+ pred_info_is_field_access_function(ModuleInfo, !.PredInfo), - pred_info_typevarset(!.PredInfo, TVarSet), - map__apply_to_list(ArgVars0, !.VarTypes, ArgTypes0), - list__append(ArgTypes0, [TypeOfX], ArgTypes), - typecheck__find_matching_pred_id(PredIds, ModuleInfo, - TVarSet, ArgTypes, PredId, QualifiedFuncName) - -> - % - % Convert function calls into predicate calls: - % replace `X = f(A, B, C)' - % with `f(A, B, C, X)' - % - ProcId = invalid_proc_id, - list__append(ArgVars0, [X0], ArgVars), - FuncCallUnifyContext = call_unify_context(X0, - functor(ConsId0, no, ArgVars0), UnifyContext), - FuncCall = call(PredId, ProcId, ArgVars, not_builtin, - yes(FuncCallUnifyContext), QualifiedFuncName), - Goal = FuncCall - GoalInfo0 - ; - % - % Is the function symbol a higher-order predicate - % or function constant? - % - ConsId0 = cons(Name, _), - type_is_higher_order(TypeOfX, _Purity, PredOrFunc, - EvalMethod, HOArgTypes), + % Find the pred_id of the constant. + map__apply_to_list(ArgVars0, !.VarTypes, ArgTypes0), + AllArgTypes = ArgTypes0 ++ HOArgTypes, + pred_info_typevarset(!.PredInfo, TVarSet), + pred_info_get_markers(!.PredInfo, Markers), + get_pred_id(calls_are_fully_qualified(Markers), Name, + PredOrFunc, TVarSet, AllArgTypes, ModuleInfo, PredId) + -> + get_proc_id(ModuleInfo, PredId, ProcId), + ShroudedPredProcId = shroud_pred_proc_id(proc(PredId, ProcId)), + ConsId = pred_const(ShroudedPredProcId, EvalMethod), + Goal = unify(X0, functor(ConsId, no, ArgVars0), Mode0, + Unification0, UnifyContext) - GoalInfo0 + ; + % Is it a call to an automatically generated field access function. + % This test must come after the tests for function calls and + % higher-order terms above. It's done that way because it's easier + % to check that the types match for functions calls and higher-order + % terms. + ConsId0 = cons(Name, Arity), + is_field_access_function_name(ModuleInfo, Name, Arity, + AccessType, FieldName), - % - % We don't do this for the clause introduced by the - % compiler for a field access function -- that needs - % to be expanded into unifications below. - % - \+ pred_info_is_field_access_function(ModuleInfo, !.PredInfo), + % We don't do this for compiler-generated predicates -- + % they will never contain calls to field access functions. + \+ is_unify_or_compare_pred(!.PredInfo), - % - % Find the pred_id of the constant. - % - map__apply_to_list(ArgVars0, !.VarTypes, ArgTypes0), - AllArgTypes = ArgTypes0 ++ HOArgTypes, - pred_info_typevarset(!.PredInfo, TVarSet), - pred_info_get_markers(!.PredInfo, Markers), - get_pred_id(calls_are_fully_qualified(Markers), Name, - PredOrFunc, TVarSet, AllArgTypes, ModuleInfo, PredId) - -> - get_proc_id(ModuleInfo, PredId, ProcId), - ShroudedPredProcId = - shroud_pred_proc_id(proc(PredId, ProcId)), - ConsId = pred_const(ShroudedPredProcId, EvalMethod), - Goal = unify(X0, functor(ConsId, no, ArgVars0), Mode0, - Unification0, UnifyContext) - GoalInfo0 - ; - % - % Is it a call to an automatically generated field access - % function. This test must come after the tests for - % function calls and higher-order terms above. - % It's done that way because it's easier to check - % that the types match for functions calls and - % higher-order terms. - % - ConsId0 = cons(Name, Arity), - is_field_access_function_name(ModuleInfo, Name, Arity, - AccessType, FieldName), - - % - % We don't do this for compiler-generated predicates -- - % they will never contain calls to field access functions. - % - \+ is_unify_or_compare_pred(!.PredInfo), - - % - % If there is a constructor for which the argument types - % match, this unification couldn't be a call to a field - % access function, otherwise there would have been an - % error reported for unresolved overloading. - % - pred_info_typevarset(!.PredInfo, TVarSet), - map__apply_to_list(ArgVars0, !.VarTypes, ArgTypes0), - \+ find_matching_constructor(ModuleInfo, TVarSet, - ConsId0, TypeOfX, ArgTypes0) - -> - post_typecheck__finish_field_access_function(ModuleInfo, - !PredInfo, !VarTypes, !VarSet, AccessType, FieldName, - UnifyContext, X0, ArgVars0, GoalInfo0, Goal) - ; - % - % Module qualify ordinary construction/deconstruction - % unifications. - % - ( - ConsId0 = cons(Name0, Arity), - type_to_ctor_and_args(TypeOfX, TypeCtorOfX, _), - TypeCtorOfX = qualified(TypeModule, _) - _ - -> - unqualify_name(Name0, Name), - ConsId = cons(qualified(TypeModule, Name), Arity) - ; - ConsId = ConsId0 - ), - Goal = unify(X0, functor(ConsId, no, ArgVars0), Mode0, - Unification0, UnifyContext) - GoalInfo0 - ). + % If there is a constructor for which the argument types match, + % this unification couldn't be a call to a field access function, + % otherwise there would have been an error reported for unresolved + % overloading. + pred_info_typevarset(!.PredInfo, TVarSet), + map__apply_to_list(ArgVars0, !.VarTypes, ArgTypes0), + \+ find_matching_constructor(ModuleInfo, TVarSet, ConsId0, + TypeOfX, ArgTypes0) + -> + finish_field_access_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet, + AccessType, FieldName, UnifyContext, X0, ArgVars0, GoalInfo0, Goal) + ; + % Module qualify ordinary construction/deconstruction unifications. + ( + ConsId0 = cons(Name0, Arity), + type_to_ctor_and_args(TypeOfX, TypeCtorOfX, _), + TypeCtorOfX = qualified(TypeModule, _) - _ + -> + unqualify_name(Name0, Name), + ConsId = cons(qualified(TypeModule, Name), Arity) + ; + ConsId = ConsId0 + ), + Goal = unify(X0, functor(ConsId, no, ArgVars0), Mode0, + Unification0, UnifyContext) - GoalInfo0 + ). %-----------------------------------------------------------------------------% - % Succeed if there is a constructor which matches the given - % cons_id, type and argument types. + % Succeed if there is a constructor which matches the given cons_id, + % type and argument types. + % :- pred find_matching_constructor(module_info::in, tvarset::in, - cons_id::in, (type)::in, list(type)::in) is semidet. + cons_id::in, (type)::in, list(type)::in) is semidet. find_matching_constructor(ModuleInfo, TVarSet, ConsId, Type, ArgTypes) :- - type_to_ctor_and_args(Type, TypeCtor, _), - module_info_get_cons_table(ModuleInfo, ConsTable), - map__search(ConsTable, ConsId, ConsDefns), - list__member(ConsDefn, ConsDefns), + type_to_ctor_and_args(Type, TypeCtor, _), + module_info_get_cons_table(ModuleInfo, ConsTable), + map__search(ConsTable, ConsId, ConsDefns), + list__member(ConsDefn, ConsDefns), - % Overloading resolution ignores the class constraints. - ConsDefn = hlds_cons_defn(ConsExistQVars, _, - ConsArgs, ConsTypeCtor, _), - ConsTypeCtor = TypeCtor, + % Overloading resolution ignores the class constraints. + ConsDefn = hlds_cons_defn(ConsExistQVars, _, ConsArgs, ConsTypeCtor, _), + ConsTypeCtor = TypeCtor, - module_info_get_type_table(ModuleInfo, Types), - map__search(Types, TypeCtor, TypeDefn), - hlds_data__get_type_defn_tvarset(TypeDefn, TypeTVarSet), - hlds_data__get_type_defn_kind_map(TypeDefn, TypeKindMap), + module_info_get_type_table(ModuleInfo, Types), + map__search(Types, TypeCtor, TypeDefn), + hlds_data__get_type_defn_tvarset(TypeDefn, TypeTVarSet), + hlds_data__get_type_defn_kind_map(TypeDefn, TypeKindMap), - assoc_list__values(ConsArgs, ConsArgTypes), - arg_type_list_subsumes(TVarSet, ArgTypes, TypeTVarSet, TypeKindMap, - ConsExistQVars, ConsArgTypes). + assoc_list__values(ConsArgs, ConsArgTypes), + arg_type_list_subsumes(TVarSet, ArgTypes, TypeTVarSet, TypeKindMap, + ConsExistQVars, ConsArgTypes). %-----------------------------------------------------------------------------% - % Convert a field access function call into the equivalent unifications - % so that later passes do not have to handle them as a special case. - % The error messages from mode analysis and determinism analysis - % shouldn't be too much worse than if the goals were special cases. - % -:- pred post_typecheck__finish_field_access_function(module_info::in, - pred_info::in, pred_info::out, vartypes::in, vartypes::out, - prog_varset::in, prog_varset::out, - field_access_type::in, ctor_field_name::in, - unify_context::in, prog_var::in, list(prog_var)::in, - hlds_goal_info::in, hlds_goal::out) is det. + % Convert a field access function call into the equivalent unifications + % so that later passes do not have to handle them as a special case. + % The error messages from mode analysis and determinism analysis + % shouldn't be too much worse than if the goals were special cases. + % +:- pred finish_field_access_function(module_info::in, + pred_info::in, pred_info::out, vartypes::in, vartypes::out, + prog_varset::in, prog_varset::out, + field_access_type::in, ctor_field_name::in, + unify_context::in, prog_var::in, list(prog_var)::in, + hlds_goal_info::in, hlds_goal::out) is det. -post_typecheck__finish_field_access_function(ModuleInfo, !PredInfo, - !VarTypes, !VarSet, AccessType, FieldName, UnifyContext, - Var, Args, GoalInfo, GoalExpr - GoalInfo) :- - ( - AccessType = get, - field_extraction_function_args(Args, TermVar), - post_typecheck__translate_get_function(ModuleInfo, - !PredInfo, !VarTypes, !VarSet, FieldName, UnifyContext, - Var, TermVar, GoalInfo, GoalExpr) - ; - AccessType = set, - field_update_function_args(Args, TermInputVar, FieldVar), - post_typecheck__translate_set_function(ModuleInfo, - !PredInfo, !VarTypes, !VarSet, FieldName, UnifyContext, - FieldVar, TermInputVar, Var, - GoalInfo, GoalExpr) - ). +finish_field_access_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet, + AccessType, FieldName, UnifyContext, Var, Args, GoalInfo, + GoalExpr - GoalInfo) :- + ( + AccessType = get, + field_extraction_function_args(Args, TermVar), + translate_get_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet, + FieldName, UnifyContext, Var, TermVar, GoalInfo, GoalExpr) + ; + AccessType = set, + field_update_function_args(Args, TermInputVar, FieldVar), + translate_set_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet, + FieldName, UnifyContext, FieldVar, TermInputVar, Var, + GoalInfo, GoalExpr) + ). -:- pred post_typecheck__translate_get_function(module_info::in, - pred_info::in, pred_info::out, vartypes::in, vartypes::out, - prog_varset::in, prog_varset::out, ctor_field_name::in, - unify_context::in, prog_var::in, prog_var::in, - hlds_goal_info::in, hlds_goal_expr::out) is det. +:- pred translate_get_function(module_info::in, + pred_info::in, pred_info::out, vartypes::in, vartypes::out, + prog_varset::in, prog_varset::out, ctor_field_name::in, + unify_context::in, prog_var::in, prog_var::in, + hlds_goal_info::in, hlds_goal_expr::out) is det. -post_typecheck__translate_get_function(ModuleInfo, !PredInfo, - !VarTypes, !VarSet, FieldName, UnifyContext, - FieldVar, TermInputVar, OldGoalInfo, GoalExpr) :- - map__lookup(!.VarTypes, TermInputVar, TermType), - get_constructor_containing_field(ModuleInfo, TermType, FieldName, - ConsId, FieldNumber), +translate_get_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet, FieldName, + UnifyContext, FieldVar, TermInputVar, OldGoalInfo, GoalExpr) :- + map__lookup(!.VarTypes, TermInputVar, TermType), + get_constructor_containing_field(ModuleInfo, TermType, FieldName, + ConsId, FieldNumber), - get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, ConsId, - TermType, ArgTypes0, ExistQVars, !PredInfo), + get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, ConsId, + TermType, ArgTypes0, ExistQVars, !PredInfo), - % - % If the type of the field we are extracting contains existentially - % quantified type variables then we need to rename any other - % occurrences of those type variables in the arguments of the - % constructor so that they match those in the type of the field. - % (We don't need to do this for field updates because if any - % existentially quantified type variables occur in field to set - % and other fields then the field update should have been disallowed - % by typecheck.m because the result can't be well-typed). - % - ( ExistQVars \= [] -> - map__lookup(!.VarTypes, FieldVar, FieldType), - list__index1_det(ArgTypes0, FieldNumber, FieldArgType), - ( - type_list_subsumes([FieldArgType], [FieldType], - FieldSubst) - -> - apply_rec_subst_to_type_list(FieldSubst, ArgTypes0, - ArgTypes) - ; - error("post_typecheck__translate_get_function: " ++ - "type_list_subsumes failed") - ) - ; - ArgTypes = ArgTypes0 - ), + % If the type of the field we are extracting contains existentially + % quantified type variables then we need to rename any other + % occurrences of those type variables in the arguments of the + % constructor so that they match those in the type of the field. + % (We don't need to do this for field updates because if any + % existentially quantified type variables occur in field to set + % and other fields then the field update should have been disallowed + % by typecheck.m because the result can't be well-typed). + ( + ExistQVars = [_ | _], + map__lookup(!.VarTypes, FieldVar, FieldType), + list__index1_det(ArgTypes0, FieldNumber, FieldArgType), + ( type_list_subsumes([FieldArgType], [FieldType], FieldSubst) -> + apply_rec_subst_to_type_list(FieldSubst, ArgTypes0, ArgTypes) + ; + error("translate_get_function: type_list_subsumes failed") + ) + ; + ExistQVars = [], + ArgTypes = ArgTypes0 + ), - split_list_at_index(FieldNumber, ArgTypes, - TypesBeforeField, _, TypesAfterField), + split_list_at_index(FieldNumber, ArgTypes, TypesBeforeField, + _, TypesAfterField), - make_new_vars(TypesBeforeField, VarsBeforeField, !VarTypes, !VarSet), - make_new_vars(TypesAfterField, VarsAfterField, !VarTypes, !VarSet), + make_new_vars(TypesBeforeField, VarsBeforeField, !VarTypes, !VarSet), + make_new_vars(TypesAfterField, VarsAfterField, !VarTypes, !VarSet), - list__append(VarsBeforeField, [FieldVar | VarsAfterField], ArgVars), + list__append(VarsBeforeField, [FieldVar | VarsAfterField], ArgVars), - goal_info_get_nonlocals(OldGoalInfo, RestrictNonLocals), - create_atomic_unification_with_nonlocals(TermInputVar, - functor(ConsId, no, ArgVars), OldGoalInfo, - RestrictNonLocals, [FieldVar, TermInputVar], - UnifyContext, FunctorGoal), - FunctorGoal = GoalExpr - _. + goal_info_get_nonlocals(OldGoalInfo, RestrictNonLocals), + create_atomic_unification_with_nonlocals(TermInputVar, + functor(ConsId, no, ArgVars), OldGoalInfo, + RestrictNonLocals, [FieldVar, TermInputVar], + UnifyContext, FunctorGoal), + FunctorGoal = GoalExpr - _. -:- pred post_typecheck__translate_set_function(module_info::in, - pred_info::in, pred_info::out, vartypes::in, vartypes::out, - prog_varset::in, prog_varset::out, ctor_field_name::in, - unify_context::in, prog_var::in, prog_var::in, prog_var::in, - hlds_goal_info::in, hlds_goal_expr::out) is det. +:- pred translate_set_function(module_info::in, + pred_info::in, pred_info::out, vartypes::in, vartypes::out, + prog_varset::in, prog_varset::out, ctor_field_name::in, + unify_context::in, prog_var::in, prog_var::in, prog_var::in, + hlds_goal_info::in, hlds_goal_expr::out) is det. -post_typecheck__translate_set_function(ModuleInfo, !PredInfo, - !VarTypes, !VarSet, FieldName, UnifyContext, - FieldVar, TermInputVar, TermOutputVar, OldGoalInfo, Goal) :- - map__lookup(!.VarTypes, TermInputVar, TermType), +translate_set_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet, + FieldName, UnifyContext, FieldVar, TermInputVar, TermOutputVar, + OldGoalInfo, Goal) :- + map__lookup(!.VarTypes, TermInputVar, TermType), - get_constructor_containing_field(ModuleInfo, TermType, FieldName, - ConsId0, FieldNumber), + get_constructor_containing_field(ModuleInfo, TermType, FieldName, + ConsId0, FieldNumber), - get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, ConsId0, - TermType, ArgTypes, ExistQVars, !PredInfo), + get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, ConsId0, + TermType, ArgTypes, ExistQVars, !PredInfo), - split_list_at_index(FieldNumber, ArgTypes, - TypesBeforeField, TermFieldType, TypesAfterField), + split_list_at_index(FieldNumber, ArgTypes, + TypesBeforeField, TermFieldType, TypesAfterField), - make_new_vars(TypesBeforeField, VarsBeforeField, !VarTypes, !VarSet), - make_new_var(TermFieldType, SingletonFieldVar, !VarTypes, !VarSet), - make_new_vars(TypesAfterField, VarsAfterField, !VarTypes, !VarSet), + make_new_vars(TypesBeforeField, VarsBeforeField, !VarTypes, !VarSet), + make_new_var(TermFieldType, SingletonFieldVar, !VarTypes, !VarSet), + make_new_vars(TypesAfterField, VarsAfterField, !VarTypes, !VarSet), - % - % Build a goal to deconstruct the input. - % - list__append(VarsBeforeField, [SingletonFieldVar | VarsAfterField], - DeconstructArgs), - goal_info_get_nonlocals(OldGoalInfo, OldNonLocals), - list__append(VarsBeforeField, VarsAfterField, NonLocalArgs), - set__insert_list(OldNonLocals, NonLocalArgs, - DeconstructRestrictNonLocals), + % Build a goal to deconstruct the input. + list__append(VarsBeforeField, [SingletonFieldVar | VarsAfterField], + DeconstructArgs), + goal_info_get_nonlocals(OldGoalInfo, OldNonLocals), + list__append(VarsBeforeField, VarsAfterField, NonLocalArgs), + set__insert_list(OldNonLocals, NonLocalArgs, + DeconstructRestrictNonLocals), - create_atomic_unification_with_nonlocals(TermInputVar, - functor(ConsId0, no, DeconstructArgs), OldGoalInfo, - DeconstructRestrictNonLocals, [TermInputVar | DeconstructArgs], - UnifyContext, DeconstructGoal), + create_atomic_unification_with_nonlocals(TermInputVar, + functor(ConsId0, no, DeconstructArgs), OldGoalInfo, + DeconstructRestrictNonLocals, [TermInputVar | DeconstructArgs], + UnifyContext, DeconstructGoal), - % - % Build a goal to construct the output. - % - list__append(VarsBeforeField, [FieldVar | VarsAfterField], - ConstructArgs), - set__insert_list(OldNonLocals, NonLocalArgs, - ConstructRestrictNonLocals), + % Build a goal to construct the output. + list__append(VarsBeforeField, [FieldVar | VarsAfterField], + ConstructArgs), + set__insert_list(OldNonLocals, NonLocalArgs, + ConstructRestrictNonLocals), - % If the cons_id is existentially quantified, add a `new' prefix - % so that polymorphism.m adds the appropriate type_infos. - ( - ExistQVars = [], - ConsId = ConsId0 - ; - ExistQVars = [_ | _], - ( ConsId0 = cons(ConsName0, ConsArity) -> - remove_new_prefix(ConsName, ConsName0), - ConsId = cons(ConsName, ConsArity) - ; - error("post_typecheck__translate_set_function: " ++ - "invalid cons_id") - ) - ), + % If the cons_id is existentially quantified, add a `new' prefix + % so that polymorphism.m adds the appropriate type_infos. + ( + ExistQVars = [], + ConsId = ConsId0 + ; + ExistQVars = [_ | _], + ( ConsId0 = cons(ConsName0, ConsArity) -> + remove_new_prefix(ConsName, ConsName0), + ConsId = cons(ConsName, ConsArity) + ; + error("translate_set_function: invalid cons_id") + ) + ), - create_atomic_unification_with_nonlocals(TermOutputVar, - functor(ConsId, no, ConstructArgs), OldGoalInfo, - ConstructRestrictNonLocals, [TermOutputVar | ConstructArgs], - UnifyContext, ConstructGoal), + create_atomic_unification_with_nonlocals(TermOutputVar, + functor(ConsId, no, ConstructArgs), OldGoalInfo, + ConstructRestrictNonLocals, [TermOutputVar | ConstructArgs], + UnifyContext, ConstructGoal), - Conj = conj([DeconstructGoal, ConstructGoal]) - OldGoalInfo, + Conj = conj([DeconstructGoal, ConstructGoal]) - OldGoalInfo, - % Make mode analysis treat the translated access function - % as an atomic goal. - Goal = scope(barrier(removable), Conj). + % Make mode analysis treat the translated access function + % as an atomic goal. + Goal = scope(barrier(removable), Conj). :- pred get_cons_id_arg_types_adding_existq_tvars(module_info::in, cons_id::in, - (type)::in, list(type)::out, list(tvar)::out, - pred_info::in, pred_info::out) is det. + (type)::in, list(type)::out, list(tvar)::out, + pred_info::in, pred_info::out) is det. get_cons_id_arg_types_adding_existq_tvars(ModuleInfo, ConsId, TermType, - ArgTypes, NewExistQVars, !PredInfo) :- - % - % Split the list of argument types at the named field. - % - type_util__get_type_and_cons_defn(ModuleInfo, TermType, - ConsId, TypeDefn, ConsDefn), - ConsDefn = hlds_cons_defn(ExistQVars, _, Args, _, _), - assoc_list__values(Args, ArgTypes0), - ( ExistQVars = [] -> - ArgTypes1 = ArgTypes0, - NewExistQVars = [] - ; - % - % Rename apart the existentially quantified type variables. - % - list__length(ExistQVars, NumExistQVars), - pred_info_typevarset(!.PredInfo, TVarSet0), - varset__new_vars(TVarSet0, NumExistQVars, NewExistQVars, - TVarSet), - pred_info_set_typevarset(TVarSet, !PredInfo), - map__from_corresponding_lists(ExistQVars, NewExistQVars, - TVarSubst), - apply_variable_renaming_to_type_list(TVarSubst, ArgTypes0, - ArgTypes1) - ), - hlds_data__get_type_defn_tparams(TypeDefn, TypeParams), - ( type_to_ctor_and_args(TermType, _, TypeArgs) -> - map__from_corresponding_lists(TypeParams, TypeArgs, TSubst) - ; - error("get_cons_id_arg_types_adding_existq_tvars: " ++ - "type_to_ctor_and_args failed") + ArgTypes, NewExistQVars, !PredInfo) :- + % Split the list of argument types at the named field. + type_util__get_type_and_cons_defn(ModuleInfo, TermType, ConsId, + TypeDefn, ConsDefn), + ConsDefn = hlds_cons_defn(ExistQVars, _, Args, _, _), + assoc_list__values(Args, ArgTypes0), + ( + ExistQVars = [], + ArgTypes1 = ArgTypes0, + NewExistQVars = [] + ; + ExistQVars = [_ | _], + % Rename apart the existentially quantified type variables. + list__length(ExistQVars, NumExistQVars), + pred_info_typevarset(!.PredInfo, TVarSet0), + varset__new_vars(TVarSet0, NumExistQVars, NewExistQVars, TVarSet), + pred_info_set_typevarset(TVarSet, !PredInfo), + map__from_corresponding_lists(ExistQVars, NewExistQVars, TVarSubst), + apply_variable_renaming_to_type_list(TVarSubst, ArgTypes0, ArgTypes1) + ), + hlds_data__get_type_defn_tparams(TypeDefn, TypeParams), + ( type_to_ctor_and_args(TermType, _, TypeArgs) -> + map__from_corresponding_lists(TypeParams, TypeArgs, TSubst) + ; + error("get_cons_id_arg_types_adding_existq_tvars: " ++ + "type_to_ctor_and_args failed") - ), - apply_subst_to_type_list(TSubst, ArgTypes1, ArgTypes). + ), + apply_subst_to_type_list(TSubst, ArgTypes1, ArgTypes). :- pred split_list_at_index(int::in, list(T)::in, list(T)::out, T::out, - list(T)::out) is det. + list(T)::out) is det. split_list_at_index(Index, List, Before, At, After) :- - ( - list__split_list(Index - 1, List, Before0, AtAndAfter), - AtAndAfter = [At0 | After0] - -> - Before = Before0, - At = At0, - After = After0 - ; - error("post_typecheck__split_list_at_index") - ). + ( + list__split_list(Index - 1, List, Before0, AtAndAfter), + AtAndAfter = [At0 | After0] + -> + Before = Before0, + At = At0, + After = After0 + ; + error("split_list_at_index") + ). %-----------------------------------------------------------------------------% - % Work out which constructor of the type has an argument with the - % given field name. + % Work out which constructor of the type has an argument with the + % given field name. + % :- pred get_constructor_containing_field(module_info::in, (type)::in, - ctor_field_name::in, cons_id::out, int::out) is det. + ctor_field_name::in, cons_id::out, int::out) is det. get_constructor_containing_field(ModuleInfo, TermType, FieldName, - ConsId, FieldNumber) :- - ( type_to_ctor_and_args(TermType, TermTypeCtor0, _) -> - TermTypeCtor = TermTypeCtor0 - ; - error("get_constructor_containing_field: " ++ - "type_to_ctor_and_args failed") - ), - module_info_get_type_table(ModuleInfo, Types), - map__lookup(Types, TermTypeCtor, TermTypeDefn), - hlds_data__get_type_defn_body(TermTypeDefn, TermTypeBody), - ( Ctors = TermTypeBody ^ du_type_ctors -> - get_constructor_containing_field_2(Ctors, FieldName, ConsId, - FieldNumber) - ; - error("get_constructor_containing_field: not du type") - ). + ConsId, FieldNumber) :- + ( type_to_ctor_and_args(TermType, TermTypeCtor0, _) -> + TermTypeCtor = TermTypeCtor0 + ; + error("get_constructor_containing_field: " ++ + "type_to_ctor_and_args failed") + ), + module_info_get_type_table(ModuleInfo, Types), + map__lookup(Types, TermTypeCtor, TermTypeDefn), + hlds_data__get_type_defn_body(TermTypeDefn, TermTypeBody), + ( Ctors = TermTypeBody ^ du_type_ctors -> + get_constructor_containing_field_2(Ctors, FieldName, ConsId, + FieldNumber) + ; + error("get_constructor_containing_field: not du type") + ). :- pred get_constructor_containing_field_2(list(constructor)::in, - ctor_field_name::in, cons_id::out, int::out) is det. + ctor_field_name::in, cons_id::out, int::out) is det. get_constructor_containing_field_2([], _, _, _) :- - error("get_constructor_containing_field: can't find field"). + error("get_constructor_containing_field: can't find field"). get_constructor_containing_field_2([Ctor | Ctors], FieldName, - ConsId, FieldNumber) :- - Ctor = ctor(_, _, SymName, CtorArgs), - ( - get_constructor_containing_field_3(CtorArgs, - FieldName, 1, FieldNumber0) - -> - list__length(CtorArgs, Arity), - ConsId = cons(SymName, Arity), - FieldNumber = FieldNumber0 - ; - get_constructor_containing_field_2(Ctors, FieldName, - ConsId, FieldNumber) - ). + ConsId, FieldNumber) :- + Ctor = ctor(_, _, SymName, CtorArgs), + ( + get_constructor_containing_field_3(CtorArgs, + FieldName, 1, FieldNumber0) + -> + list__length(CtorArgs, Arity), + ConsId = cons(SymName, Arity), + FieldNumber = FieldNumber0 + ; + get_constructor_containing_field_2(Ctors, FieldName, + ConsId, FieldNumber) + ). :- pred get_constructor_containing_field_3(list(constructor_arg)::in, - ctor_field_name::in, int::in, int::out) is semidet. + ctor_field_name::in, int::in, int::out) is semidet. get_constructor_containing_field_3([MaybeArgFieldName - _ | CtorArgs], - FieldName, FieldNumber0, FieldNumber) :- - ( - MaybeArgFieldName = yes(ArgFieldName), - unqualify_name(ArgFieldName, UnqualFieldName), - unqualify_name(FieldName, UnqualFieldName) - -> - FieldNumber = FieldNumber0 - ; - get_constructor_containing_field_3(CtorArgs, FieldName, - FieldNumber0 + 1, FieldNumber) - ). + FieldName, FieldNumber0, FieldNumber) :- + ( + MaybeArgFieldName = yes(ArgFieldName), + unqualify_name(ArgFieldName, UnqualFieldName), + unqualify_name(FieldName, UnqualFieldName) + -> + FieldNumber = FieldNumber0 + ; + get_constructor_containing_field_3(CtorArgs, FieldName, + FieldNumber0 + 1, FieldNumber) + ). %-----------------------------------------------------------------------------% :- pred create_atomic_unification_with_nonlocals(prog_var::in, unify_rhs::in, - hlds_goal_info::in, set(prog_var)::in, list(prog_var)::in, - unify_context::in, hlds_goal::out) is det. + hlds_goal_info::in, set(prog_var)::in, list(prog_var)::in, + unify_context::in, hlds_goal::out) is det. create_atomic_unification_with_nonlocals(Var, RHS, OldGoalInfo, - RestrictNonLocals, VarsList, UnifyContext, Goal) :- - goal_info_get_context(OldGoalInfo, Context), - UnifyContext = unify_context(UnifyMainContext, UnifySubContext), - create_atomic_complicated_unification(Var, RHS, - Context, UnifyMainContext, UnifySubContext, Goal0), - Goal0 = GoalExpr0 - GoalInfo0, + RestrictNonLocals, VarsList, UnifyContext, Goal) :- + goal_info_get_context(OldGoalInfo, Context), + UnifyContext = unify_context(UnifyMainContext, UnifySubContext), + create_atomic_complicated_unification(Var, RHS, + Context, UnifyMainContext, UnifySubContext, Goal0), + Goal0 = GoalExpr0 - GoalInfo0, - % Compute the nonlocals of the goal. - set__list_to_set(VarsList, NonLocals1), - set__intersect(RestrictNonLocals, NonLocals1, NonLocals), - goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo), - Goal = GoalExpr0 - GoalInfo. + % Compute the nonlocals of the goal. + set__list_to_set(VarsList, NonLocals1), + set__intersect(RestrictNonLocals, NonLocals1, NonLocals), + goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo), + Goal = GoalExpr0 - GoalInfo. :- pred make_new_vars(list(type)::in, list(prog_var)::out, - vartypes::in, vartypes::out, prog_varset::in, prog_varset::out) is det. + vartypes::in, vartypes::out, prog_varset::in, prog_varset::out) is det. make_new_vars(Types, Vars, !VarTypes, !VarSet) :- - list__length(Types, NumVars), - varset__new_vars(!.VarSet, NumVars, Vars, !:VarSet), - map__det_insert_from_corresponding_lists(!.VarTypes, Vars, Types, - !:VarTypes). + list__length(Types, NumVars), + varset__new_vars(!.VarSet, NumVars, Vars, !:VarSet), + map__det_insert_from_corresponding_lists(!.VarTypes, Vars, Types, + !:VarTypes). :- pred make_new_var((type)::in, prog_var::out, vartypes::in, vartypes::out, - prog_varset::in, prog_varset::out) is det. + prog_varset::in, prog_varset::out) is det. make_new_var(Type, Var, !VarTypes, !VarSet) :- - varset__new_var(!.VarSet, Var, !:VarSet), - map__det_insert(!.VarTypes, Var, Type, !:VarTypes). + varset__new_var(!.VarSet, Var, !:VarSet), + map__det_insert(!.VarTypes, Var, Type, !:VarTypes). %-----------------------------------------------------------------------------% -% -% Check that every abstract type in a module has at least one definition -% in either the interface or implementation of the module. A type may -% have several definitions, e.g. some foreign definitions and a default -% Mercury definition. -% + % Check that every abstract type in a module has at least one definition + % in either the interface or implementation of the module. A type may + % have several definitions, e.g. some foreign definitions and a default + % Mercury definition. + % :- pred check_for_missing_definitions(module_info::in, - int::in, int::out, bool::in, bool::out, io::di, io::uo) is det. + int::in, int::out, bool::in, bool::out, io::di, io::uo) is det. -check_for_missing_definitions(ModuleInfo, !NumErrors, !FoundTypeError, - !IO) :- - module_info_get_type_table(ModuleInfo, TypeTable), - map.foldl3(check_for_missing_definitions_2, TypeTable, - !NumErrors, !FoundTypeError, !IO). +check_for_missing_definitions(ModuleInfo, !NumErrors, !FoundTypeError, !IO) :- + module_info_get_type_table(ModuleInfo, TypeTable), + map.foldl3(check_for_missing_definitions_2, TypeTable, + !NumErrors, !FoundTypeError, !IO). :- pred check_for_missing_definitions_2(type_ctor::in, hlds_type_defn::in, - int::in, int::out, bool::in, bool::out, io::di, io::uo) is det. + int::in, int::out, bool::in, bool::out, io::di, io::uo) is det. check_for_missing_definitions_2(TypeCtor, TypeDefn, !NumErrors, - !FoundTypeError, !IO) :- - ( - get_type_defn_status(TypeDefn, ImportStatus), - status_defined_in_this_module(ImportStatus, LocalDefn), - LocalDefn = yes, - get_type_defn_body(TypeDefn, TypeBody), - TypeBody = abstract_type(_) - -> - % We expect builtin types character, float, int and - % string to have abstract declarations with no - % definitions. The following types from the type_desc - % module also only have abstract declarations: - % - % - type_desc/0 - % - pseudo_type_desc/0 - % - type_ctor_desc/0 - % - % We do not emit an error for these types. In addition, - % we also don't bother checking for corresponding - % definitions in any of the builtin modules in the - % standard library. - % - TypeCtor = SymName - Arity, - BuiltinTypeCtors = builtin_type_ctors_with_no_hlds_type_defn, - ( - sym_name_get_module_name(SymName, ModuleName), - not any_mercury_builtin_module(ModuleName), - % - % Several of the type defined in type_desc do not - % have Mercury definitions. - % - not ModuleName = unqualified("type_desc"), - not list.member(TypeCtor, BuiltinTypeCtors) - -> - ErrorPieces = [ - words("Error: abstract"), - words("declaration for type"), - sym_name_and_arity(SymName / Arity), - words("has no corresponding"), - words("definition.") - ], - get_type_defn_context(TypeDefn, TypeContext), - write_error_pieces(TypeContext, 0, - ErrorPieces, !IO), - io.set_exit_status(1, !IO), - !:FoundTypeError = yes, - !:NumErrors = !.NumErrors + 1 - ; - true - ) - ; - true - ). + !FoundTypeError, !IO) :- + ( + get_type_defn_status(TypeDefn, ImportStatus), + status_defined_in_this_module(ImportStatus, LocalDefn), + LocalDefn = yes, + get_type_defn_body(TypeDefn, TypeBody), + TypeBody = abstract_type(_) + -> + % We expect builtin types character, float, int and + % string to have abstract declarations with no + % definitions. The following types from the type_desc + % module also only have abstract declarations: + % + % - type_desc/0 + % - pseudo_type_desc/0 + % - type_ctor_desc/0 + % + % We do not emit an error for these types. In addition, + % we also don't bother checking for corresponding + % definitions in any of the builtin modules in the + % standard library. + + TypeCtor = SymName - Arity, + BuiltinTypeCtors = builtin_type_ctors_with_no_hlds_type_defn, + ( + sym_name_get_module_name(SymName, ModuleName), + not any_mercury_builtin_module(ModuleName), + + % Several of the type defined in type_desc do not + % have Mercury definitions. + not ModuleName = unqualified("type_desc"), + not list.member(TypeCtor, BuiltinTypeCtors) + -> + ErrorPieces = [ + words("Error: abstract"), + words("declaration for type"), + sym_name_and_arity(SymName / Arity), + words("has no corresponding"), + words("definition.") + ], + get_type_defn_context(TypeDefn, TypeContext), + write_error_pieces(TypeContext, 0, + ErrorPieces, !IO), + io.set_exit_status(1, !IO), + !:FoundTypeError = yes, + !:NumErrors = !.NumErrors + 1 + ; + true + ) + ; + true + ). %-----------------------------------------------------------------------------% :- end_module post_typecheck. diff --git a/compiler/prog_io.m b/compiler/prog_io.m index a526c0221..fa10b2a9e 100644 --- a/compiler/prog_io.m +++ b/compiler/prog_io.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------e +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------e % Copyright (C) 1993-2005 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. @@ -40,7 +42,7 @@ % Implication and equivalence implemented by squirrel, who would also % like to get her hands on this file and give it a good clean up and % put it into good clean "mercury" style! - +% % Wishlist: % % 1. implement importing/exporting operators with a particular fixity @@ -74,193 +76,193 @@ :- type file_name == string. :- type dir_name == string. - % Open a source or interface file, returning `ok(FileInfo)' on - % success (where FileInfo is information about the file such as - % the file name or the directory in which it was found), or - % `error(Message)' on failure. + % Open a source or interface file, returning `ok(FileInfo)' on success + % (where FileInfo is information about the file such as the file name + % or the directory in which it was found), or `error(Message)' on failure. :- type open_file(FileInfo) == pred(maybe_error(FileInfo), io, io). :- inst open_file == (pred(out, di, uo) is det). - % prog_io__read_module(OpenFile, FileName, DefaultModuleName, - % ReturnTimestamp, Error, MaybeFileInfo, - % ActualModuleName, Messages, Program, - % MaybeModuleTimestamp) - % Reads and parses the file opened by OpenFile - % using the default module name DefaultModuleName. - % If ReturnTimestamp is `yes', attempt to return the - % modification timestamp in MaybeModuleTimestamp. - % Error is `fatal' if the file coudn't be opened, `yes' - % if a syntax error was detected, and `no' otherwise. - % MaybeFileInfo is the information about the file (usually - % the file or directory name) returned by OpenFile. - % ActualModuleName is the module name specified in the - % `:- module' declaration, if any, or the DefaultModuleName - % if there is no `:- module' declaration. - % Messages is a list of warning/error messages. - % Program is the parse tree. - :- type module_error - ---> no_module_errors % no errors - ; some_module_errors % some syntax errors - ; fatal_module_errors. % couldn't open the file + ---> no_module_errors % no errors + ; some_module_errors % some syntax errors + ; fatal_module_errors. % couldn't open the file -:- pred prog_io__read_module(open_file(FileInfo)::in(open_file), - module_name::in, bool::in, module_error::out, maybe(FileInfo)::out, - module_name::out, message_list::out, item_list::out, - maybe(io__res(timestamp))::out, io::di, io::uo) is det. + % read_module(OpenFile, FileName, DefaultModuleName, + % ReturnTimestamp, Error, MaybeFileInfo, ActualModuleName, Messages, + % Program, MaybeModuleTimestamp): + % + % Reads and parses the file opened by OpenFile using the default module + % name DefaultModuleName. If ReturnTimestamp is `yes', attempt to return + % the modification timestamp in MaybeModuleTimestamp. Error is + % `fatal_module_errors' if the file coudn't be opened, `some_module_errors' + % if a syntax error was detected, and `no_module_errors' otherwise. + % MaybeFileInfo is the information about the file (usually the file or + % directory name) returned by OpenFile. ActualModuleName is the module name + % specified in the `:- module' declaration, if any, or the + % DefaultModuleName if there is no `:- module' declaration. + % Messages is a list of warning/error messages. Program is the parse tree. + % +:- pred read_module(open_file(FileInfo)::in(open_file), + module_name::in, bool::in, module_error::out, maybe(FileInfo)::out, + module_name::out, message_list::out, item_list::out, + maybe(io__res(timestamp))::out, io::di, io::uo) is det. -:- pred prog_io__read_module_if_changed(open_file(FileInfo)::in(open_file), - module_name::in, timestamp::in, module_error::out, - maybe(FileInfo)::out, module_name::out, message_list::out, - item_list::out, maybe(io__res(timestamp))::out, io::di, io::uo) is det. +:- pred read_module_if_changed(open_file(FileInfo)::in(open_file), + module_name::in, timestamp::in, module_error::out, + maybe(FileInfo)::out, module_name::out, message_list::out, + item_list::out, maybe(io__res(timestamp))::out, io::di, io::uo) is det. - % Same as prog_io__read_module, but use intermod_directories - % instead of search_directories when searching for the file. - % Also report an error if the actual module name doesn't match - % the expected module name. -:- pred prog_io__read_opt_file(file_name::in, module_name::in, - module_error::out, message_list::out, item_list::out, io::di, io::uo) - is det. + % Same as read_module, but use intermod_directories instead of + % search_directories when searching for the file. + % Also report an error if the actual module name doesn't match + % the expected module name. + % +:- pred read_opt_file(file_name::in, module_name::in, module_error::out, + message_list::out, item_list::out, io::di, io::uo) is det. - % check_module_has_expected_name(FileName, ExpectedName, ActualName): - % Check that two module names are equal, - % and report an error if they aren't. + % check_module_has_expected_name(FileName, ExpectedName, ActualName): + % + % Check that two module names are equal, and report an error if they + % aren't. + % :- pred check_module_has_expected_name(file_name::in, module_name::in, - module_name::in, io::di, io::uo) is det. + module_name::in, io::di, io::uo) is det. - % search_for_file(Dirs, FileName, FoundFileName, IO0, IO) - % - % Search Dirs for FileName, opening the file if it is found, - % and returning the path name of the file that was found. + % search_for_file(Dirs, FileName, FoundFileName, !IO): + % + % Search Dirs for FileName, opening the file if it is found, + % and returning the path name of the file that was found. + % :- pred search_for_file(list(dir_name)::in, file_name::in, - maybe_error(file_name)::out, io::di, io::uo) is det. + maybe_error(file_name)::out, io::di, io::uo) is det. - % search_for_file_returning_dir(Dirs, FileName, FoundDirName, IO0, IO) - % - % Search Dirs for FileName, opening the file if it is found, - % and returning the name of the directory in which the file - % was found. + % search_for_file_returning_dir(Dirs, FileName, FoundDirName, !IO): + % + % Search Dirs for FileName, opening the file if it is found, and returning + % the name of the directory in which the file was found. + % :- pred search_for_file_returning_dir(list(dir_name)::in, file_name::in, - maybe_error(dir_name)::out, io::di, io::uo) is det. + maybe_error(dir_name)::out, io::di, io::uo) is det. - % search_for_module_source(Dirs, ModuleName, - % FoundSourceFileName, IO0, IO) - % - % Look for the source for ModuleName in Dirs. - % This will also search for files matching partially - % qualified versions of ModuleName. - % For example, module foo:bar:baz can be found - % in foo.bar.m, bar.baz.m or bar.m. + % search_for_module_source(Dirs, ModuleName, FoundSourceFileName, !IO): + % + % Look for the source for ModuleName in Dirs. This will also search for + % files matching partially qualified versions of ModuleName. For example, + % module foo.bar.baz can be found in foo.bar.m, bar.baz.m or bar.m. + % :- pred search_for_module_source(list(dir_name)::in, module_name::in, - maybe_error(file_name)::out, io::di, io::uo) is det. + maybe_error(file_name)::out, io::di, io::uo) is det. - % Read the first item from the given file to find the module name. + % Read the first item from the given file to find the module name. + % :- pred find_module_name(file_name::in, maybe(module_name)::out, - io::di, io::uo) is det. + io::di, io::uo) is det. - % parse_item(ModuleName, VarSet, Term, MaybeItem) - % - % parse Term. If successful, MaybeItem is bound to the parsed item, - % otherwise it is bound to an appropriate error message. - % Qualify appropriate parts of the item, with ModuleName as the - % module name. + % parse_item(ModuleName, VarSet, Term, MaybeItem): + % + % Parse Term. If successful, MaybeItem is bound to the parsed item, + % otherwise it is bound to an appropriate error message. Qualify + % appropriate parts of the item, with ModuleName as the module name. + % :- pred parse_item(module_name::in, varset::in, term::in, - maybe_item_and_context::out) is det. + maybe_item_and_context::out) is det. - % parse_decl(ModuleName, VarSet, Term, Result) - % - % parse Term as a declaration. If successful, Result is bound to the - % parsed item, otherwise it is bound to an appropriate error message. - % Qualify appropriate parts of the item, with ModuleName as the module - % name. + % parse_decl(ModuleName, VarSet, Term, Result): + % + % Parse Term as a declaration. If successful, Result is bound to the + % parsed item, otherwise it is bound to an appropriate error message. + % Qualify appropriate parts of the item, with ModuleName as the module + % name. + % :- pred parse_decl(module_name::in, varset::in, term::in, - maybe_item_and_context::out) is det. + maybe_item_and_context::out) is det. - % parse_type_defn_head(ModuleName, Head, Body, HeadResult). - % - % Check the head of a type definition for errors. + % parse_type_defn_head(ModuleName, Head, Body, HeadResult): + % + % Check the head of a type definition for errors. + % :- pred parse_type_defn_head(module_name::in, term::in, term::in, - maybe2(sym_name, list(type_param))::out) is det. + maybe2(sym_name, list(type_param))::out) is det. - % parse_type_decl_where_part_if_present(TypeSymName, Arity, - % IsSolverType, Inst, ModuleName, Term0, Term, Result): - % Checks if Term0 is a term of the form - % ` where ' - % If so, returns the `' in Term and the parsed - % `' in Result. - % If not, returns Term = Term0 and - % Result = no. - % + % parse_type_decl_where_part_if_present(TypeSymName, Arity, + % IsSolverType, Inst, ModuleName, Term0, Term, Result): + % + % Checks if Term0 is a term of the form ` where '. + % If so, returns the `' in Term and the parsed `' + % in Result. If not, returns Term = Term0 and Result = no. + % :- pred parse_type_decl_where_part_if_present(is_solver_type::in, - module_name::in, term::in, term::out, - maybe2(maybe(solver_type_details), maybe(unify_compare))::out) is det. + module_name::in, term::in, term::out, + maybe2(maybe(solver_type_details), maybe(unify_compare))::out) is det. %-----------------------------------------------------------------------------% - % A QualifiedTerm is one of - % Name(Args) - % Module:Name(Args) - % (or if Args is empty, one of - % Name - % Module:Name) - % where Module is a SymName. - % For backwards compatibility, we allow `__' - % as an alternative to `:'. +% A QualifiedTerm is one of +% Name(Args) +% Module.Name(Args) +% (or if Args is empty, one of +% Name +% Module.Name) +% where Module is a SymName. For backwards compatibility, we allow `__' +% as an alternative to `.'. - % sym_name_and_args takes a term and returns a sym_name and a list of - % argument terms. - % It fails if the input is not valid syntax for a QualifiedTerm. + % Sym_name_and_args takes a term and returns a sym_name and a list of + % argument terms. It fails if the input is not valid syntax for a + % QualifiedTerm. + % :- pred sym_name_and_args(term(T)::in, sym_name::out, list(term(T))::out) - is semidet. + is semidet. - % parse_qualified_term/4 takes a term (and also the containing - % term, and a string describing the context from which it - % was called [e.g. "clause head"]) - % and returns a sym_name and a list of argument terms. - % Returns an error on ill-formed input. - % See also parse_implicitly_qualified_term/5 (below). + % parse_qualified_term/4 takes a term (and also the containing term, + % and a string describing the context from which it was called + % [e.g. "clause head"]) and returns a sym_name and a list of argument + % terms. Returns an error on ill-formed input. See also + % parse_implicitly_qualified_term/5 (below). + % :- pred parse_qualified_term(term(T)::in, term(T)::in, string::in, - maybe_functor(T)::out) is det. + maybe_functor(T)::out) is det. - % parse_implicitly_qualified_term(DefaultModName, Term, - % ContainingTerm, Msg, Result): - % - % parse_implicitly_qualified_term/5 takes a default module name - % and a term, - % (and also the containing term, and a string describing - % the context from which it was called (e.g. "clause head"), - % and returns a sym_name and a list of argument terms. - % Returns an error on ill-formed input or a module qualifier that - % doesn't match the DefaultModName. - % - % Note: parse_qualified_term/4 is used for places where a symbol - % is _used_, in which case no default module name exists, whereas - % parse_implicitly_qualified_term/5 is used for places where a symbol - % is _defined_; in that case, there is a default module name (the - % name of the current module) -- specifying a module qualifier - % explicitly is redundant, but it is allowed, so long as the - % module qualifier specified matches the default. + % parse_implicitly_qualified_term(DefaultModName, Term, + % ContainingTerm, Msg, Result): + % + % parse_implicitly_qualified_term/5 takes a default module name and a term, + % (and also the containing term, and a string describing the context from + % which it was called (e.g. "clause head"), and returns a sym_name and + % a list of argument terms. Returns an error on ill-formed input or + % a module qualifier that doesn't match the DefaultModName. + % + % Note: parse_qualified_term/4 is used for places where a symbol is _used_, + % in which case no default module name exists, whereas + % parse_implicitly_qualified_term/5 is used for places where a symbol + % is _defined_; in that case, there is a default module name (the name + % of the current module) -- specifying a module qualifier explicitly + % is redundant, but it is allowed, so long as the module qualifier + % specified matches the default. + % :- pred parse_implicitly_qualified_term(module_name::in, term(T)::in, - term(T)::in, string::in, maybe_functor(T)::out) is det. + term(T)::in, string::in, maybe_functor(T)::out) is det. %-----------------------------------------------------------------------------% - % Replace all occurrences of inst_var(I) with - % constrained_inst_var(I, ground(shared, none)). + % Replace all occurrences of inst_var(I) with + % constrained_inst_var(I, ground(shared, none)). + % :- pred constrain_inst_vars_in_mode((mode)::in, (mode)::out) is det. - % Replace all occurrences of inst_var(I) with - % constrained_inst_var(I, Inst) where I -> Inst is in the inst_var_sub. - % If I is not in the inst_var_sub, default to ground(shared, none). + % Replace all occurrences of inst_var(I) with + % constrained_inst_var(I, Inst) where I -> Inst is in the inst_var_sub. + % If I is not in the inst_var_sub, default to ground(shared, none). + % :- pred constrain_inst_vars_in_mode(inst_var_sub::in, (mode)::in, (mode)::out) - is det. + is det. %-----------------------------------------------------------------------------% - % Check that for each constrained_inst_var all occurrences have the - % same constraint. + % Check that for each constrained_inst_var all occurrences have the + % same constraint. + % :- pred inst_var_constraints_are_consistent_in_modes(list(mode)::in) - is semidet. + is semidet. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -297,1176 +299,1096 @@ %-----------------------------------------------------------------------------% -prog_io__read_module(OpenFile, DefaultModuleName, - ReturnTimestamp, Error, FileData, ModuleName, - Messages, Items, MaybeModuleTimestamp, !IO) :- - prog_io__read_module_2(OpenFile, DefaultModuleName, - no, ReturnTimestamp, Error, FileData, ModuleName, - Messages, Items, MaybeModuleTimestamp, !IO). +read_module(OpenFile, DefaultModuleName, + ReturnTimestamp, Error, FileData, ModuleName, + Messages, Items, MaybeModuleTimestamp, !IO) :- + read_module_2(OpenFile, DefaultModuleName, + no, ReturnTimestamp, Error, FileData, ModuleName, + Messages, Items, MaybeModuleTimestamp, !IO). -prog_io__read_module_if_changed(OpenFile, DefaultModuleName, - OldTimestamp, Error, FileData, ModuleName, Messages, - Items, MaybeModuleTimestamp, !IO) :- - prog_io__read_module_2(OpenFile, DefaultModuleName, - yes(OldTimestamp), yes, Error, FileData, - ModuleName, Messages, Items, MaybeModuleTimestamp, !IO). +read_module_if_changed(OpenFile, DefaultModuleName, + OldTimestamp, Error, FileData, ModuleName, Messages, + Items, MaybeModuleTimestamp, !IO) :- + read_module_2(OpenFile, DefaultModuleName, + yes(OldTimestamp), yes, Error, FileData, + ModuleName, Messages, Items, MaybeModuleTimestamp, !IO). -prog_io__read_opt_file(FileName, DefaultModuleName, Error, Messages, Items, - !IO) :- - globals__io_lookup_accumulating_option(intermod_directories, Dirs, - !IO), - prog_io__read_module_2(search_for_file(Dirs, FileName), - DefaultModuleName, no, no, Error, _, ModuleName, Messages, - Items, _, !IO), - check_module_has_expected_name(FileName, DefaultModuleName, ModuleName, - !IO). +read_opt_file(FileName, DefaultModuleName, Error, Messages, Items, !IO) :- + globals__io_lookup_accumulating_option(intermod_directories, Dirs, !IO), + read_module_2(search_for_file(Dirs, FileName), + DefaultModuleName, no, no, Error, _, ModuleName, Messages, + Items, _, !IO), + check_module_has_expected_name(FileName, DefaultModuleName, ModuleName, + !IO). check_module_has_expected_name(FileName, ExpectedName, ActualName, !IO) :- - ( ActualName \= ExpectedName -> - mdbcomp__prim_data__sym_name_to_string(ActualName, - ActualString), - mdbcomp__prim_data__sym_name_to_string(ExpectedName, - ExpectedString), - io__write_strings([ - "Error: file `", FileName, - "' contains the wrong module.\n", - "Expected module `", ExpectedString, - "', found module `", ActualString, "'.\n" - ], !IO), - io__set_exit_status(1, !IO) - ; - true - ). + ( ActualName \= ExpectedName -> + sym_name_to_string(ActualName, ActualString), + sym_name_to_string(ExpectedName, ExpectedString), + io__write_strings([ + "Error: file `", FileName, "' contains the wrong module.\n", + "Expected module `", ExpectedString, + "', found module `", ActualString, "'.\n" + ], !IO), + io__set_exit_status(1, !IO) + ; + true + ). -% This implementation uses io__read_term to read in the program -% term at a time, and then converts those terms into clauses and -% declarations, checking for errors as it goes. -% Note that rather than using difference lists, we just -% build up the lists of items and messages in reverse order -% and then reverse them afterwards. (Using difference lists would require -% late-input modes.) + % This implementation uses io__read_term to read in the program one term + % at a time, and then converts those terms into clauses and declarations, + % checking for errors as it goes. Note that rather than using difference + % lists, we just build up the lists of items and messages in reverse order + % and then reverse them afterwards. (Using difference lists would require + % late-input modes.) + % +:- pred read_module_2(open_file(T)::in(open_file), module_name::in, + maybe(timestamp)::in, bool::in, module_error::out, maybe(T)::out, + module_name::out, message_list::out, item_list::out, + maybe(io__res(timestamp))::out, io::di, io::uo) is det. -:- pred prog_io__read_module_2(open_file(T)::in(open_file), module_name::in, - maybe(timestamp)::in, bool::in, module_error::out, maybe(T)::out, - module_name::out, message_list::out, item_list::out, - maybe(io__res(timestamp))::out, io::di, io::uo) is det. +read_module_2(OpenFile, DefaultModuleName, MaybeOldTimestamp, ReturnTimestamp, + Error, MaybeFileData, ModuleName, Messages, Items, + MaybeModuleTimestamp, !IO) :- + io__input_stream(OldInputStream, !IO), + OpenFile(OpenResult, !IO), + ( + OpenResult = ok(FileData), + MaybeFileData = yes(FileData), + ( ReturnTimestamp = yes -> + io__input_stream_name(InputStreamName, !IO), + io__file_modification_time(InputStreamName, TimestampResult, !IO), + ( + TimestampResult = ok(Timestamp), + MaybeModuleTimestamp = yes(ok(time_t_to_timestamp(Timestamp))) + ; + TimestampResult = error(IOError), + MaybeModuleTimestamp = yes(error(IOError)) + ) + ; + MaybeModuleTimestamp = no + ), + ( + MaybeOldTimestamp = yes(OldTimestamp), + MaybeModuleTimestamp = yes(ok(OldTimestamp)) + -> + % XXX Currently smart recompilation won't work + % if ModuleName \= DefaultModuleName. + % In that case, smart recompilation will be disabled + % and read_module should never be passed an old timestamp. -prog_io__read_module_2(OpenFile, DefaultModuleName, - MaybeOldTimestamp, ReturnTimestamp, Error, - MaybeFileData, ModuleName, Messages, Items, - MaybeModuleTimestamp, !IO) :- - io__input_stream(OldInputStream, !IO), - OpenFile(OpenResult, !IO), - ( - OpenResult = ok(FileData), - MaybeFileData = yes(FileData), - ( ReturnTimestamp = yes -> - io__input_stream_name(InputStreamName, !IO), - io__file_modification_time(InputStreamName, - TimestampResult, !IO), - ( - TimestampResult = ok(Timestamp), - MaybeModuleTimestamp = yes( - ok(time_t_to_timestamp(Timestamp))) - ; - TimestampResult = error(IOError), - MaybeModuleTimestamp = yes(error(IOError)) - ) - ; - MaybeModuleTimestamp = no - ), - ( - MaybeOldTimestamp = yes(OldTimestamp), - MaybeModuleTimestamp = yes(ok(OldTimestamp)) - -> - % - % XXX Currently smart recompilation won't work - % if ModuleName \= DefaultModuleName. - % In that case, smart recompilation will - % be disabled and prog_io__read_module should - % never be passed an old timestamp. - % - ModuleName = DefaultModuleName, - Items = [], - Error = no_module_errors, - Messages = [] - ; - read_all_items(DefaultModuleName, ModuleName, - Messages, Items, Error, !IO) - ), - io__set_input_stream(OldInputStream, ModuleInputStream, !IO), - io__close_input(ModuleInputStream, !IO) - ; - OpenResult = error(Message0), - io__progname_base("mercury_compile", Progname, !IO), - Message = Progname ++ ": " ++ Message0, - dummy_term(Term), - Messages = [Message - Term], - Error = fatal_module_errors, - Items = [], - ModuleName = DefaultModuleName, - MaybeFileData = no, - MaybeModuleTimestamp = no - ). + ModuleName = DefaultModuleName, + Items = [], + Error = no_module_errors, + Messages = [] + ; + read_all_items(DefaultModuleName, ModuleName, Messages, Items, + Error, !IO) + ), + io__set_input_stream(OldInputStream, ModuleInputStream, !IO), + io__close_input(ModuleInputStream, !IO) + ; + OpenResult = error(Message0), + io__progname_base("mercury_compile", Progname, !IO), + Message = Progname ++ ": " ++ Message0, + dummy_term(Term), + Messages = [Message - Term], + Error = fatal_module_errors, + Items = [], + ModuleName = DefaultModuleName, + MaybeFileData = no, + MaybeModuleTimestamp = no + ). search_for_file(Dirs, FileName, Result, !IO) :- - search_for_file_returning_dir(Dirs, FileName, Result0, !IO), - ( - Result0 = ok(Dir), - ( dir__this_directory(Dir) -> - PathName = FileName - ; - PathName = dir__make_path_name(Dir, FileName) - ), - Result = ok(PathName) - ; - Result0 = error(Message), - Result = error(Message) - ). + search_for_file_returning_dir(Dirs, FileName, Result0, !IO), + ( + Result0 = ok(Dir), + ( dir__this_directory(Dir) -> + PathName = FileName + ; + PathName = dir__make_path_name(Dir, FileName) + ), + Result = ok(PathName) + ; + Result0 = error(Message), + Result = error(Message) + ). search_for_file_returning_dir(Dirs, FileName, R, !IO) :- - search_for_file_returning_dir(Dirs, Dirs, FileName, R, !IO). + search_for_file_returning_dir(Dirs, Dirs, FileName, R, !IO). :- pred search_for_file_returning_dir(list(dir_name)::in, list(dir_name)::in, - file_name::in, maybe_error(dir_name)::out, io::di, io::uo) is det. + file_name::in, maybe_error(dir_name)::out, io::di, io::uo) is det. search_for_file_returning_dir([], AllDirs, FileName, error(Msg), !IO) :- - Msg = append_list(["cannot find `", FileName, "' in directories ", - string__join_list(", ", AllDirs)]). + Msg = append_list(["cannot find `", FileName, "' in directories ", + string__join_list(", ", AllDirs)]). search_for_file_returning_dir([Dir | Dirs], AllDirs, FileName, R, !IO) :- - ( dir__this_directory(Dir) -> - ThisFileName = FileName - ; - ThisFileName = dir__make_path_name(Dir, FileName) - ), - io__see(ThisFileName, R0, !IO), - ( R0 = ok -> - R = ok(Dir) - ; - search_for_file_returning_dir(Dirs, AllDirs, FileName, R, !IO) - ). + ( dir__this_directory(Dir) -> + ThisFileName = FileName + ; + ThisFileName = dir__make_path_name(Dir, FileName) + ), + io__see(ThisFileName, R0, !IO), + ( R0 = ok -> + R = ok(Dir) + ; + search_for_file_returning_dir(Dirs, AllDirs, FileName, R, !IO) + ). search_for_module_source(Dirs, ModuleName, MaybeFileName, !IO) :- - search_for_module_source(Dirs, ModuleName, ModuleName, MaybeFileName, - !IO). + search_for_module_source(Dirs, ModuleName, ModuleName, MaybeFileName, !IO). :- pred search_for_module_source(list(dir_name)::in, - module_name::in, module_name::in, maybe_error(file_name)::out, - io::di, io::uo) is det. + module_name::in, module_name::in, maybe_error(file_name)::out, + io::di, io::uo) is det. search_for_module_source(Dirs, ModuleName, PartialModuleName, Result, !IO) :- - module_name_to_file_name(PartialModuleName, ".m", no, FileName, !IO), - search_for_file(Dirs, FileName, Result0, !IO), - ( - Result0 = ok(_), - Result = Result0 - ; - Result0 = error(_), - ( - PartialModuleName1 = - drop_one_qualifier(PartialModuleName) - -> - search_for_module_source(Dirs, ModuleName, - PartialModuleName1, Result, !IO) - ; - sym_name_to_string(ModuleName, ModuleNameStr), - Result = error("can't find source for module `" ++ - ModuleNameStr ++ "'") - ) - ). + module_name_to_file_name(PartialModuleName, ".m", no, FileName, !IO), + search_for_file(Dirs, FileName, Result0, !IO), + ( + Result0 = ok(_), + Result = Result0 + ; + Result0 = error(_), + ( + PartialModuleName1 = drop_one_qualifier(PartialModuleName) + -> + search_for_module_source(Dirs, ModuleName, PartialModuleName1, + Result, !IO) + ; + sym_name_to_string(ModuleName, ModuleNameStr), + Result = error("can't find source for module `" ++ + ModuleNameStr ++ "'") + ) + ). :- func drop_one_qualifier(module_name) = module_name is semidet. drop_one_qualifier(qualified(ParentQual, ChildName)) = - drop_one_qualifier_2(ParentQual, ChildName). + drop_one_qualifier_2(ParentQual, ChildName). :- func drop_one_qualifier_2(module_name, string) = module_name. drop_one_qualifier_2(ParentQual, ChildName) = PartialQual :- - ( - ParentQual = unqualified(_ParentName), - PartialQual = unqualified(ChildName) - ; - ParentQual = qualified(GrandParentQual, ParentName), - PartialGrandParentQual = drop_one_qualifier_2(GrandParentQual, - ParentName), - PartialQual = qualified(PartialGrandParentQual, ChildName) - ). + ( + ParentQual = unqualified(_ParentName), + PartialQual = unqualified(ChildName) + ; + ParentQual = qualified(GrandParentQual, ParentName), + PartialGrandParentQual = drop_one_qualifier_2(GrandParentQual, + ParentName), + PartialQual = qualified(PartialGrandParentQual, ChildName) + ). %-----------------------------------------------------------------------------% - % extract the final `:- end_module' declaration if any +:- type module_end + ---> no + ; yes(module_name, prog_context). -:- type module_end ---> no ; yes(module_name, prog_context). + % Extract the final `:- end_module' declaration if any. + % +:- pred get_end_module(module_name::in, item_list::in, item_list::out, + module_end::out) is det. -:- pred get_end_module(item_list::in, module_name::in, item_list::out, - module_end::out) is det. +get_end_module(ModuleName, RevItems0, RevItems, EndModule) :- + ( + % Note: if the module name in the end_module declaration does not match + % what we expect, given the source file name, then we assume that it is + % for a nested module, and so we leave it alone. If it is not for a + % nested module, the error will be caught by make_hlds. -get_end_module(RevItems0, ModuleName, RevItems, EndModule) :- - ( - % - % Note: if the module name in the end_module declaration - % does not match what we expect, given the source file name, - % then we assume that it is for a nested module, and so - % we leave it alone. If it is not for a nested module, - % the error will be caught by make_hlds.m. - % - RevItems0 = [ - module_defn(_VarSet, end_module(ModuleName)) - Context - | RevItems1] - -> - RevItems = RevItems1, - EndModule = yes(ModuleName, Context) - ; - RevItems = RevItems0, - EndModule = no - ). + RevItems0 = [module_defn(_VarSet, end_module(ModuleName)) - Context + | RevItemsPrime] + -> + RevItems = RevItemsPrime, + EndModule = yes(ModuleName, Context) + ; + RevItems = RevItems0, + EndModule = no + ). %-----------------------------------------------------------------------------% - % check that the module starts with a :- module declaration, - % and that the end_module declaration (if any) is correct, - % and construct the final parsing result. - + % Check that the module starts with a :- module declaration, + % and that the end_module declaration (if any) is correct, + % and construct the final parsing result. + % :- pred check_end_module(module_end::in, message_list::in, message_list::out, - item_list::in, item_list::out, module_error::in, module_error::out) - is det. + item_list::in, item_list::out, module_error::in, module_error::out) + is det. check_end_module(EndModule, !Messages, !Items, !Error) :- - % - % double-check that the first item is a `:- module ModuleName' - % declaration, and remove it from the front of the item list - % - ( - !.Items = [Item | !:Items], - Item = module_defn(_VarSet, module(ModuleName1)) - _Context1 - -> - % - % check that the end module declaration (if any) - % matches the begin module declaration - % - ( - EndModule = yes(ModuleName2, Context2), - ModuleName1 \= ModuleName2 - -> - dummy_term_with_context(Context2, Term), - add_error("`:- end_module' declaration doesn't " ++ - "match `:- module' declaration", - Term, !Messages), - !:Error = some_module_errors - ; - true - ) - ; - % if there's no `:- module' declaration at this point, it is - % an internal error -- read_first_item should have inserted one - error("check_end_module: no `:- module' declaration") - ). + % Double-check that the first item is a `:- module ModuleName' declaration, + % and remove it from the front of the item list. + ( + !.Items = [Item | !:Items], + Item = module_defn(_VarSet, module(ModuleName1)) - _Context1 + -> + % Check that the end module declaration (if any) matches + % the begin module declaration. + ( + EndModule = yes(ModuleName2, Context2), + ModuleName1 \= ModuleName2 + -> + dummy_term_with_context(Context2, Term), + add_error("`:- end_module' declaration doesn't " ++ + "match `:- module' declaration", + Term, !Messages), + !:Error = some_module_errors + ; + true + ) + ; + % If there's no `:- module' declaration at this point, it is + % an internal error -- read_first_item should have inserted one. + error("check_end_module: no `:- module' declaration") + ). %-----------------------------------------------------------------------------% - % Create a dummy term. - % Used for error messages that are not associated with any - % particular term or context. + % Create a dummy term. Used for error messages that are not associated + % with any particular term or context. + % :- pred dummy_term(term::out) is det. dummy_term(Term) :- - term__context_init(Context), - dummy_term_with_context(Context, Term). - - % Create a dummy term with the specified context. - % Used for error messages that are associated with some specific - % context, but for which we don't want to print out the term - % (or for which the term isn't available to be printed out). + term__context_init(Context), + dummy_term_with_context(Context, Term). + % Create a dummy term with the specified context. + % Used for error messages that are associated with some specific + % context, but for which we don't want to print out the term + % (or for which the term isn't available to be printed out). + % :- pred dummy_term_with_context(term__context::in, term::out) is det. dummy_term_with_context(Context, Term) :- - Term = term__functor(term__atom(""), [], Context). + Term = term__functor(term__atom(""), [], Context). %-----------------------------------------------------------------------------% find_module_name(FileName, MaybeModuleName, !IO) :- - io__open_input(FileName, OpenRes, !IO), - ( - OpenRes = ok(InputStream), - io__set_input_stream(InputStream, OldInputStream, !IO), - ( string__remove_suffix(FileName, ".m", PartialFileName0) -> - PartialFileName = PartialFileName0 - ; - PartialFileName = FileName - ), - ( dir__basename(PartialFileName, BaseName0) -> - BaseName = BaseName0 - ; - BaseName = "" - ), - file_name_to_module_name(BaseName, DefaultModuleName), - read_first_item(DefaultModuleName, FileName, - ModuleName, RevMessages, _, _, _, !IO), - MaybeModuleName = yes(ModuleName), - prog_out__write_messages(list__reverse(RevMessages), !IO), - io__set_input_stream(OldInputStream, _, !IO), - io__close_input(InputStream, !IO) - ; - OpenRes = error(Error), - io__progname_base("mercury_compile", Progname, !IO), - io__write_string(Progname, !IO), - io__write_string(": error opening `", !IO), - io__write_string(FileName, !IO), - io__write_string("': ", !IO), - io__write_string(io__error_message(Error), !IO), - io__write_string(".\n", !IO), - MaybeModuleName = no - ). - - % Read a source file from standard in, first reading in - % the input term by term and then parsing those terms and producing - % a high-level representation. - % Parsing is actually a 3-stage process instead of the - % normal two-stage process: - % lexical analysis (chars -> tokens), - % parsing stage 1 (tokens -> terms), - % parsing stage 2 (terms -> items). - % The final stage produces a list of program items, each of - % which may be a declaration or a clause. - % - % We use a continuation-passing style here. + io__open_input(FileName, OpenRes, !IO), + ( + OpenRes = ok(InputStream), + io__set_input_stream(InputStream, OldInputStream, !IO), + ( string__remove_suffix(FileName, ".m", PartialFileName0) -> + PartialFileName = PartialFileName0 + ; + PartialFileName = FileName + ), + ( dir__basename(PartialFileName, BaseName0) -> + BaseName = BaseName0 + ; + BaseName = "" + ), + file_name_to_module_name(BaseName, DefaultModuleName), + read_first_item(DefaultModuleName, FileName, + ModuleName, RevMessages, _, _, _, !IO), + MaybeModuleName = yes(ModuleName), + prog_out__write_messages(list__reverse(RevMessages), !IO), + io__set_input_stream(OldInputStream, _, !IO), + io__close_input(InputStream, !IO) + ; + OpenRes = error(Error), + io__progname_base("mercury_compile", Progname, !IO), + io__write_string(Progname, !IO), + io__write_string(": error opening `", !IO), + io__write_string(FileName, !IO), + io__write_string("': ", !IO), + io__write_string(io__error_message(Error), !IO), + io__write_string(".\n", !IO), + MaybeModuleName = no + ). + % Read a source file from standard in, first reading in + % the input term by term and then parsing those terms and producing + % a high-level representation. + % Parsing is actually a 3-stage process instead of the + % normal two-stage process: + % lexical analysis (chars -> tokens), + % parsing stage 1 (tokens -> terms), + % parsing stage 2 (terms -> items). + % The final stage produces a list of program items, each of which + % may be a declaration or a clause. + % + % We use a continuation-passing style here. + % :- pred read_all_items(module_name::in, module_name::out, - message_list::out, item_list::out, module_error::out, - io__state::di, io__state::uo) is det. + message_list::out, item_list::out, module_error::out, + io__state::di, io__state::uo) is det. read_all_items(DefaultModuleName, ModuleName, Messages, Items, Error, !IO) :- - % - % read all the items (the first one is handled specially) - % - io__input_stream(Stream, !IO), - io__input_stream_name(Stream, SourceFileName, !IO), - read_first_item(DefaultModuleName, SourceFileName, ModuleName, - RevMessages0, RevItems0, MaybeSecondTerm, Error0, !IO), - ( - MaybeSecondTerm = yes(SecondTerm), - process_read_term(ModuleName, SecondTerm, - MaybeSecondItem), + % Read all the items (the first one is handled specially). + io__input_stream(Stream, !IO), + io__input_stream_name(Stream, SourceFileName, !IO), + read_first_item(DefaultModuleName, SourceFileName, ModuleName, + RevMessages0, RevItems0, MaybeSecondTerm, Error0, !IO), + ( + MaybeSecondTerm = yes(SecondTerm), + process_read_term(ModuleName, SecondTerm, MaybeSecondItem), - read_items_loop_2(MaybeSecondItem, ModuleName, SourceFileName, - RevMessages0, RevMessages1, RevItems0, RevItems1, - Error0, Error1, !IO) - ; - MaybeSecondTerm = no, - read_items_loop(ModuleName, SourceFileName, - RevMessages0, RevMessages1, RevItems0, RevItems1, - Error0, Error1, !IO) - ), + read_items_loop_2(MaybeSecondItem, ModuleName, SourceFileName, + RevMessages0, RevMessages1, RevItems0, RevItems1, + Error0, Error1, !IO) + ; + MaybeSecondTerm = no, + read_items_loop(ModuleName, SourceFileName, + RevMessages0, RevMessages1, RevItems0, RevItems1, + Error0, Error1, !IO) + ), - % - % get the end_module declaration (if any), - % check that it matches the initial module declaration (if any), - % and remove both of them from the final item list. - % - get_end_module(RevItems1, ModuleName, RevItems, EndModule), - check_end_module(EndModule, RevMessages1, RevMessages, Items0, Items, - Error1, Error), - list__reverse(RevMessages, Messages), - list__reverse(RevItems, Items0). + % Get the end_module declaration (if any), check that it matches + % the initial module declaration (if any), and remove both of them + % from the final item list. + get_end_module(ModuleName, RevItems1, RevItems, EndModule), + check_end_module(EndModule, RevMessages1, RevMessages, Items0, Items, + Error1, Error), + list__reverse(RevMessages, Messages), + list__reverse(RevItems, Items0). -% -% We need to jump through a few hoops when reading the first item, -% to allow the initial `:- module' declaration to be optional. -% The reason is that in order to parse an item, we need to know -% which module it is defined in (because we do some module -% qualification and checking of module qualifiers at parse time), -% but the initial `:- module' declaration and the declaration -% that follows it occur in different scopes, so we need to know -% what it is that we're parsing before we can parse it! -% We solve this dilemma by first parsing it in the root scope, -% and then if it turns out to not be a `:- module' declaration -% we reparse it in the default module scope. Blecchh. -% + % We need to jump through a few hoops when reading the first item, + % to allow the initial `:- module' declaration to be optional. + % The reason is that in order to parse an item, we need to know + % which module it is defined in (because we do some module + % qualification and checking of module qualifiers at parse time), + % but the initial `:- module' declaration and the declaration + % that follows it occur in different scopes, so we need to know + % what it is that we're parsing before we can parse it! + % We solve this dilemma by first parsing it in the root scope, + % and then if it turns out to not be a `:- module' declaration + % we reparse it in the default module scope. Blecchh. + % :- pred read_first_item(module_name::in, file_name::in, module_name::out, - message_list::out, item_list::out, maybe(read_term)::out, - module_error::out, io__state::di, io__state::uo) is det. + message_list::out, item_list::out, maybe(read_term)::out, + module_error::out, io__state::di, io__state::uo) is det. read_first_item(DefaultModuleName, SourceFileName, ModuleName, - Messages, Items, MaybeSecondTerm, Error, !IO) :- - globals__io_lookup_bool_option(warn_missing_module_name, - WarnMissing, !IO), - globals__io_lookup_bool_option(warn_wrong_module_name, - WarnWrong, !IO), + Messages, Items, MaybeSecondTerm, Error, !IO) :- + globals__io_lookup_bool_option(warn_missing_module_name, WarnMissing, !IO), + globals__io_lookup_bool_option(warn_wrong_module_name, WarnWrong, !IO), - % - % parse the first term, treating it as occurring - % within the scope of the special "root" module - % (so that any `:- module' declaration is taken to - % be a non-nested module unless explicitly qualified). - % - parser__read_term(SourceFileName, MaybeFirstTerm, !IO), - root_module_name(RootModuleName), - process_read_term(RootModuleName, MaybeFirstTerm, MaybeFirstItem), - ( - % - % apply and then skip `pragma source_file' decls, - % by calling ourselves recursively with the new source - % file name - % - MaybeFirstItem = ok(FirstItem, _), - FirstItem = pragma(_, source_file(NewSourceFileName)) - -> - read_first_item(DefaultModuleName, NewSourceFileName, - ModuleName, Messages, Items, MaybeSecondTerm, Error, - !IO) - ; - % - % check if the first term was a `:- module' decl - % - MaybeFirstItem = ok(FirstItem, FirstContext), - FirstItem = module_defn(_VarSet, ModuleDefn), - ModuleDefn = module(StartModuleName) - -> - % - % if so, then check that it matches the expected - % module name, and if not, report a warning - % - ( match_sym_name(StartModuleName, DefaultModuleName) -> - ModuleName = DefaultModuleName, - Messages = [] - ; - match_sym_name(DefaultModuleName, StartModuleName) - -> - ModuleName = StartModuleName, - Messages = [] - ; - mdbcomp__prim_data__sym_name_to_string(StartModuleName, - StartModuleNameString), - string__append_list(["source file `", SourceFileName, - "' contains module named `", - StartModuleNameString, "'"], - WrongModuleWarning), - maybe_add_warning(WarnWrong, MaybeFirstTerm, - FirstContext, - WrongModuleWarning, [], Messages), + % Parse the first term, treating it as occurring within the scope + % of the special "root" module (so that any `:- module' declaration + % is taken to be a non-nested module unless explicitly qualified). + parser__read_term(SourceFileName, MaybeFirstTerm, !IO), + root_module_name(RootModuleName), + process_read_term(RootModuleName, MaybeFirstTerm, MaybeFirstItem), + ( + % Apply and then skip `pragma source_file' decls, by calling ourselves + % recursively with the new source file name. + MaybeFirstItem = ok(FirstItem, _), + FirstItem = pragma(_, source_file(NewSourceFileName)) + -> + read_first_item(DefaultModuleName, NewSourceFileName, + ModuleName, Messages, Items, MaybeSecondTerm, Error, !IO) + ; + % Check if the first term was a `:- module' decl. + MaybeFirstItem = ok(FirstItem, FirstContext), + FirstItem = module_defn(_VarSet, ModuleDefn), + ModuleDefn = module(StartModuleName) + -> + % If so, then check that it matches the expected module name, + % and if not, report a warning. + ( match_sym_name(StartModuleName, DefaultModuleName) -> + ModuleName = DefaultModuleName, + Messages = [] + ; match_sym_name(DefaultModuleName, StartModuleName) -> + ModuleName = StartModuleName, + Messages = [] + ; + sym_name_to_string(StartModuleName, StartModuleNameString), + string__append_list(["source file `", SourceFileName, + "' contains module named `", + StartModuleNameString, "'"], + WrongModuleWarning), + maybe_add_warning(WarnWrong, MaybeFirstTerm, FirstContext, + WrongModuleWarning, [], Messages), - % Which one should we use here? - % We used to use the default module name - % (computed from the filename) - % but now we use the declared one. - ModuleName = StartModuleName - ), - make_module_decl(ModuleName, FirstContext, FixedFirstItem), - Items = [FixedFirstItem], - Error = no_module_errors, - MaybeSecondTerm = no - ; - % - % if the first term was not a `:- module' decl, - % then issue a warning (if warning enabled), and - % insert an implicit `:- module ModuleName' decl. - % - ( MaybeFirstItem = ok(_FirstItem, FirstContext0) -> - FirstContext = FirstContext0 - ; - term__context_init(SourceFileName, 1, FirstContext) - ), - ( WarnMissing = yes -> - dummy_term_with_context(FirstContext, FirstTerm), - add_warning("module should start with a " ++ - "`:- module' declaration", FirstTerm, [], - Messages) - ; - Messages = [] - ), - ModuleName = DefaultModuleName, - make_module_decl(ModuleName, FirstContext, FixedFirstItem), + % Which one should we use here? We used to use the default module + % name (computed from the filename) but now we use the declared + % one. + ModuleName = StartModuleName + ), + make_module_decl(ModuleName, FirstContext, FixedFirstItem), + Items = [FixedFirstItem], + Error = no_module_errors, + MaybeSecondTerm = no + ; + % If the first term was not a `:- module' decl, then issue a warning + % (if warning enabled), and insert an implicit `:- module ModuleName' + % decl. + ( MaybeFirstItem = ok(_FirstItem, FirstContext0) -> + FirstContext = FirstContext0 + ; + term__context_init(SourceFileName, 1, FirstContext) + ), + ( + WarnMissing = yes, + dummy_term_with_context(FirstContext, FirstTerm), + add_warning("module should start with a " ++ + "`:- module' declaration", FirstTerm, [], + Messages) + ; + WarnMissing = no, + Messages = [] + ), + ModuleName = DefaultModuleName, + make_module_decl(ModuleName, FirstContext, FixedFirstItem), - % - % reparse the first term, this time treating it as - % occuring within the scope of the implicit - % `:- module' decl rather than in the root module. - % - MaybeSecondTerm = yes(MaybeFirstTerm), - Items = [FixedFirstItem], - Error = no_module_errors - ). + % Reparse the first term, this time treating it as occuring within + % the scope of the implicit `:- module' decl rather than in the + % root module. + MaybeSecondTerm = yes(MaybeFirstTerm), + Items = [FixedFirstItem], + Error = no_module_errors + ). :- pred make_module_decl(module_name::in, term__context::in, - item_and_context::out) is det. + item_and_context::out) is det. make_module_decl(ModuleName, Context, Item - Context) :- - varset__init(EmptyVarSet), - ModuleDefn = module(ModuleName), - Item = module_defn(EmptyVarSet, ModuleDefn). + varset__init(EmptyVarSet), + ModuleDefn = module(ModuleName), + Item = module_defn(EmptyVarSet, ModuleDefn). :- pred maybe_add_warning(bool::in, read_term::in, term__context::in, - string::in, message_list::in, message_list::out) is det. + string::in, message_list::in, message_list::out) is det. maybe_add_warning(DoWarn, MaybeTerm, Context, Warning, !Messages) :- - ( - DoWarn = yes, - ( MaybeTerm = term(_VarSet, Term) -> - WarningTerm = Term - ; - dummy_term_with_context(Context, WarningTerm) - ), - add_warning(Warning, WarningTerm, !Messages) - ; - DoWarn = no - ). + ( + DoWarn = yes, + ( MaybeTerm = term(_VarSet, Term) -> + WarningTerm = Term + ; + dummy_term_with_context(Context, WarningTerm) + ), + add_warning(Warning, WarningTerm, !Messages) + ; + DoWarn = no + ). %-----------------------------------------------------------------------------% - % The code below was carefully optimized to run efficiently - % in NU-Prolog. We used to call read_item(MaybeItem) - - % which does all the work for a single item - - % via io__gc_call/1, which called the goal with garbage collection. - % But optimizing for NU-Prolog is no longer a big priority... + % The code below was carefully optimized to run efficiently in NU-Prolog. + % We used to call read_item(MaybeItem) - which does all the work for + % a single item - via io__gc_call/1, which called the goal with + % garbage collection. But optimizing for NU-Prolog is no longer a concern. :- pred read_items_loop(module_name::in, file_name::in, - message_list::in, message_list::out, item_list::in, item_list::out, - module_error::in,module_error::out, io__state::di, io__state::uo) - is det. + message_list::in, message_list::out, item_list::in, item_list::out, + module_error::in,module_error::out, io__state::di, io__state::uo) is det. read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, !Error, !IO) :- - read_item(ModuleName, SourceFileName, MaybeItem, !IO), - read_items_loop_2(MaybeItem, ModuleName, SourceFileName, - !Msgs, !Items, !Error, !IO). + read_item(ModuleName, SourceFileName, MaybeItem, !IO), + read_items_loop_2(MaybeItem, ModuleName, SourceFileName, !Msgs, + !Items, !Error, !IO). %-----------------------------------------------------------------------------% :- pred read_items_loop_2(maybe_item_or_eof::in, module_name::in, - file_name::in, message_list::in, message_list::out, - item_list::in, item_list::out, module_error::in, module_error::out, - io__state::di, io__state::uo) is det. - -% do a switch on the type of the next item + file_name::in, message_list::in, message_list::out, + item_list::in, item_list::out, module_error::in, module_error::out, + io__state::di, io__state::uo) is det. read_items_loop_2(eof, _ModuleName, _SourceFile, !Msgs, !Items, !Error, !IO). - % if the next item was end-of-file, then we're done. + % If the next item was end-of-file, then we're done. read_items_loop_2(syntax_error(ErrorMsg, LineNumber), ModuleName, - SourceFileName, !Msgs, !Items, _Error0, Error, !IO) :- - % if the next item was a syntax error, then insert it in - % the list of messages and continue looping - term__context_init(SourceFileName, LineNumber, Context), - dummy_term_with_context(Context, Term), - ThisError = ErrorMsg - Term, - !:Msgs = [ThisError | !.Msgs], - Error1 = some_module_errors, - read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, - Error1, Error, !IO). + SourceFileName, !Msgs, !Items, _Error0, Error, !IO) :- + % If the next item was a syntax error, then insert it in the list + % of messages and continue looping. + term__context_init(SourceFileName, LineNumber, Context), + dummy_term_with_context(Context, Term), + ThisError = ErrorMsg - Term, + !:Msgs = [ThisError | !.Msgs], + Error1 = some_module_errors, + read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, + Error1, Error, !IO). read_items_loop_2(error(M, T), ModuleName, SourceFileName, !Msgs, !Items, - _Error0, Error, !IO) :- - % if the next item was a semantic error, then insert it in - % the list of messages and continue looping - add_error(M, T, !Msgs), - Error1 = some_module_errors, - read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, - Error1, Error, !IO). + _Error0, Error, !IO) :- + % If the next item was a semantic error, then insert it in the list + % of messages and continue looping. + add_error(M, T, !Msgs), + Error1 = some_module_errors, + read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, + Error1, Error, !IO). read_items_loop_2(ok(Item0, Context), ModuleName0, SourceFileName0, - !Msgs, !Items, !Error, !IO) :- - ( Item0 = nothing(yes(Warning)) -> - Warning = item_warning(MaybeOption, Msg, Term), - ( MaybeOption = yes(Option) -> - globals__io_lookup_bool_option(Option, Warn, !IO) - ; - Warn = yes - ), - ( Warn = yes -> - add_warning(Msg, Term, !Msgs), + !Msgs, !Items, !Error, !IO) :- + ( Item0 = nothing(yes(Warning)) -> + Warning = item_warning(MaybeOption, Msg, Term), + ( + MaybeOption = yes(Option), + globals__io_lookup_bool_option(Option, Warn, !IO) + ; + MaybeOption = no, + Warn = yes + ), + ( + Warn = yes, + add_warning(Msg, Term, !Msgs), - globals__io_lookup_bool_option(halt_at_warn, Halt, - !IO), - ( Halt = yes -> - !:Error = some_module_errors - ; - true - ) - ; - true - ), - Item = nothing(no) - ; - Item = Item0 - ), + globals__io_lookup_bool_option(halt_at_warn, Halt, !IO), + ( + Halt = yes, + !:Error = some_module_errors + ; + Halt = no + ) + ; + Warn = no + ), + Item = nothing(no) + ; + Item = Item0 + ), - % if the next item was a valid item, check whether it was - % a declaration that affects the current parsing context -- - % i.e. either a `module'/`end_module' declaration or a - % `pragma source_file' declaration. If so, set the new - % parsing context according. Next, unless the item is a - % `pragma source_file' declaration, insert it into the item list. - % Then continue looping. - ( Item = pragma(_, source_file(NewSourceFileName)) -> - SourceFileName = NewSourceFileName, - ModuleName = ModuleName0 - ; Item = module_defn(_VarSet, module(NestedModuleName)) -> - ModuleName = NestedModuleName, - SourceFileName = SourceFileName0, - !:Items = [Item - Context | !.Items] - ; Item = module_defn(_VarSet, end_module(NestedModuleName)) -> - root_module_name(RootModuleName), - sym_name_get_module_name(NestedModuleName, RootModuleName, - ParentModuleName), - ModuleName = ParentModuleName, - SourceFileName = SourceFileName0, - !:Items = [Item - Context | !.Items] - ; Item = module_defn(VarSet, import(module(Modules))) -> - ImportItems = list.map( - make_pseudo_import_module_decl(VarSet, Context), - Modules), - SourceFileName = SourceFileName0, - ModuleName = ModuleName0, - list.append(ImportItems, !Items) - ; Item = module_defn(VarSet, use(module(Modules))) -> - UseItems = list.map( - make_pseudo_use_module_decl(VarSet, Context), - Modules), - SourceFileName = SourceFileName0, - ModuleName = ModuleName0, - list.append(UseItems, !Items) - ; Item = module_defn(VarSet, include_module(Modules)) -> - IncludeItems = list.map( - make_pseudo_include_module_decl(VarSet, Context), - Modules), - SourceFileName = SourceFileName0, - ModuleName = ModuleName0, - list.append(IncludeItems, !Items) - ; - SourceFileName = SourceFileName0, - ModuleName = ModuleName0, - !:Items = [Item - Context | !.Items] - ), - read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, !Error, - !IO). + % If the next item was a valid item, check whether it was + % a declaration that affects the current parsing context -- + % i.e. either a `module'/`end_module' declaration or a + % `pragma source_file' declaration. If so, set the new + % parsing context according. Next, unless the item is a + % `pragma source_file' declaration, insert it into the item list. + % Then continue looping. + ( Item = pragma(_, source_file(NewSourceFileName)) -> + SourceFileName = NewSourceFileName, + ModuleName = ModuleName0 + ; Item = module_defn(_VarSet, module(NestedModuleName)) -> + ModuleName = NestedModuleName, + SourceFileName = SourceFileName0, + !:Items = [Item - Context | !.Items] + ; Item = module_defn(_VarSet, end_module(NestedModuleName)) -> + root_module_name(RootModuleName), + sym_name_get_module_name(NestedModuleName, RootModuleName, + ParentModuleName), + ModuleName = ParentModuleName, + SourceFileName = SourceFileName0, + !:Items = [Item - Context | !.Items] + ; Item = module_defn(VarSet, import(module(Modules))) -> + ImportItems = list.map(make_pseudo_import_module_decl(VarSet, Context), + Modules), + SourceFileName = SourceFileName0, + ModuleName = ModuleName0, + list.append(ImportItems, !Items) + ; Item = module_defn(VarSet, use(module(Modules))) -> + UseItems = list.map(make_pseudo_use_module_decl(VarSet, Context), + Modules), + SourceFileName = SourceFileName0, + ModuleName = ModuleName0, + list.append(UseItems, !Items) + ; Item = module_defn(VarSet, include_module(Modules)) -> + IncludeItems = list.map( + make_pseudo_include_module_decl(VarSet, Context), + Modules), + SourceFileName = SourceFileName0, + ModuleName = ModuleName0, + list.append(IncludeItems, !Items) + ; + SourceFileName = SourceFileName0, + ModuleName = ModuleName0, + !:Items = [Item - Context | !.Items] + ), + read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, !Error, !IO). :- func make_pseudo_import_module_decl(prog_varset, prog_context, - module_specifier) = item_and_context. + module_specifier) = item_and_context. make_pseudo_import_module_decl(Varset, Context, ModuleSpecifier) = - module_defn(Varset, import(module([ModuleSpecifier]))) - Context. + module_defn(Varset, import(module([ModuleSpecifier]))) - Context. :- func make_pseudo_use_module_decl(prog_varset, prog_context, - module_specifier) = item_and_context. + module_specifier) = item_and_context. -make_pseudo_use_module_decl(Varset, Context, ModuleSpecifier) = - module_defn(Varset, use(module([ModuleSpecifier]))) - Context. +make_pseudo_use_module_decl(Varset, Context, ModuleSpecifier) = + module_defn(Varset, use(module([ModuleSpecifier]))) - Context. :- func make_pseudo_include_module_decl(prog_varset, prog_context, - module_name) = item_and_context. + module_name) = item_and_context. -make_pseudo_include_module_decl(Varset, Context, ModuleSpecifier) = - module_defn(Varset, include_module([ModuleSpecifier])) - - Context. +make_pseudo_include_module_decl(Varset, Context, ModuleSpecifier) = + module_defn(Varset, include_module([ModuleSpecifier])) - Context. %-----------------------------------------------------------------------------% - % read_item/1 reads a single item, and if it is a valid term - % parses it. - :- type maybe_item_or_eof - ---> eof - ; syntax_error(file_name, int) - ; error(string, term) - ; ok(item, term__context). + ---> eof + ; syntax_error(file_name, int) + ; error(string, term) + ; ok(item, term__context). + % Read_item/1 reads a single item, and if it is a valid term parses it. + % :- pred read_item(module_name::in, file_name::in, maybe_item_or_eof::out, - io::di, io::uo) is det. + io::di, io::uo) is det. read_item(ModuleName, SourceFileName, MaybeItem, !IO) :- - parser__read_term(SourceFileName, MaybeTerm, !IO), - process_read_term(ModuleName, MaybeTerm, MaybeItem). + parser__read_term(SourceFileName, MaybeTerm, !IO), + process_read_term(ModuleName, MaybeTerm, MaybeItem). :- pred process_read_term(module_name::in, read_term::in, - maybe_item_or_eof::out) is det. + maybe_item_or_eof::out) is det. process_read_term(_ModuleName, eof, eof). process_read_term(_ModuleName, error(ErrorMsg, LineNumber), - syntax_error(ErrorMsg, LineNumber)). + syntax_error(ErrorMsg, LineNumber)). process_read_term(ModuleName, term(VarSet, Term), MaybeItemOrEof) :- - parse_item(ModuleName, VarSet, Term, MaybeItem), - convert_item(MaybeItem, MaybeItemOrEof). + parse_item(ModuleName, VarSet, Term, MaybeItem), + convert_item(MaybeItem, MaybeItemOrEof). :- pred convert_item(maybe_item_and_context::in, maybe_item_or_eof::out) - is det. + is det. convert_item(ok(Item, Context), ok(Item, Context)). convert_item(error(M, T), error(M, T)). parse_item(ModuleName, VarSet, Term, Result) :- - ( %%% some [Decl, DeclContext] - Term = term__functor(term__atom(":-"), [Decl], _DeclContext) - -> - % It's a declaration - parse_decl(ModuleName, VarSet, Decl, Result) - ; %%% some [DCG_H, DCG_B, DCG_Context] - % It's a DCG clause - Term = term__functor(term__atom("-->"), [DCG_H, DCG_B], - DCG_Context) - -> - parse_dcg_clause(ModuleName, VarSet, DCG_H, DCG_B, - DCG_Context, Result) - ; - % It's either a fact or a rule - ( %%% some [H, B, TermContext] - Term = term__functor(term__atom(":-"), [H, B], - TermContext) - -> - % it's a rule - Head = H, - Body = B, - TheContext = TermContext - ; - % it's a fact - Head = Term, - ( - Head = term__functor(_Functor, _Args, - HeadContext) - -> - TheContext = HeadContext - ; - % term consists of just a single - % variable - the context has been lost - term__context_init(TheContext) - ), - Body = term__functor(term__atom("true"), [], TheContext) - ), - varset__coerce(VarSet, ProgVarSet), - parse_goal(Body, Body2, ProgVarSet, ProgVarSet2), - ( - Head = term__functor(term__atom("="), - [FuncHead0, FuncResult], _), - FuncHead = desugar_field_access(FuncHead0) - -> - parse_implicitly_qualified_term(ModuleName, - FuncHead, Head, "equation head", R2), - process_func_clause(R2, FuncResult, ProgVarSet2, Body2, - R3) - ; - parse_implicitly_qualified_term(ModuleName, - Head, Term, "clause head", R2), - process_pred_clause(R2, ProgVarSet2, Body2, R3) - ), - add_context(R3, TheContext, Result) - ). + ( Term = term__functor(term__atom(":-"), [Decl], _DeclContext) -> + % It's a declaration. + parse_decl(ModuleName, VarSet, Decl, Result) + ; Term = term__functor(term__atom("-->"), [DCG_H, DCG_B], DCG_Context) -> + % It's a DCG clause. + parse_dcg_clause(ModuleName, VarSet, DCG_H, DCG_B, DCG_Context, Result) + ; + % It's either a fact or a rule + ( Term = term__functor(term__atom(":-"), [H, B], TermContext) -> + % It's a rule. + Head = H, + Body = B, + TheContext = TermContext + ; + % It's a fact. + Head = Term, + ( Head = term__functor(_Functor, _Args, HeadContext) -> + TheContext = HeadContext + ; + % Term consists of just a single variable - the context + % has been lost. + term__context_init(TheContext) + ), + Body = term__functor(term__atom("true"), [], TheContext) + ), + varset__coerce(VarSet, ProgVarSet), + parse_goal(Body, Body2, ProgVarSet, ProgVarSet2), + ( + Head = term__functor(term__atom("="), [FuncHead0, FuncResult], _), + FuncHead = desugar_field_access(FuncHead0) + -> + parse_implicitly_qualified_term(ModuleName, FuncHead, Head, + "equation head", R2), + process_func_clause(R2, FuncResult, ProgVarSet2, Body2, R3) + ; + parse_implicitly_qualified_term(ModuleName, Head, Term, + "clause head", R2), + process_pred_clause(R2, ProgVarSet2, Body2, R3) + ), + add_context(R3, TheContext, Result) + ). :- pred process_pred_clause(maybe_functor::in, prog_varset::in, goal::in, - maybe1(item)::out) is det. + maybe1(item)::out) is det. process_pred_clause(ok(Name, Args0), VarSet, Body, - ok(clause(user, VarSet, predicate, Name, Args, Body))) :- - list__map(term__coerce, Args0, Args). + ok(clause(user, VarSet, predicate, Name, Args, Body))) :- + list__map(term__coerce, Args0, Args). process_pred_clause(error(ErrMessage, Term0), _, _, error(ErrMessage, Term)) :- - term__coerce(Term0, Term). + term__coerce(Term0, Term). :- pred process_func_clause(maybe_functor::in, term::in, prog_varset::in, - goal::in, maybe1(item)::out) is det. + goal::in, maybe1(item)::out) is det. process_func_clause(ok(Name, Args0), Result0, VarSet, Body, - ok(clause(user, VarSet, function, Name, Args, Body))) :- - list__append(Args0, [Result0], Args1), - list__map(term__coerce, Args1, Args). + ok(clause(user, VarSet, function, Name, Args, Body))) :- + list__append(Args0, [Result0], Args1), + list__map(term__coerce, Args1, Args). process_func_clause(error(ErrMessage, Term0), _, _, _, - error(ErrMessage, Term)) :- - term__coerce(Term0, Term). + error(ErrMessage, Term)) :- + term__coerce(Term0, Term). %-----------------------------------------------------------------------------% :- type decl_attribute - ---> purity(purity) - ; quantifier(quantifier_type, list(var)) - ; constraints(quantifier_type, term) - % the term here is the (not yet parsed) list of constraints - ; solver_type. + ---> purity(purity) + ; quantifier(quantifier_type, list(var)) + ; constraints(quantifier_type, term) + % the term here is the (not yet parsed) list of constraints + ; solver_type. :- type quantifier_type - ---> exist - ; univ. + ---> exist + ; univ. + % The term associated with each decl_attribute is the term containing + % both the attribute and the declaration that that attribute modifies; + % this term is used when printing out error messages for cases when + % attributes are used on declarations where they are not allowed. :- type decl_attrs == list(pair(decl_attribute, term)). - % the term associated with each decl_attribute - % is the term containing both the attribute and - % the declaration that that attribute modifies; - % this term is used when printing out error messages - % for cases when attributes are used on declarations - % where they are not allowed. parse_decl(ModuleName, VarSet, F, Result) :- - parse_decl_2(ModuleName, VarSet, F, [], Result). + parse_decl_2(ModuleName, VarSet, F, [], Result). - % parse_decl_2(ModuleName, VarSet, Term, Attributes, Result) - % succeeds if Term is a declaration and binds Result to a - % representation of that declaration. Attributes is a list - % of enclosing declaration attributes, in the order innermost to - % outermost. + % parse_decl_2(ModuleName, VarSet, Term, Attributes, Result): + % + % Succeeds if Term is a declaration and binds Result to a representation + % of that declaration. Attributes is a list of enclosing declaration + % attributes, in the order innermost to outermost. + % :- pred parse_decl_2(module_name::in, varset::in, term::in, decl_attrs::in, - maybe_item_and_context::out) is det. + maybe_item_and_context::out) is det. parse_decl_2(ModuleName, VarSet, F, Attributes, Result) :- - ( - F = term__functor(term__atom(Atom), Args, Context) - -> - ( - parse_decl_attribute(Atom, Args, Attribute, SubTerm) - -> - NewAttributes = [Attribute - F | Attributes], - parse_decl_2(ModuleName, VarSet, SubTerm, - NewAttributes, Result) - ; - process_decl(ModuleName, VarSet, Atom, Args, - Attributes, R) - -> - add_context(R, Context, Result) - ; - Result = error("unrecognized declaration", F) - ) - ; - Result = error("atom expected after `:-'", F) - ). + ( F = term__functor(term__atom(Atom), Args, Context) -> + ( parse_decl_attribute(Atom, Args, Attribute, SubTerm) -> + NewAttributes = [Attribute - F | Attributes], + parse_decl_2(ModuleName, VarSet, SubTerm, NewAttributes, Result) + ; process_decl(ModuleName, VarSet, Atom, Args, Attributes, R) -> + add_context(R, Context, Result) + ; + Result = error("unrecognized declaration", F) + ) + ; + Result = error("atom expected after `:-'", F) + ). - % process_decl(ModuleName, VarSet, Attributes, Atom, Args, Result) - % succeeds if Atom(Args) is a declaration and binds Result to a - % representation of that declaration. Attributes is a list - % of enclosing declaration attributes, in the order outermost to - % innermost. + % process_decl(ModuleName, VarSet, Attributes, Atom, Args, Result): + % + % Succeeds if Atom(Args) is a declaration and binds Result to a + % representation of that declaration. Attributes is a list of + % enclosing declaration attributes, in the order outermost to innermost. + % :- pred process_decl(module_name::in, varset::in, string::in, list(term)::in, - decl_attrs::in, maybe1(item)::out) is semidet. + decl_attrs::in, maybe1(item)::out) is semidet. process_decl(ModuleName, VarSet, "type", [TypeDecl], Attributes, Result) :- - parse_type_decl(ModuleName, VarSet, TypeDecl, Attributes, Result). + parse_type_decl(ModuleName, VarSet, TypeDecl, Attributes, Result). process_decl(ModuleName, VarSet, "pred", [PredDecl], Attributes, Result) :- - parse_type_decl_pred(ModuleName, VarSet, PredDecl, Attributes, Result). + parse_type_decl_pred(ModuleName, VarSet, PredDecl, Attributes, Result). process_decl(ModuleName, VarSet, "func", [FuncDecl], Attributes, Result) :- - parse_type_decl_func(ModuleName, VarSet, FuncDecl, Attributes, Result). + parse_type_decl_func(ModuleName, VarSet, FuncDecl, Attributes, Result). process_decl(ModuleName, VarSet, "mode", [ModeDecl], Attributes, Result) :- - parse_mode_decl(ModuleName, VarSet, ModeDecl, Attributes, Result). + parse_mode_decl(ModuleName, VarSet, ModeDecl, Attributes, Result). process_decl(ModuleName, VarSet, "inst", [InstDecl], Attributes, Result) :- - parse_inst_decl(ModuleName, VarSet, InstDecl, Result0), - check_no_attributes(Result0, Attributes, Result). + parse_inst_decl(ModuleName, VarSet, InstDecl, Result0), + check_no_attributes(Result0, Attributes, Result). process_decl(_ModuleName, VarSet, "import_module", [ModuleSpec], Attributes, - Result) :- - parse_symlist_decl(parse_module_specifier, make_module, make_import, - ModuleSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_module_specifier, make_module, make_import, + ModuleSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_module", [ModuleSpec], Attributes, - Result) :- - parse_symlist_decl(parse_module_specifier, make_module, make_use, - ModuleSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_module_specifier, make_module, make_use, + ModuleSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_module", [ModuleSpec], Attributes, - Result) :- - parse_symlist_decl(parse_module_specifier, make_module, make_export, - ModuleSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_module_specifier, make_module, make_export, + ModuleSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_sym", [SymSpec], Attributes, - Result) :- - parse_symlist_decl(parse_symbol_specifier, make_sym, make_import, - SymSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_symbol_specifier, make_sym, make_import, + SymSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_sym", [SymSpec], Attributes, Result) :- - parse_symlist_decl(parse_symbol_specifier, make_sym, make_use, - SymSpec, Attributes, VarSet, Result). + parse_symlist_decl(parse_symbol_specifier, make_sym, make_use, + SymSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_sym", [SymSpec], Attributes, - Result) :- - parse_symlist_decl(parse_symbol_specifier, make_sym, make_export, - SymSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_symbol_specifier, make_sym, make_export, + SymSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_pred", [PredSpec], Attributes, - Result) :- - parse_symlist_decl(parse_predicate_specifier, make_pred, make_import, - PredSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_predicate_specifier, make_pred, make_import, + PredSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_pred", [PredSpec], Attributes, - Result) :- - parse_symlist_decl(parse_predicate_specifier, make_pred, make_use, - PredSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_predicate_specifier, make_pred, make_use, + PredSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_pred", [PredSpec], Attributes, - Result) :- - parse_symlist_decl(parse_predicate_specifier, make_pred, make_export, - PredSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_predicate_specifier, make_pred, make_export, + PredSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_func", [FuncSpec], Attributes, - Result) :- - parse_symlist_decl(parse_function_specifier, make_func, make_import, - FuncSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_function_specifier, make_func, make_import, + FuncSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_func", [FuncSpec], Attributes, - Result) :- - parse_symlist_decl(parse_function_specifier, make_func, make_use, - FuncSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_function_specifier, make_func, make_use, + FuncSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_func", [FuncSpec], Attributes, - Result) :- - parse_symlist_decl(parse_function_specifier, make_func, make_export, - FuncSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_function_specifier, make_func, make_export, + FuncSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_cons", [ConsSpec], Attributes, - Result) :- - parse_symlist_decl(parse_constructor_specifier, make_cons, make_import, - ConsSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_constructor_specifier, make_cons, make_import, + ConsSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_cons", [ConsSpec], Attributes, - Result) :- - parse_symlist_decl(parse_constructor_specifier, make_cons, make_use, - ConsSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_constructor_specifier, make_cons, make_use, + ConsSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_cons", [ConsSpec], Attributes, - Result) :- - parse_symlist_decl(parse_constructor_specifier, make_cons, make_export, - ConsSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_constructor_specifier, make_cons, make_export, + ConsSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_type", [TypeSpec], Attributes, - Result) :- - parse_symlist_decl(parse_type_specifier, make_type, make_import, - TypeSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_type_specifier, make_type, make_import, + TypeSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_type", [TypeSpec], Attributes, - Result) :- - parse_symlist_decl(parse_type_specifier, make_type, make_use, - TypeSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_type_specifier, make_type, make_use, + TypeSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_type", [TypeSpec], Attributes, - Result) :- - parse_symlist_decl(parse_type_specifier, make_type, make_export, - TypeSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_type_specifier, make_type, make_export, + TypeSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_adt", [ADT_Spec], Attributes, - Result) :- - parse_symlist_decl(parse_adt_specifier, make_adt, make_import, - ADT_Spec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_adt_specifier, make_adt, make_import, + ADT_Spec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_adt", [ADT_Spec], Attributes, Result) :- - parse_symlist_decl(parse_adt_specifier, make_adt, make_use, - ADT_Spec, Attributes, VarSet, Result). + parse_symlist_decl(parse_adt_specifier, make_adt, make_use, + ADT_Spec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_adt", [ADT_Spec], Attributes, - Result) :- - parse_symlist_decl(parse_adt_specifier, make_adt, make_export, - ADT_Spec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_adt_specifier, make_adt, make_export, + ADT_Spec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_op", [OpSpec], Attributes, - Result) :- - parse_symlist_decl(parse_op_specifier, make_op, make_import, - OpSpec, Attributes, VarSet, Result). + Result) :- + parse_symlist_decl(parse_op_specifier, make_op, make_import, + OpSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_op", [OpSpec], Attributes, Result) :- - parse_symlist_decl(parse_op_specifier, make_op, make_use, - OpSpec, Attributes, VarSet, Result). + parse_symlist_decl(parse_op_specifier, make_op, make_use, + OpSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_op", [OpSpec], Attributes, Result) :- - parse_symlist_decl(parse_op_specifier, make_op, make_export, - OpSpec, Attributes, VarSet, Result). + parse_symlist_decl(parse_op_specifier, make_op, make_export, + OpSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet0, "interface", [], Attributes, Result) :- - varset__coerce(VarSet0, VarSet), - Result0 = ok(module_defn(VarSet, interface)), - check_no_attributes(Result0, Attributes, Result). + varset__coerce(VarSet0, VarSet), + Result0 = ok(module_defn(VarSet, interface)), + check_no_attributes(Result0, Attributes, Result). process_decl(_ModuleName, VarSet0, "implementation", [], Attributes, Result) :- - varset__coerce(VarSet0, VarSet), - Result0 = ok(module_defn(VarSet, implementation)), - check_no_attributes(Result0, Attributes, Result). + varset__coerce(VarSet0, VarSet), + Result0 = ok(module_defn(VarSet, implementation)), + check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, "external", Args, Attributes, Result) :- - ( - Args = [PredSpec], - MaybeBackend = no - ; - Args = [BackendArg, PredSpec], - BackendArg = term__functor(term__atom(Functor), [], _), - ( - Functor = "high_level_backend", - Backend = high_level_backend - ; - Functor = "low_level_backend", - Backend = low_level_backend - ), - MaybeBackend = yes(Backend) - ), - parse_implicitly_qualified_symbol_name_specifier(ModuleName, - PredSpec, Result0), - process_maybe1(make_external(VarSet, MaybeBackend), Result0, Result1), - check_no_attributes(Result1, Attributes, Result). + ( + Args = [PredSpec], + MaybeBackend = no + ; + Args = [BackendArg, PredSpec], + BackendArg = term__functor(term__atom(Functor), [], _), + ( + Functor = "high_level_backend", + Backend = high_level_backend + ; + Functor = "low_level_backend", + Backend = low_level_backend + ), + MaybeBackend = yes(Backend) + ), + parse_implicitly_qualified_symbol_name_specifier(ModuleName, + PredSpec, Result0), + process_maybe1(make_external(VarSet, MaybeBackend), Result0, Result1), + check_no_attributes(Result1, Attributes, Result). process_decl(DefaultModuleName, VarSet0, "module", [ModuleName], Attributes, - Result) :- - parse_module_name(DefaultModuleName, ModuleName, Result0), - ( - Result0 = ok(ModuleNameSym), - varset__coerce(VarSet0, VarSet), - Result1 = ok(module_defn(VarSet, module(ModuleNameSym))) - ; - Result0 = error(A, B), - Result1 = error(A, B) - ), - check_no_attributes(Result1, Attributes, Result). + Result) :- + parse_module_name(DefaultModuleName, ModuleName, Result0), + ( + Result0 = ok(ModuleNameSym), + varset__coerce(VarSet0, VarSet), + Result1 = ok(module_defn(VarSet, module(ModuleNameSym))) + ; + Result0 = error(A, B), + Result1 = error(A, B) + ), + check_no_attributes(Result1, Attributes, Result). process_decl(DefaultModuleName, VarSet0, "include_module", [ModuleNames], - Attributes, Result) :- - parse_list(parse_module_name(DefaultModuleName), ModuleNames, Result0), - ( - Result0 = ok(ModuleNameSyms), - varset__coerce(VarSet0, VarSet), - Result1 = ok(module_defn(VarSet, - include_module(ModuleNameSyms))) - ; - Result0 = error(A, B), - Result1 = error(A, B) - ), - check_no_attributes(Result1, Attributes, Result). + Attributes, Result) :- + parse_list(parse_module_name(DefaultModuleName), ModuleNames, Result0), + ( + Result0 = ok(ModuleNameSyms), + varset__coerce(VarSet0, VarSet), + Result1 = ok(module_defn(VarSet, include_module(ModuleNameSyms))) + ; + Result0 = error(A, B), + Result1 = error(A, B) + ), + check_no_attributes(Result1, Attributes, Result). process_decl(DefaultModuleName, VarSet0, "end_module", [ModuleName], - Attributes, Result) :- - % - % The name in an `end_module' declaration not inside the - % scope of the module being ended, so the default module name - % here is the parent of the previous default module name. - % - root_module_name(RootModuleName), - sym_name_get_module_name(DefaultModuleName, RootModuleName, - ParentOfDefaultModuleName), - parse_module_name(ParentOfDefaultModuleName, ModuleName, Result0), - ( - Result0 = ok(ModuleNameSym), - varset__coerce(VarSet0, VarSet), - Result1 = ok(module_defn(VarSet, end_module(ModuleNameSym))) - ; - Result0 = error(A, B), - Result1 = error(A, B) - ), - check_no_attributes(Result1, Attributes, Result). + Attributes, Result) :- + % The name in an `end_module' declaration not inside the scope of the + % module being ended, so the default module name here is the parent + % of the previous default module name. + + root_module_name(RootModuleName), + sym_name_get_module_name(DefaultModuleName, RootModuleName, + ParentOfDefaultModuleName), + parse_module_name(ParentOfDefaultModuleName, ModuleName, Result0), + ( + Result0 = ok(ModuleNameSym), + varset__coerce(VarSet0, VarSet), + Result1 = ok(module_defn(VarSet, end_module(ModuleNameSym))) + ; + Result0 = error(A, B), + Result1 = error(A, B) + ), + check_no_attributes(Result1, Attributes, Result). process_decl(ModuleName, VarSet, "pragma", Pragma, Attributes, Result):- - parse_pragma(ModuleName, VarSet, Pragma, Result0), - check_no_attributes(Result0, Attributes, Result). + parse_pragma(ModuleName, VarSet, Pragma, Result0), + check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, "promise", Assertion, Attributes, Result):- - parse_promise(ModuleName, true, VarSet, Assertion, Attributes, Result0), - check_no_attributes(Result0, Attributes, Result). + parse_promise(ModuleName, true, VarSet, Assertion, Attributes, Result0), + check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, "promise_exclusive", PromiseGoal, Attributes, - Result):- - parse_promise(ModuleName, exclusive, VarSet, PromiseGoal, Attributes, - Result). + Result):- + parse_promise(ModuleName, exclusive, VarSet, PromiseGoal, Attributes, + Result). process_decl(ModuleName, VarSet, "promise_exhaustive", PromiseGoal, Attributes, - Result):- - parse_promise(ModuleName, exhaustive, VarSet, PromiseGoal, Attributes, - Result). + Result):- + parse_promise(ModuleName, exhaustive, VarSet, PromiseGoal, Attributes, + Result). process_decl(ModuleName, VarSet, "promise_exclusive_exhaustive", PromiseGoal, - Attributes, Result):- - parse_promise(ModuleName, exclusive_exhaustive, VarSet, PromiseGoal, - Attributes, Result). + Attributes, Result):- + parse_promise(ModuleName, exclusive_exhaustive, VarSet, PromiseGoal, + Attributes, Result). process_decl(ModuleName, VarSet, "typeclass", Args, Attributes, Result):- - parse_typeclass(ModuleName, VarSet, Args, Result0), - check_no_attributes(Result0, Attributes, Result). + parse_typeclass(ModuleName, VarSet, Args, Result0), + check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, "instance", Args, Attributes, Result):- - parse_instance(ModuleName, VarSet, Args, Result0), - check_no_attributes(Result0, Attributes, Result). + parse_instance(ModuleName, VarSet, Args, Result0), + check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet0, "version_numbers", - [VersionNumberTerm, ModuleNameTerm, VersionNumbersTerm], - Attributes, Result) :- - parse_module_specifier(ModuleNameTerm, ModuleNameResult), - ( - VersionNumberTerm = term__functor( - term__integer(VersionNumber), [], _), - VersionNumber = version_numbers_version_number - -> - ( - ModuleNameResult = ok(ModuleName) - -> - recompilation__version__parse_version_numbers( - VersionNumbersTerm, Result0), - ( - Result0 = ok(VersionNumbers), - varset__coerce(VarSet0, VarSet), - Result1 = module_defn(VarSet, - version_numbers(ModuleName, - VersionNumbers)), - check_no_attributes(ok(Result1), - Attributes, Result) - ; - Result0 = error(A, B), - Result = error(A, B) - ) - ; - Result = error( - "invalid module name in `:- version_numbers'", - ModuleNameTerm) - ) - ; - - ( VersionNumberTerm = term__functor(_, _, Context) -> - Msg = "interface file needs to be recreated, " ++ - "the version numbers are out of date", - dummy_term_with_context(Context, DummyTerm), - Warning = item_warning(yes(warn_smart_recompilation), - Msg, DummyTerm), - Result = ok(nothing(yes(Warning))) - ; - Result = error( - "invalid version number in `:- version_numbers'", - VersionNumberTerm) - ) - ). + [VersionNumberTerm, ModuleNameTerm, VersionNumbersTerm], + Attributes, Result) :- + parse_module_specifier(ModuleNameTerm, ModuleNameResult), + ( + VersionNumberTerm = term__functor(term__integer(VersionNumber), [], _), + VersionNumber = version_numbers_version_number + -> + ( + ModuleNameResult = ok(ModuleName) + -> + recompilation__version__parse_version_numbers(VersionNumbersTerm, + Result0), + ( + Result0 = ok(VersionNumbers), + varset__coerce(VarSet0, VarSet), + Result1 = module_defn(VarSet, version_numbers(ModuleName, + VersionNumbers)), + check_no_attributes(ok(Result1), Attributes, Result) + ; + Result0 = error(A, B), + Result = error(A, B) + ) + ; + Result = error("invalid module name in `:- version_numbers'", + ModuleNameTerm) + ) + ; + ( VersionNumberTerm = term__functor(_, _, Context) -> + Msg = "interface file needs to be recreated, " ++ + "the version numbers are out of date", + dummy_term_with_context(Context, DummyTerm), + Warning = item_warning(yes(warn_smart_recompilation), + Msg, DummyTerm), + Result = ok(nothing(yes(Warning))) + ; + Result = error("invalid version number in `:- version_numbers'", + VersionNumberTerm) + ) + ). process_decl(ModuleName, VarSet, InitDecl, Args, Attributes, Result) :- - ( InitDecl = "initialise" ; InitDecl = "initialize" ), - parse_initialise_decl(ModuleName, VarSet, Args, Result0), - check_no_attributes(Result0, Attributes, Result). + ( InitDecl = "initialise" ; InitDecl = "initialize" ), + parse_initialise_decl(ModuleName, VarSet, Args, Result0), + check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, FinalDecl, Args, Attributes, Result) :- - ( FinalDecl = "finalise" ; FinalDecl = "finalize" ), - parse_finalise_decl(ModuleName, VarSet, Args, Result0), - check_no_attributes(Result0, Attributes, Result). + ( FinalDecl = "finalise" ; FinalDecl = "finalize" ), + parse_finalise_decl(ModuleName, VarSet, Args, Result0), + check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, "mutable", Args, Attributes, Result) :- - parse_mutable_decl(ModuleName, VarSet, Args, Result0), - check_no_attributes(Result0, Attributes, Result). + parse_mutable_decl(ModuleName, VarSet, Args, Result0), + check_no_attributes(Result0, Attributes, Result). :- pred parse_decl_attribute(string::in, list(term)::in, decl_attribute::out, - term::out) is semidet. + term::out) is semidet. parse_decl_attribute("impure", [Decl], purity(impure), Decl). parse_decl_attribute("semipure", [Decl], purity(semipure), Decl). parse_decl_attribute("<=", [Decl, Constraints], - constraints(univ, Constraints), Decl). + constraints(univ, Constraints), Decl). parse_decl_attribute("=>", [Decl, Constraints], - constraints(exist, Constraints), Decl). + constraints(exist, Constraints), Decl). parse_decl_attribute("some", [TVars, Decl], - quantifier(exist, TVarsList), Decl) :- - parse_list_of_vars(TVars, TVarsList). + quantifier(exist, TVarsList), Decl) :- + parse_list_of_vars(TVars, TVarsList). parse_decl_attribute("all", [TVars, Decl], - quantifier(univ, TVarsList), Decl) :- - parse_list_of_vars(TVars, TVarsList). + quantifier(univ, TVarsList), Decl) :- + parse_list_of_vars(TVars, TVarsList). parse_decl_attribute("solver", [Decl], solver_type, Decl). :- pred check_no_attributes(maybe1(T)::in, decl_attrs::in, maybe1(T)::out) - is det. + is det. check_no_attributes(Result0, Attributes, Result) :- - ( - Result0 = ok(_), - Attributes = [Attr - Term | _] - -> - attribute_description(Attr, AttrDescr), - string__append(AttrDescr, " not allowed here", Message), - Result = error(Message, Term) - ; - Result = Result0 - ). + ( + Result0 = ok(_), + Attributes = [Attr - Term | _] + -> + attribute_description(Attr, AttrDescr), + string__append(AttrDescr, " not allowed here", Message), + Result = error(Message, Term) + ; + Result = Result0 + ). :- pred attribute_description(decl_attribute::in, string::out) is det. @@ -1475,382 +1397,367 @@ attribute_description(quantifier(univ, _), "universal quantifier (`all')"). attribute_description(quantifier(exist, _), "existential quantifier (`some')"). attribute_description(constraints(univ, _), "type class constraint (`<=')"). attribute_description(constraints(exist, _), - "existentially quantified type class constraint (`=>')"). + "existentially quantified type class constraint (`=>')"). attribute_description(solver_type, "solver type specifier"). %-----------------------------------------------------------------------------% :- pred parse_promise(module_name::in, promise_type::in, varset::in, - list(term)::in, decl_attrs::in, maybe1(item)::out) is semidet. + list(term)::in, decl_attrs::in, maybe1(item)::out) is semidet. parse_promise(ModuleName, PromiseType, VarSet, [Term], Attributes, Result) :- - varset__coerce(VarSet, ProgVarSet0), - parse_goal(Term, Goal0, ProgVarSet0, ProgVarSet), + varset__coerce(VarSet, ProgVarSet0), + parse_goal(Term, Goal0, ProgVarSet0, ProgVarSet), - % get universally quantified variables - ( PromiseType = true -> - ( Goal0 = all(UnivVars0, AllGoal) - _Context -> - UnivVars0 = UnivVars, - Goal = AllGoal - ; - UnivVars = [], - Goal = Goal0 - ) - ; - get_quant_vars(univ, ModuleName, Attributes, _, [], UnivVars0), - list__map(term__coerce_var, UnivVars0, UnivVars), - Goal0 = Goal - ), - - Result = ok(promise(PromiseType, Goal, ProgVarSet, UnivVars)). + % Get universally quantified variables. + ( PromiseType = true -> + ( Goal0 = all(UnivVars0, AllGoal) - _Context -> + UnivVars0 = UnivVars, + Goal = AllGoal + ; + UnivVars = [], + Goal = Goal0 + ) + ; + get_quant_vars(univ, ModuleName, Attributes, _, [], UnivVars0), + list__map(term__coerce_var, UnivVars0, UnivVars), + Goal0 = Goal + ), + Result = ok(promise(PromiseType, Goal, ProgVarSet, UnivVars)). %-----------------------------------------------------------------------------% :- pred parse_type_decl(module_name::in, varset::in, term::in, decl_attrs::in, - maybe1(item)::out) is det. + maybe1(item)::out) is det. parse_type_decl(ModuleName, VarSet, TypeDecl, Attributes, Result) :- - ( - TypeDecl = term__functor(term__atom(Name), Args, _), - parse_type_decl_type(ModuleName, Name, Args, Attributes, - Cond, R) - -> - R1 = R, - Cond1 = Cond - ; - process_abstract_type(ModuleName, TypeDecl, Attributes, R1), - Cond1 = true - ), - % We should check the condition for errors - % (don't bother at the moment, since we ignore - % conditions anyhow :-). - process_maybe1(make_type_defn(VarSet, Cond1), R1, Result). + ( + TypeDecl = term__functor(term__atom(Name), Args, _), + parse_type_decl_type(ModuleName, Name, Args, Attributes, Cond, R) + -> + R1 = R, + Cond1 = Cond + ; + process_abstract_type(ModuleName, TypeDecl, Attributes, R1), + Cond1 = true + ), + % We should check the condition for errors (don't bother at the moment, + % since we ignore conditions anyhow :-). + process_maybe1(make_type_defn(VarSet, Cond1), R1, Result). :- pred make_type_defn(varset::in, condition::in, processed_type_body::in, - item::out) is det. + item::out) is det. make_type_defn(VarSet0, Cond, processed_type_body(Name, Args, TypeDefn), - type_defn(VarSet, Name, Args, TypeDefn, Cond)) :- - varset__coerce(VarSet0, VarSet). + type_defn(VarSet, Name, Args, TypeDefn, Cond)) :- + varset__coerce(VarSet0, VarSet). :- pred make_external(varset::in, maybe(backend)::in, sym_name_specifier::in, - item::out) is det. + item::out) is det. make_external(VarSet0, MaybeBackend, SymSpec, - module_defn(VarSet, external(MaybeBackend, SymSpec))) :- - varset__coerce(VarSet0, VarSet). + module_defn(VarSet, external(MaybeBackend, SymSpec))) :- + varset__coerce(VarSet0, VarSet). :- pred get_is_solver_type(is_solver_type::out, - decl_attrs::in, decl_attrs::out) is det. + decl_attrs::in, decl_attrs::out) is det. get_is_solver_type(IsSolverType, !Attributes) :- - ( !.Attributes = [solver_type - _ | !:Attributes] -> - IsSolverType = solver_type - ; - IsSolverType = non_solver_type - ). + ( !.Attributes = [solver_type - _ | !:Attributes] -> + IsSolverType = solver_type + ; + IsSolverType = non_solver_type + ). %-----------------------------------------------------------------------------% - % add a warning message to the list of messages - + % Add a warning message to the list of messages. + % :- pred add_warning(string::in, term::in, message_list::in, message_list::out) - is det. + is det. add_warning(Warning, Term, Msgs, [Msg - Term | Msgs]) :- - string__append("Warning: ", Warning, Msg). - - % add an error message to the list of messages + string__append("Warning: ", Warning, Msg). + % Add an error message to the list of messages. + % :- pred add_error(string::in, term::in, message_list::in, message_list::out) - is det. + is det. add_error(Error, Term, Msgs, [Msg - Term | Msgs]) :- - string__append("Error: ", Error, Msg). + string__append("Error: ", Error, Msg). %-----------------------------------------------------------------------------% - % parse_type_decl_type(Term, Condition, Result) succeeds - % if Term is a "type" type declaration, and binds Condition - % to the condition for that declaration (if any), and Result to - % a representation of the declaration. + % parse_type_decl_type(Term, Condition, Result) succeeds if Term is + % a "type" type declaration, and binds Condition to the condition for + % that declaration (if any), and Result to a representation of the + % declaration. + % :- pred parse_type_decl_type(module_name::in, string::in, list(term)::in, - decl_attrs::in, condition::out, maybe1(processed_type_body)::out) - is semidet. + decl_attrs::in, condition::out, maybe1(processed_type_body)::out) + is semidet. parse_type_decl_type(ModuleName, "--->", [H, B], Attributes0, Condition, - Result) :- - get_condition(B, Body, Condition), - get_is_solver_type(IsSolverType, Attributes0, Attributes), - ( - IsSolverType = solver_type, - Result = error("a solver type cannot have data constructors", - H) - ; - IsSolverType = non_solver_type, - du_type_rhs_ctors_and_where_terms(Body, CtorsTerm, - MaybeWhereTerm), - CtorsResult = convert_constructors(ModuleName, CtorsTerm), - ( - CtorsResult = error(String, Term), - Result = error(String, Term) - ; - CtorsResult = ok(Ctors), - WhereResult = parse_type_decl_where_term( - non_solver_type, ModuleName, MaybeWhereTerm), - ( - WhereResult = error(String, Term), - Result = error(String, Term) - ; - % The code to process `where' - % attributes will return an error - % result if solver attributes are - % given for a non-solver type. - % Because this is a du type, if the - % unification with WhereResult - % succeeds then _NoSolverTypeDetails - % is guaranteed to be `no'. - WhereResult = ok(_NoSolverTypeDetails, - MaybeUserEqComp), - process_du_type(ModuleName, H, Body, Ctors, - MaybeUserEqComp, Result0), - check_no_attributes(Result0, Attributes, - Result) - ) - ) - ). + Result) :- + get_condition(B, Body, Condition), + get_is_solver_type(IsSolverType, Attributes0, Attributes), + ( + IsSolverType = solver_type, + Result = error("a solver type cannot have data constructors", H) + ; + IsSolverType = non_solver_type, + du_type_rhs_ctors_and_where_terms(Body, CtorsTerm, + MaybeWhereTerm), + CtorsResult = convert_constructors(ModuleName, CtorsTerm), + ( + CtorsResult = error(String, Term), + Result = error(String, Term) + ; + CtorsResult = ok(Ctors), + WhereResult = parse_type_decl_where_term(non_solver_type, + ModuleName, MaybeWhereTerm), + ( + WhereResult = error(String, Term), + Result = error(String, Term) + ; + % The code to process `where' attributes will return an error + % result if solver attributes are given for a non-solver type. + % Because this is a du type, if the unification with + % WhereResult succeeds then _NoSolverTypeDetails is + % guaranteed to be `no'. + WhereResult = ok(_NoSolverTypeDetails, MaybeUserEqComp), + process_du_type(ModuleName, H, Body, Ctors, MaybeUserEqComp, + Result0), + check_no_attributes(Result0, Attributes, Result) + ) + ) + ). parse_type_decl_type(ModuleName, "==", [H, B], Attributes, Condition, R) :- - get_condition(B, Body, Condition), - process_eqv_type(ModuleName, H, Body, R0), - check_no_attributes(R0, Attributes, R). + get_condition(B, Body, Condition), + process_eqv_type(ModuleName, H, Body, R0), + check_no_attributes(R0, Attributes, R). -parse_type_decl_type(ModuleName, "where", [H, B], Attributes0, Condition, - R) :- - get_condition(B, Body, Condition), - get_is_solver_type(IsSolverType, Attributes0, Attributes), - ( - IsSolverType = non_solver_type, - R = error("only solver types can be defined " ++ - "by a `where' block alone", H) - ; - IsSolverType = solver_type, - R0 = parse_type_decl_where_term(solver_type, ModuleName, - yes(Body)), - ( - R0 = error(String, Term), - R = error(String, Term) - ; - R0 = ok(MaybeSolverTypeDetails, MaybeUserEqComp), - process_solver_type(ModuleName, H, - MaybeSolverTypeDetails, MaybeUserEqComp, R1), - check_no_attributes(R1, Attributes, R) - ) - ). +parse_type_decl_type(ModuleName, "where", [H, B], Attributes0, Condition, R) :- + get_condition(B, Body, Condition), + get_is_solver_type(IsSolverType, Attributes0, Attributes), + ( + IsSolverType = non_solver_type, + R = error("only solver types can be defined " ++ + "by a `where' block alone", H) + ; + IsSolverType = solver_type, + R0 = parse_type_decl_where_term(solver_type, ModuleName, yes(Body)), + ( + R0 = error(String, Term), + R = error(String, Term) + ; + R0 = ok(MaybeSolverTypeDetails, MaybeUserEqComp), + process_solver_type(ModuleName, H, + MaybeSolverTypeDetails, MaybeUserEqComp, R1), + check_no_attributes(R1, Attributes, R) + ) + ). :- pred du_type_rhs_ctors_and_where_terms(term::in, - term::out, maybe(term)::out) is det. + term::out, maybe(term)::out) is det. du_type_rhs_ctors_and_where_terms(Term, CtorsTerm, MaybeWhereTerm) :- - ( - Term = term__functor(term__atom("where"), - [CtorsTerm0, WhereTerm], _Context) - -> - CtorsTerm = CtorsTerm0, - MaybeWhereTerm = yes(WhereTerm) - ; - CtorsTerm = Term, - MaybeWhereTerm = no - ). + ( + Term = term__functor(term__atom("where"), [CtorsTerm0, WhereTerm], + _Context) + -> + CtorsTerm = CtorsTerm0, + MaybeWhereTerm = yes(WhereTerm) + ; + CtorsTerm = Term, + MaybeWhereTerm = no + ). %-----------------------------------------------------------------------------% - % parse_type_decl_pred(ModuleName, VarSet, Pred, Attributes, Result) - % succeeds if Pred is a predicate type declaration, and binds Result - % to a representation of the declaration. + % parse_type_decl_pred(ModuleName, VarSet, Pred, Attributes, Result) + % succeeds if Pred is a predicate type declaration, and binds Result + % to a representation of the declaration. + % :- pred parse_type_decl_pred(module_name::in, varset::in, term::in, - decl_attrs::in, maybe1(item)::out) is det. + decl_attrs::in, maybe1(item)::out) is det. parse_type_decl_pred(ModuleName, VarSet, Pred, Attributes, R) :- - get_condition(Pred, Body, Condition), - get_determinism(Body, Body2, MaybeDeterminism), - get_with_inst(Body2, Body3, WithInst), - get_with_type(Body3, Body4, WithTypeResult), - ( - WithTypeResult = ok(WithType), - process_type_decl_pred_or_func(predicate, ModuleName, - WithType, WithInst, MaybeDeterminism, VarSet, Body4, - Condition, Attributes, R) - ; - WithTypeResult = error(Msg, ErrorTerm), - R = error(Msg, ErrorTerm) - ). + get_condition(Pred, Body, Condition), + get_determinism(Body, Body2, MaybeDeterminism), + get_with_inst(Body2, Body3, WithInst), + get_with_type(Body3, Body4, WithTypeResult), + ( + WithTypeResult = ok(WithType), + process_type_decl_pred_or_func(predicate, ModuleName, WithType, + WithInst, MaybeDeterminism, VarSet, Body4, Condition, Attributes, + R) + ; + WithTypeResult = error(Msg, ErrorTerm), + R = error(Msg, ErrorTerm) + ). :- pred process_type_decl_pred_or_func(pred_or_func::in, module_name::in, - maybe(type)::in, maybe1(maybe(inst))::in, - maybe1(maybe(determinism))::in, varset::in, term::in, condition::in, - decl_attrs::in, maybe1(item)::out) is det. + maybe(type)::in, maybe1(maybe(inst))::in, + maybe1(maybe(determinism))::in, varset::in, term::in, condition::in, + decl_attrs::in, maybe1(item)::out) is det. process_type_decl_pred_or_func(PredOrFunc, ModuleName, WithType, WithInst0, - MaybeDeterminism0, VarSet, Body, Condition, Attributes, R) :- - ( - MaybeDeterminism0 = ok(MaybeDeterminism), - ( - WithInst0 = ok(WithInst), - ( MaybeDeterminism = yes(_), WithInst = yes(_) -> - R = error("`with_inst` and determinism " ++ - "both specified", Body) - ; WithInst = yes(_), WithType = no -> - R = error("`with_inst` specified without " ++ - "`with_type`", Body) - ; - ( - % Function declarations with - % `with_type` annotations have the - % same form as predicate declarations. - PredOrFunc = function, - WithType = no - -> - process_func(ModuleName, VarSet, Body, - Condition, MaybeDeterminism, - Attributes, R) - ; - process_pred_or_func(PredOrFunc, - ModuleName, VarSet, Body, - Condition, WithType, WithInst, - MaybeDeterminism, Attributes, - R) - ) - ) - ; - WithInst0 = error(E, T), - R = error(E, T) - ) - ; - MaybeDeterminism0 = error(E, T), - R = error(E, T) - ). + MaybeDeterminism0, VarSet, Body, Condition, Attributes, R) :- + ( + MaybeDeterminism0 = ok(MaybeDeterminism), + ( + WithInst0 = ok(WithInst), + ( MaybeDeterminism = yes(_), WithInst = yes(_) -> + R = error("`with_inst` and determinism " ++ + "both specified", Body) + ; WithInst = yes(_), WithType = no -> + R = error("`with_inst` specified without " ++ + "`with_type`", Body) + ; + ( + % Function declarations with `with_type` annotations + % have the same form as predicate declarations. + PredOrFunc = function, + WithType = no + -> + process_func(ModuleName, VarSet, Body, Condition, + MaybeDeterminism, Attributes, R) + ; + process_pred_or_func(PredOrFunc, ModuleName, VarSet, Body, + Condition, WithType, WithInst, MaybeDeterminism, + Attributes, R) + ) + ) + ; + WithInst0 = error(E, T), + R = error(E, T) + ) + ; + MaybeDeterminism0 = error(E, T), + R = error(E, T) + ). %-----------------------------------------------------------------------------% - % parse_type_decl_func(ModuleName, Varset, Func, Attributes, Result) - % succeeds if Func is a function type declaration, and binds Result to - % a representation of the declaration. + % parse_type_decl_func(ModuleName, Varset, Func, Attributes, Result) + % succeeds if Func is a function type declaration, and binds Result to + % a representation of the declaration. + % :- pred parse_type_decl_func(module_name::in, varset::in, term::in, - decl_attrs::in, maybe1(item)::out) is det. + decl_attrs::in, maybe1(item)::out) is det. parse_type_decl_func(ModuleName, VarSet, Func, Attributes, R) :- - get_condition(Func, Body, Condition), - get_determinism(Body, Body2, MaybeDeterminism), - get_with_inst(Body2, Body3, WithInst), - get_with_type(Body3, Body4, WithTypeResult), - ( - WithTypeResult = ok(WithType), - process_type_decl_pred_or_func(function, ModuleName, - WithType, WithInst, MaybeDeterminism, VarSet, Body4, - Condition, Attributes, R) - ; - WithTypeResult = error(Msg, ErrorTerm), - R = error(Msg, ErrorTerm) - ). + get_condition(Func, Body, Condition), + get_determinism(Body, Body2, MaybeDeterminism), + get_with_inst(Body2, Body3, WithInst), + get_with_type(Body3, Body4, WithTypeResult), + ( + WithTypeResult = ok(WithType), + process_type_decl_pred_or_func(function, ModuleName, + WithType, WithInst, MaybeDeterminism, VarSet, Body4, + Condition, Attributes, R) + ; + WithTypeResult = error(Msg, ErrorTerm), + R = error(Msg, ErrorTerm) + ). %-----------------------------------------------------------------------------% - % parse_mode_decl_pred(ModuleName, Pred, Condition, Result) succeeds - % if Pred is a predicate mode declaration, and binds Condition to the - % condition for that declaration (if any), and Result to a - % representation of the declaration. - % + % parse_mode_decl_pred(ModuleName, Pred, Condition, Result) succeeds + % if Pred is a predicate mode declaration, and binds Condition to the + % condition for that declaration (if any), and Result to a + % representation of the declaration. + % :- pred parse_mode_decl_pred(module_name::in, varset::in, term::in, - decl_attrs::in, maybe1(item)::out) is det. + decl_attrs::in, maybe1(item)::out) is det. parse_mode_decl_pred(ModuleName, VarSet, Pred, Attributes, Result) :- - get_condition(Pred, Body, Condition), - get_determinism(Body, Body2, MaybeDeterminism0), - get_with_inst(Body2, Body3, WithInst0), - ( - MaybeDeterminism0 = ok(MaybeDeterminism), - ( - WithInst0 = ok(WithInst), - ( - MaybeDeterminism = yes(_), - WithInst = yes(_) - -> - Result = error("`with_inst` and " ++ - "determinism both specified", Body) - ; - process_mode(ModuleName, VarSet, Body3, - Condition, Attributes, WithInst, - MaybeDeterminism, Result) - ) - ; - WithInst0 = error(E, T), - Result = error(E, T) - ) - ; - MaybeDeterminism0 = error(E, T), - Result = error(E, T) - ). + get_condition(Pred, Body, Condition), + get_determinism(Body, Body2, MaybeDeterminism0), + get_with_inst(Body2, Body3, WithInst0), + ( + MaybeDeterminism0 = ok(MaybeDeterminism), + ( + WithInst0 = ok(WithInst), + ( + MaybeDeterminism = yes(_), + WithInst = yes(_) + -> + Result = error("`with_inst` and " ++ + "determinism both specified", Body) + ; + process_mode(ModuleName, VarSet, Body3, Condition, Attributes, + WithInst, MaybeDeterminism, Result) + ) + ; + WithInst0 = error(E, T), + Result = error(E, T) + ) + ; + MaybeDeterminism0 = error(E, T), + Result = error(E, T) + ). %-----------------------------------------------------------------------------% :- pred parse_initialise_decl(module_name::in, varset::in, list(term)::in, - maybe1(item)::out) is semidet. + maybe1(item)::out) is semidet. parse_initialise_decl(_ModuleName, _VarSet, [Term], Result) :- - parse_symbol_name_specifier(Term, MaybeSymNameSpecifier), - ( - MaybeSymNameSpecifier = error(ErrMsg, Trm), - Result = error(ErrMsg, Trm) - ; - MaybeSymNameSpecifier = ok(SymNameSpecifier), - ( - SymNameSpecifier = name(_), - Result = error("`initialise' " ++ - "declaration requires arity", Term) - ; - SymNameSpecifier = name_arity(SymName, Arity), - ( - ( Arity = 2 ; Arity = 0 ) - -> - Result = ok(initialise(user, SymName, Arity)) - ; - Result = error("`initialise' " ++ - "declaration specifies a predicate " ++ - "whose arity is not zero or two", Term) - ) - ) - ). + parse_symbol_name_specifier(Term, MaybeSymNameSpecifier), + ( + MaybeSymNameSpecifier = error(ErrMsg, Trm), + Result = error(ErrMsg, Trm) + ; + MaybeSymNameSpecifier = ok(SymNameSpecifier), + ( + SymNameSpecifier = name(_), + Result = error("`initialise' declaration requires arity", Term) + ; + SymNameSpecifier = name_arity(SymName, Arity), + ( + ( Arity = 2 ; Arity = 0 ) + -> + Result = ok(initialise(user, SymName, Arity)) + ; + Result = error("`initialise' " ++ + "declaration specifies a predicate " ++ + "whose arity is not zero or two", Term) + ) + ) + ). %-----------------------------------------------------------------------------% :- pred parse_finalise_decl(module_name::in, varset::in, list(term)::in, - maybe1(item)::out) is semidet. + maybe1(item)::out) is semidet. parse_finalise_decl(_ModuleName, _VarSet, [Term], Result) :- - parse_symbol_name_specifier(Term, MaybeSymNameSpecifier), - ( - MaybeSymNameSpecifier = error(ErrMsg, Trm), - Result = error(ErrMsg, Trm) - ; - MaybeSymNameSpecifier = ok(SymNameSpecifier), - ( - SymNameSpecifier = name(_), - Result = error("`finalise' " ++ - "declaration requires arity", Term) - ; - SymNameSpecifier = name_arity(SymName, Arity), - ( - ( Arity = 2 ; Arity = 0) - -> - Result = ok(finalise(user, SymName, Arity)) - ; - Result = error("`finalise' " ++ - "declaration specifies a predicate " ++ - "whose arity is not zero or two", Term) - ) - ) - ). + parse_symbol_name_specifier(Term, MaybeSymNameSpecifier), + ( + MaybeSymNameSpecifier = error(ErrMsg, Trm), + Result = error(ErrMsg, Trm) + ; + MaybeSymNameSpecifier = ok(SymNameSpecifier), + ( + SymNameSpecifier = name(_), + Result = error("`finalise' declaration requires arity", Term) + ; + SymNameSpecifier = name_arity(SymName, Arity), + ( + ( Arity = 2 ; Arity = 0) + -> + Result = ok(finalise(user, SymName, Arity)) + ; + Result = error("`finalise' " ++ + "declaration specifies a predicate " ++ + "whose arity is not zero or two", Term) + ) + ) + ). %-----------------------------------------------------------------------------% @@ -1867,16 +1774,16 @@ parse_finalise_decl(_ModuleName, _VarSet, [Term], Result) :- % % :- semipure pred get_counter(int::out(ground)) is det. % :- pragma foreign_proc("C", -% get_counter(X::out(ground)), -% [promise_semipure, will_not_call_mercury, thread_safe], -% "X = mutable_counter;"). +% get_counter(X::out(ground)), +% [promise_semipure, will_not_call_mercury, thread_safe], +% "X = mutable_counter;"). % % :- impure pred set_counter(int::in(ground)) is det. % :- pragma foreign_proc("C", -% set_counter(X::in(ground)), -% [will_not_call_mercury, thread_safe], -% "MR_trail_current_value(&mutable_counter); -% mutable_counter = X;"). +% set_counter(X::in(ground)), +% [will_not_call_mercury, thread_safe], +% "MR_trail_current_value(&mutable_counter); +% mutable_counter = X;"). % % :- pragma foreign_decl("C", "extern MR_Word mutable_counter;"). % :- pragma foreign_code("C", "MR_Word mutable_counter;"); @@ -1886,7 +1793,7 @@ parse_finalise_decl(_ModuleName, _VarSet, [Term], Result) :- % :- impure pred initialise_mutable_counter(io::di, io::uo) is det. % % initialise_mutable_counter(!IO) :- -% impure set_counter(0). +% impure set_counter(0). % % If the `thread_safe' attribute is specified in % then foreign_procs are created that have the thread_safe attribute @@ -1895,1100 +1802,1036 @@ parse_finalise_decl(_ModuleName, _VarSet, [Term], Result) :- % is omitted. :- pred parse_mutable_decl(module_name::in, varset::in, list(term)::in, - maybe1(item)::out) is semidet. + maybe1(item)::out) is semidet. parse_mutable_decl(_ModuleName, _VarSet, Terms, Result) :- - Terms = [NameTerm, TypeTerm, ValueTerm, InstTerm | OptMutAttrsTerm], - parse_mutable_name(NameTerm, NameResult), - parse_mutable_type(TypeTerm, TypeResult), - term__coerce(ValueTerm, Value), - parse_mutable_inst(InstTerm, InstResult), - ( - OptMutAttrsTerm = [], - MutAttrsResult = ok(default_mutable_attributes) - ; - OptMutAttrsTerm = [MutAttrsTerm], - parse_mutable_attrs(MutAttrsTerm, MutAttrsResult) - ), - ( - NameResult = ok(Name), - TypeResult = ok(Type), - InstResult = ok(Inst), - MutAttrsResult = ok(MutAttrs) - -> - Result = ok(mutable(Name, Type, Value, Inst, MutAttrs)) - ; - NameResult = error(Msg, Term) - -> - Result = error(Msg, Term) - ; - TypeResult = error(Msg, Term) - -> - Result = error(Msg, Term) - ; - InstResult = error(Msg, Term) - -> - Result = error(Msg, Term) - ; - MutAttrsResult = error(Msg, Term) - -> - Result = error(Msg, Term) - ; - error("prog_io.parse_mutable_decl: shouldn't be here!") - ). - + Terms = [NameTerm, TypeTerm, ValueTerm, InstTerm | OptMutAttrsTerm], + parse_mutable_name(NameTerm, NameResult), + parse_mutable_type(TypeTerm, TypeResult), + term__coerce(ValueTerm, Value), + parse_mutable_inst(InstTerm, InstResult), + ( + OptMutAttrsTerm = [], + MutAttrsResult = ok(default_mutable_attributes) + ; + OptMutAttrsTerm = [MutAttrsTerm], + parse_mutable_attrs(MutAttrsTerm, MutAttrsResult) + ), + ( + NameResult = ok(Name), + TypeResult = ok(Type), + InstResult = ok(Inst), + MutAttrsResult = ok(MutAttrs) + -> + Result = ok(mutable(Name, Type, Value, Inst, MutAttrs)) + ; + NameResult = error(Msg, Term) + -> + Result = error(Msg, Term) + ; + TypeResult = error(Msg, Term) + -> + Result = error(Msg, Term) + ; + InstResult = error(Msg, Term) + -> + Result = error(Msg, Term) + ; + MutAttrsResult = error(Msg, Term) + -> + Result = error(Msg, Term) + ; + error("prog_io.parse_mutable_decl: shouldn't be here!") + ). :- pred parse_mutable_name(term::in, maybe1(string)::out) is det. parse_mutable_name(NameTerm, NameResult) :- - ( - NameTerm = term__functor(atom(Name), [], _) - -> - NameResult = ok(Name) - ; - NameResult = error("invalid mutable name", NameTerm) - ). - + ( NameTerm = term__functor(atom(Name), [], _) -> + NameResult = ok(Name) + ; + NameResult = error("invalid mutable name", NameTerm) + ). :- pred parse_mutable_type(term::in, maybe1(type)::out) is det. parse_mutable_type(TypeTerm, TypeResult) :- - ( - term__contains_var(TypeTerm, _) - -> - TypeResult = error("the type in a mutable declaration " ++ - "cannot contain variables", TypeTerm) - ; - parse_type(TypeTerm, TypeResult) - ). - + ( term__contains_var(TypeTerm, _) -> + TypeResult = error("the type in a mutable declaration " ++ + "cannot contain variables", TypeTerm) + ; + parse_type(TypeTerm, TypeResult) + ). :- pred parse_mutable_inst(term::in, maybe1(inst)::out) is det. parse_mutable_inst(InstTerm, InstResult) :- - ( - term__contains_var(InstTerm, _) - -> - InstResult = error("the inst in a mutable declaration " ++ - "cannot contain variables", InstTerm) - ; - convert_inst(no_allow_constrained_inst_var, InstTerm, Inst) - -> - InstResult = ok(Inst) - ; - InstResult = error("invalid inst in mutable declaration", - InstTerm) - ). + ( term__contains_var(InstTerm, _) -> + InstResult = error("the inst in a mutable declaration " ++ + "cannot contain variables", InstTerm) + ; convert_inst(no_allow_constrained_inst_var, InstTerm, Inst) -> + InstResult = ok(Inst) + ; + InstResult = error("invalid inst in mutable declaration", InstTerm) + ). :- type collected_mutable_attribute - ---> trailed(trailed) - ; thread_safe(thread_safe) - ; foreign_name(foreign_name) - ; attach_to_io_state(bool). + ---> trailed(trailed) + ; thread_safe(thread_safe) + ; foreign_name(foreign_name) + ; attach_to_io_state(bool). :- pred parse_mutable_attrs(term::in, - maybe1(mutable_var_attributes)::out) is det. + maybe1(mutable_var_attributes)::out) is det. parse_mutable_attrs(MutAttrsTerm, MutAttrsResult) :- - Attributes0 = default_mutable_attributes, - ConflictingAttributes = [ - thread_safe(thread_safe) - thread_safe(not_thread_safe), - trailed(trailed) - trailed(untrailed) - ], - ( - list_term_to_term_list(MutAttrsTerm, MutAttrTerms), - map_parser(parse_mutable_attr, MutAttrTerms, MaybeAttrList), - MaybeAttrList = ok(CollectedMutAttrs) - -> - % - % We check for trailed/untrailed and - % thread_safe/not_thread_safe conflicts here and deal - % with conflicting foreign_name attributes in - % make_hlds_passes.m. - % - ( - list.member(Conflict1 - Conflict2, - ConflictingAttributes), - list.member(Conflict1, CollectedMutAttrs), - list.member(Conflict2, CollectedMutAttrs) - -> - MutAttrsResult = error("conflicting attributes " ++ - "in attribute list", MutAttrsTerm) - ; - list.foldl(process_mutable_attribute, - CollectedMutAttrs, Attributes0, Attributes), - MutAttrsResult = ok(Attributes) - ) - ; - MutAttrsResult = error("malformed attribute list in " ++ - "mutable declaration", MutAttrsTerm) - ). + Attributes0 = default_mutable_attributes, + ConflictingAttributes = [ + thread_safe(thread_safe) - thread_safe(not_thread_safe), + trailed(trailed) - trailed(untrailed) + ], + ( + list_term_to_term_list(MutAttrsTerm, MutAttrTerms), + map_parser(parse_mutable_attr, MutAttrTerms, MaybeAttrList), + MaybeAttrList = ok(CollectedMutAttrs) + -> + % We check for trailed/untrailed and thread_safe/not_thread_safe + % conflicts here and deal with conflicting foreign_name attributes in + % make_hlds_passes.m. + % + ( + list.member(Conflict1 - Conflict2, ConflictingAttributes), + list.member(Conflict1, CollectedMutAttrs), + list.member(Conflict2, CollectedMutAttrs) + -> + MutAttrsResult = error("conflicting attributes " ++ + "in attribute list", MutAttrsTerm) + ; + list.foldl(process_mutable_attribute, CollectedMutAttrs, + Attributes0, Attributes), + MutAttrsResult = ok(Attributes) + ) + ; + MutAttrsResult = error("malformed attribute list in " ++ + "mutable declaration", MutAttrsTerm) + ). :- pred process_mutable_attribute(collected_mutable_attribute::in, - mutable_var_attributes::in, mutable_var_attributes::out) is det. + mutable_var_attributes::in, mutable_var_attributes::out) is det. process_mutable_attribute(thread_safe(ThreadSafe), !Attributes) :- - set_mutable_var_thread_safe(ThreadSafe, !Attributes). + set_mutable_var_thread_safe(ThreadSafe, !Attributes). process_mutable_attribute(trailed(Trailed), !Attributes) :- - set_mutable_var_trailed(Trailed, !Attributes). + set_mutable_var_trailed(Trailed, !Attributes). process_mutable_attribute(foreign_name(ForeignName), !Attributes) :- - set_mutable_add_foreign_name(ForeignName, !Attributes). + set_mutable_add_foreign_name(ForeignName, !Attributes). process_mutable_attribute(attach_to_io_state(AttachToIOState), !Attributes) :- - set_mutable_var_attach_to_io_state(AttachToIOState, !Attributes). + set_mutable_var_attach_to_io_state(AttachToIOState, !Attributes). :- pred parse_mutable_attr(term::in, - maybe1(collected_mutable_attribute)::out) is det. + maybe1(collected_mutable_attribute)::out) is det. parse_mutable_attr(MutAttrTerm, MutAttrResult) :- - ( - MutAttrTerm = term__functor(term__atom(String), [], _), - ( - String = "untrailed", - MutAttr = trailed(untrailed) - ; - String = "trailed", - MutAttr = trailed(trailed) - ; - String = "attach_to_io_state", - MutAttr = attach_to_io_state(yes) - ; - String = "thread_safe", - MutAttr = thread_safe(thread_safe) - ; - String = "not_thread_safe", - MutAttr = thread_safe(not_thread_safe) - ) - -> - MutAttrResult = ok(MutAttr) - ; - MutAttrTerm = term.functor(term.atom("foreign_name"), Args, _), - Args = [LangTerm, ForeignNameTerm], - parse_foreign_language(LangTerm, Lang), - ForeignNameTerm = term.functor(term.string(ForeignName), [], _) - -> - MutAttr = foreign_name(foreign_name(Lang, ForeignName)), - MutAttrResult = ok(MutAttr) - ; - MutAttrResult = error("unrecognised attribute in mutable " ++ - "declaration", MutAttrTerm) - ). + ( + MutAttrTerm = term__functor(term__atom(String), [], _), + ( + String = "untrailed", + MutAttr = trailed(untrailed) + ; + String = "trailed", + MutAttr = trailed(trailed) + ; + String = "attach_to_io_state", + MutAttr = attach_to_io_state(yes) + ; + String = "thread_safe", + MutAttr = thread_safe(thread_safe) + ; + String = "not_thread_safe", + MutAttr = thread_safe(not_thread_safe) + ) + -> + MutAttrResult = ok(MutAttr) + ; + MutAttrTerm = term.functor(term.atom("foreign_name"), Args, _), + Args = [LangTerm, ForeignNameTerm], + parse_foreign_language(LangTerm, Lang), + ForeignNameTerm = term.functor(term.string(ForeignName), [], _) + -> + MutAttr = foreign_name(foreign_name(Lang, ForeignName)), + MutAttrResult = ok(MutAttr) + ; + MutAttrResult = error("unrecognised attribute in mutable " ++ + "declaration", MutAttrTerm) + ). %-----------------------------------------------------------------------------% - % The optional `where ...' part of the type definition syntax - % is a comma separated list of special type `attributes'. - % - % The possible attributes (in this order) are either - % - `type_is_abstract_noncanonical' on its own appears only in .int2 - % files and indicates that the type has user-defined equality and/or - % comparison, but that what these predicates are is not known at - % this point - % or - % - `representation is <>' (required for solver types) - % - `initialisation is <>' (required for solver types) - % - `ground is <>' (required for solver types) - % - `any is <>' (required for solver types) - % - `equality is <>' (optional) - % - `comparison is <>' (optional). - % + % The optional `where ...' part of the type definition syntax + % is a comma separated list of special type `attributes'. + % + % The possible attributes (in this order) are either + % - `type_is_abstract_noncanonical' on its own appears only in .int2 + % files and indicates that the type has user-defined equality and/or + % comparison, but that what these predicates are is not known at + % this point + % or + % - `representation is <>' (required for solver types) + % - `initialisation is <>' (required for solver types) + % - `ground is <>' (required for solver types) + % - `any is <>' (required for solver types) + % - `equality is <>' (optional) + % - `comparison is <>' (optional). + % parse_type_decl_where_part_if_present(IsSolverType, ModuleName, Term0, Term, - Result) :- - ( - Term0 = term__functor(term__atom("where"), [Term1, WhereTerm], - _Context) - -> - Term = Term1, - Result = parse_type_decl_where_term(IsSolverType, ModuleName, - yes(WhereTerm)) - ; - Term = Term0, - Result = ok(no, no) - ). + Result) :- + ( + Term0 = term__functor(term__atom("where"), [Term1, WhereTerm], + _Context) + -> + Term = Term1, + Result = parse_type_decl_where_term(IsSolverType, ModuleName, + yes(WhereTerm)) + ; + Term = Term0, + Result = ok(no, no) + ). - % The maybe2 wrapper allows us to return an error code or a pair - % of results. Either result half may be empty, hence the maybe - % wrapper around each of those. - % + % The maybe2 wrapper allows us to return an error code or a pair + % of results. Either result half may be empty, hence the maybe + % wrapper around each of those. + % :- func parse_type_decl_where_term(is_solver_type, module_name, maybe(term)) = - maybe2(maybe(solver_type_details), maybe(unify_compare)). + maybe2(maybe(solver_type_details), maybe(unify_compare)). parse_type_decl_where_term(_IsSolverType, _ModuleName, no) = - ok(no, no). + ok(no, no). parse_type_decl_where_term(IsSolverType, ModuleName, MaybeTerm0 @ yes(Term)) = - MaybeWhereDetails :- - some [!MaybeTerm] ( - !:MaybeTerm = MaybeTerm0, - parse_where_attribute( - parse_where_type_is_abstract_noncanonical, - TypeIsAbstractNoncanonicalResult, !MaybeTerm), - parse_where_attribute( - parse_where_is("representation", - parse_where_type_is(ModuleName)), - RepresentationIsResult, !MaybeTerm), - parse_where_attribute( - parse_where_initialisation_is(ModuleName), - InitialisationIsResult, !MaybeTerm), - parse_where_attribute( - parse_where_is("ground", - parse_where_inst_is(ModuleName)), - GroundIsResult, !MaybeTerm), - parse_where_attribute( - parse_where_is("any", - parse_where_inst_is(ModuleName)), - AnyIsResult, !MaybeTerm), - parse_where_attribute( - parse_where_is("equality", - parse_where_pred_is(ModuleName)), - EqualityIsResult, !MaybeTerm), - parse_where_attribute( - parse_where_is("comparison", - parse_where_pred_is(ModuleName)), - ComparisonIsResult, !MaybeTerm), - parse_where_end(!.MaybeTerm, WhereEndResult) - ), - MaybeWhereDetails = - make_maybe_where_details( - IsSolverType, - TypeIsAbstractNoncanonicalResult, - RepresentationIsResult, - InitialisationIsResult, - GroundIsResult, - AnyIsResult, - EqualityIsResult, - ComparisonIsResult, - WhereEndResult, - Term - ). + MaybeWhereDetails :- + some [!MaybeTerm] ( + !:MaybeTerm = MaybeTerm0, + parse_where_attribute(parse_where_type_is_abstract_noncanonical, + TypeIsAbstractNoncanonicalResult, !MaybeTerm), + parse_where_attribute(parse_where_is("representation", + parse_where_type_is(ModuleName)), + RepresentationIsResult, !MaybeTerm), + parse_where_attribute(parse_where_initialisation_is(ModuleName), + InitialisationIsResult, !MaybeTerm), + parse_where_attribute(parse_where_is("ground", + parse_where_inst_is(ModuleName)), + GroundIsResult, !MaybeTerm), + parse_where_attribute(parse_where_is("any", + parse_where_inst_is(ModuleName)), + AnyIsResult, !MaybeTerm), + parse_where_attribute(parse_where_is("equality", + parse_where_pred_is(ModuleName)), + EqualityIsResult, !MaybeTerm), + parse_where_attribute(parse_where_is("comparison", + parse_where_pred_is(ModuleName)), + ComparisonIsResult, !MaybeTerm), + parse_where_end(!.MaybeTerm, WhereEndResult) + ), + MaybeWhereDetails = + make_maybe_where_details( + IsSolverType, + TypeIsAbstractNoncanonicalResult, + RepresentationIsResult, + InitialisationIsResult, + GroundIsResult, + AnyIsResult, + EqualityIsResult, + ComparisonIsResult, + WhereEndResult, + Term + ). - % parse_where_attribute(Parser, Result, MaybeTerm0, MaybeTerm) - % handles - % - where MaybeTerm0 may contain nothing - % - where MaybeTerm0 may be a comma-separated pair - % - applies Parser to the appropriate (sub)term to obtain Result - % - sets MaybeTerm depending upon whether the Result is an error - % or not and whether there is more to parse because MaybeTerm0 - % was a comma-separated pair. - % + % parse_where_attribute(Parser, Result, MaybeTerm0, MaybeTerm) + % handles + % - where MaybeTerm0 may contain nothing + % - where MaybeTerm0 may be a comma-separated pair + % - applies Parser to the appropriate (sub)term to obtain Result + % - sets MaybeTerm depending upon whether the Result is an error + % or not and whether there is more to parse because MaybeTerm0 + % was a comma-separated pair. + % :- pred parse_where_attribute((func(term) = maybe1(maybe(T)))::in, - maybe1(maybe(T))::out, maybe(term)::in, maybe(term)::out) is det. + maybe1(maybe(T))::out, maybe(term)::in, maybe(term)::out) is det. parse_where_attribute(_Parser, ok(no), no, no ). parse_where_attribute( Parser, Result, yes(Term0), MaybeRest) :- - ( - Term0 = term__functor(term__atom(","), [Term1, Term], _Context) - -> - Result = Parser(Term1), - MaybeRestIfYes = yes(Term) - ; - Result = Parser(Term0), - MaybeRestIfYes = no - ), - ( - Result = error(_, _), - MaybeRest = no - ; - Result = ok(no), - MaybeRest = yes(Term0) - ; - Result = ok(yes(_)), - MaybeRest = MaybeRestIfYes - ). + ( + Term0 = term__functor(term__atom(","), [Term1, Term], _Context) + -> + Result = Parser(Term1), + MaybeRestIfYes = yes(Term) + ; + Result = Parser(Term0), + MaybeRestIfYes = no + ), + ( + Result = error(_, _), + MaybeRest = no + ; + Result = ok(no), + MaybeRest = yes(Term0) + ; + Result = ok(yes(_)), + MaybeRest = MaybeRestIfYes + ). - % Parser for `where ...' attributes of the form - % `attributename is attributevalue'. - % + % Parser for `where ...' attributes of the form + % `attributename is attributevalue'. + % :- func parse_where_is(string, func(term) = maybe1(T), term) = - maybe1(maybe(T)). + maybe1(maybe(T)). parse_where_is(Name, Parser, Term) = Result :- - ( - Term = term__functor(term__atom("is"), [LHS, RHS], _Context1) - -> - ( - LHS = term__functor(term__atom(Name), [], _Context2) - -> - RHSResult = Parser(RHS), - ( - RHSResult = ok(ParsedRHS), - Result = ok(yes(ParsedRHS)) - ; - RHSResult = error(Msg, ProblemTerm), - Result = error(Msg, ProblemTerm) - ) - ; - Result = ok(no) - ) - ; - Result = error("expected is/2", Term) - ). + ( Term = term__functor(term__atom("is"), [LHS, RHS], _Context1) -> + ( LHS = term__functor(term__atom(Name), [], _Context2) -> + RHSResult = Parser(RHS), + ( + RHSResult = ok(ParsedRHS), + Result = ok(yes(ParsedRHS)) + ; + RHSResult = error(Msg, ProblemTerm), + Result = error(Msg, ProblemTerm) + ) + ; + Result = ok(no) + ) + ; + Result = error("expected is/2", Term) + ). :- func parse_where_type_is_abstract_noncanonical(term) = maybe1(maybe(unit)). parse_where_type_is_abstract_noncanonical(Term) = - ( - Term = term__functor(term__atom( - "type_is_abstract_noncanonical"), [], _Context) - -> - ok(yes(unit)) - ; - ok(no) - ). + ( + Term = term__functor(term__atom("type_is_abstract_noncanonical"), [], + _Context) + -> + ok(yes(unit)) + ; + ok(no) + ). :- func parse_where_initialisation_is(module_name, term) = - maybe1(maybe(sym_name)). + maybe1(maybe(sym_name)). parse_where_initialisation_is(ModuleName, Term) = Result :- - Result0 = parse_where_is("initialisation", - parse_where_pred_is(ModuleName), Term), - ( - Result0 = ok(no) - -> - Result = parse_where_is("initialization", - parse_where_pred_is(ModuleName), Term) - ; - Result = Result0 - ). + Result0 = parse_where_is("initialisation", parse_where_pred_is(ModuleName), + Term), + ( + Result0 = ok(no) + -> + Result = parse_where_is("initialization", + parse_where_pred_is(ModuleName), Term) + ; + Result = Result0 + ). :- func parse_where_pred_is(module_name, term) = maybe1(sym_name). parse_where_pred_is(ModuleName, Term) = Result :- - parse_implicitly_qualified_symbol_name(ModuleName, Term, Result). + parse_implicitly_qualified_symbol_name(ModuleName, Term, Result). :- func parse_where_inst_is(module_name, term) = maybe1(inst). parse_where_inst_is(_ModuleName, Term) = - ( - prog_io_util__convert_inst(no_allow_constrained_inst_var, - Term, Inst), - not prog_mode__inst_contains_unconstrained_var(Inst) - -> - ok(Inst) - ; - error("expected a ground, unconstrained inst", Term) - ). + ( + prog_io_util__convert_inst(no_allow_constrained_inst_var, Term, Inst), + not prog_mode__inst_contains_unconstrained_var(Inst) + -> + ok(Inst) + ; + error("expected a ground, unconstrained inst", Term) + ). :- func parse_where_type_is(module_name, term) = maybe1(type). parse_where_type_is(_ModuleName, Term) = Result :- - prog_io_util__parse_type(Term, Result). + prog_io_util__parse_type(Term, Result). :- pred parse_where_end(maybe(term)::in, maybe1(maybe(unit))::out) is det. parse_where_end(no, ok(yes(unit))). parse_where_end(yes(Term), error("attributes are either badly ordered or " ++ - "contain an unrecognised attribute", Term)). + "contain an unrecognised attribute", Term)). :- func make_maybe_where_details( - is_solver_type, - maybe1(maybe(unit)), - maybe1(maybe(type)), - maybe1(maybe(init_pred)), - maybe1(maybe(inst)), - maybe1(maybe(inst)), - maybe1(maybe(equality_pred)), - maybe1(maybe(comparison_pred)), - maybe1(maybe(unit)), - term - ) = maybe2(maybe(solver_type_details), maybe(unify_compare)). + is_solver_type, + maybe1(maybe(unit)), + maybe1(maybe(type)), + maybe1(maybe(init_pred)), + maybe1(maybe(inst)), + maybe1(maybe(inst)), + maybe1(maybe(equality_pred)), + maybe1(maybe(comparison_pred)), + maybe1(maybe(unit)), + term + ) = maybe2(maybe(solver_type_details), maybe(unify_compare)). make_maybe_where_details( - IsSolverType, - TypeIsAbstractNoncanonicalResult, - RepresentationIsResult, - InitialisationIsResult, - GroundIsResult, - AnyIsResult, - EqualityIsResult, - ComparisonIsResult, - WhereEndResult, - WhereTerm) = Result :- - ( - TypeIsAbstractNoncanonicalResult = error(String, Term) - -> - Result = error(String, Term) - ; - RepresentationIsResult = error(String, Term) - -> - Result = error(String, Term) - ; - InitialisationIsResult = error(String, Term) - -> - Result = error(String, Term) - ; - GroundIsResult = error(String, Term) - -> - Result = error(String, Term) - ; - AnyIsResult = error(String, Term) - -> - Result = error(String, Term) - ; - EqualityIsResult = error(String, Term) - -> - Result = error(String, Term) - ; - ComparisonIsResult = error(String, Term) - -> - Result = error(String, Term) - ; - WhereEndResult = error(String, Term) - -> - Result = error(String, Term) - ; - TypeIsAbstractNoncanonicalResult = ok(yes(_)) - -> - % rafe: XXX I think this is wrong. There isn't - % a problem with having the solver_type_details - % and type_is_abstract_noncanonical. - ( - RepresentationIsResult = ok(no), - InitialisationIsResult = ok(no), - GroundIsResult = ok(no), - AnyIsResult = ok(no), - EqualityIsResult = ok(no), - ComparisonIsResult = ok(no) - -> - Result = ok(no, - yes(abstract_noncanonical_type(IsSolverType))) - ; - Result = error("`where type_is_abstract_noncanonical' " - ++ " excludes other `where ...' attributes", - WhereTerm) - ) - ; - IsSolverType = solver_type - -> - ( - RepresentationIsResult = ok(yes(RepnType)), - InitialisationIsResult = ok(yes(InitPred)), - GroundIsResult = ok(MaybeGroundInst), - AnyIsResult = ok(MaybeAnyInst), - EqualityIsResult = ok(MaybeEqPred), - ComparisonIsResult = ok(MaybeCmpPred) - -> - ( - MaybeGroundInst = yes(GroundInst) - ; - MaybeGroundInst = no, - GroundInst = ground_inst - ), - ( - MaybeAnyInst = yes(AnyInst) - ; - MaybeAnyInst = no, - AnyInst = ground_inst - ), - MaybeSolverTypeDetails = yes(solver_type_details( - RepnType, InitPred, GroundInst, AnyInst)), - ( - MaybeEqPred = no, - MaybeCmpPred = no - -> - MaybeUnifyCompare = no - ; - MaybeUnifyCompare = yes(unify_compare( - MaybeEqPred, MaybeCmpPred)) - ), - Result = ok(MaybeSolverTypeDetails, MaybeUnifyCompare) - ; - RepresentationIsResult = ok(no) - -> - Result = error("solver type definitions must have a" ++ - "`representation' attribute", WhereTerm) - ; - InitialisationIsResult = ok(no) - -> - Result = error("solver type definitions must have an" ++ - "`initialisation' attribute", WhereTerm) - ; - error("prog_io__make_maybe_where_details: " ++ - "shouldn't have reached this point! (1)") - ) - ; - % Here we know IsSolverType = non_solver_type, so... + IsSolverType, + TypeIsAbstractNoncanonicalResult, + RepresentationIsResult, + InitialisationIsResult, + GroundIsResult, + AnyIsResult, + EqualityIsResult, + ComparisonIsResult, + WhereEndResult, + WhereTerm) = Result :- + ( + TypeIsAbstractNoncanonicalResult = error(String, Term) + -> + Result = error(String, Term) + ; + RepresentationIsResult = error(String, Term) + -> + Result = error(String, Term) + ; + InitialisationIsResult = error(String, Term) + -> + Result = error(String, Term) + ; + GroundIsResult = error(String, Term) + -> + Result = error(String, Term) + ; + AnyIsResult = error(String, Term) + -> + Result = error(String, Term) + ; + EqualityIsResult = error(String, Term) + -> + Result = error(String, Term) + ; + ComparisonIsResult = error(String, Term) + -> + Result = error(String, Term) + ; + WhereEndResult = error(String, Term) + -> + Result = error(String, Term) + ; + TypeIsAbstractNoncanonicalResult = ok(yes(_)) + -> + % rafe: XXX I think this is wrong. There isn't a problem with having + % the solver_type_details and type_is_abstract_noncanonical. + ( + RepresentationIsResult = ok(no), + InitialisationIsResult = ok(no), + GroundIsResult = ok(no), + AnyIsResult = ok(no), + EqualityIsResult = ok(no), + ComparisonIsResult = ok(no) + -> + Result = ok(no, yes(abstract_noncanonical_type(IsSolverType))) + ; + Result = error("`where type_is_abstract_noncanonical' " + ++ " excludes other `where ...' attributes", WhereTerm) + ) + ; + IsSolverType = solver_type + -> + ( + RepresentationIsResult = ok(yes(RepnType)), + InitialisationIsResult = ok(yes(InitPred)), + GroundIsResult = ok(MaybeGroundInst), + AnyIsResult = ok(MaybeAnyInst), + EqualityIsResult = ok(MaybeEqPred), + ComparisonIsResult = ok(MaybeCmpPred) + -> + ( + MaybeGroundInst = yes(GroundInst) + ; + MaybeGroundInst = no, + GroundInst = ground_inst + ), + ( + MaybeAnyInst = yes(AnyInst) + ; + MaybeAnyInst = no, + AnyInst = ground_inst + ), + MaybeSolverTypeDetails = yes(solver_type_details( + RepnType, InitPred, GroundInst, AnyInst)), + ( + MaybeEqPred = no, + MaybeCmpPred = no + -> + MaybeUnifyCompare = no + ; + MaybeUnifyCompare = yes(unify_compare( + MaybeEqPred, MaybeCmpPred)) + ), + Result = ok(MaybeSolverTypeDetails, MaybeUnifyCompare) + ; + RepresentationIsResult = ok(no) + -> + Result = error("solver type definitions must have a" ++ + "`representation' attribute", WhereTerm) + ; + InitialisationIsResult = ok(no) + -> + Result = error("solver type definitions must have an" ++ + "`initialisation' attribute", WhereTerm) + ; + error("make_maybe_where_details: " ++ + "shouldn't have reached this point! (1)") + ) + ; + % Here we know IsSolverType = non_solver_type, so... - ( RepresentationIsResult = ok(yes(_)) - ; InitialisationIsResult = ok(yes(_)) - ; GroundIsResult = ok(yes(_)) - ; AnyIsResult = ok(yes(_)) - ) - -> - Result = error("solver type attribute given for " ++ - "non-solver type", WhereTerm) - ; - EqualityIsResult = ok(MaybeEqPred), - ComparisonIsResult = ok(MaybeCmpPred) - -> - Result = ok(no, yes(unify_compare(MaybeEqPred, MaybeCmpPred))) - ; - error("prog_io__make_maybe_where_details: " ++ - "shouldn't have reached this point! (2)") - ). - - % get_determinism(Term0, Term, Determinism) binds Determinism - % to a representation of the determinism condition of Term0, if any, - % and binds Term to the other part of Term0. If Term0 does not - % contain a determinism, then Determinism is bound to `unspecified'. + ( RepresentationIsResult = ok(yes(_)) + ; InitialisationIsResult = ok(yes(_)) + ; GroundIsResult = ok(yes(_)) + ; AnyIsResult = ok(yes(_)) + ) + -> + Result = error("solver type attribute given for " ++ + "non-solver type", WhereTerm) + ; + EqualityIsResult = ok(MaybeEqPred), + ComparisonIsResult = ok(MaybeCmpPred) + -> + Result = ok(no, yes(unify_compare(MaybeEqPred, MaybeCmpPred))) + ; + error("make_maybe_where_details: " ++ + "shouldn't have reached this point! (2)") + ). + % get_determinism(Term0, Term, Determinism) binds Determinism + % to a representation of the determinism condition of Term0, if any, + % and binds Term to the other part of Term0. If Term0 does not + % contain a determinism, then Determinism is bound to `unspecified'. + % :- pred get_determinism(term::in, term::out, maybe1(maybe(determinism))::out) - is det. + is det. get_determinism(B, Body, Determinism) :- - ( - B = term__functor(term__atom("is"), Args, _Context1), - Args = [Body1, Determinism1] - -> - Body = Body1, - ( - Determinism1 = term__functor(term__atom(Determinism2), - [], _Context2), - standard_det(Determinism2, Determinism3) - -> - Determinism = ok(yes(Determinism3)) - ; - Determinism = error("invalid category", Determinism1) - ) - ; - Body = B, - Determinism = ok(no) - ). + ( + B = term__functor(term__atom("is"), Args, _Context1), + Args = [Body1, Determinism1] + -> + Body = Body1, + ( + Determinism1 = term__functor(term__atom(Determinism2), [], + _Context2), + standard_det(Determinism2, Determinism3) + -> + Determinism = ok(yes(Determinism3)) + ; + Determinism = error("invalid category", Determinism1) + ) + ; + Body = B, + Determinism = ok(no) + ). - % Process the `with_inst` part of a declaration of the form: - % :- mode p(int) `with_inst` (pred(in, out) is det). + % Process the `with_inst` part of a declaration of the form: + % :- mode p(int) `with_inst` (pred(in, out) is det). + % :- pred get_with_inst(term::in, term::out, maybe1(maybe(inst))::out) is det. get_with_inst(Body0, Body, WithInst) :- - ( - Body0 = term__functor(term__atom("with_inst"), - [Body1, Inst1], _) - -> - ( convert_inst(allow_constrained_inst_var, Inst1, Inst) -> - WithInst = ok(yes(Inst)) - ; - WithInst = error("invalid inst in `with_inst`", - Body0) - ), - Body = Body1 - ; - Body = Body0, - WithInst = ok(no) - ). + ( + Body0 = term__functor(term__atom("with_inst"), [Body1, Inst1], _) + -> + ( convert_inst(allow_constrained_inst_var, Inst1, Inst) -> + WithInst = ok(yes(Inst)) + ; + WithInst = error("invalid inst in `with_inst`", Body0) + ), + Body = Body1 + ; + Body = Body0, + WithInst = ok(no) + ). :- pred get_with_type(term::in, term::out, maybe1(maybe(type))::out) is det. get_with_type(Body0, Body, Result) :- - ( - Body0 = term__functor(TypeQualifier, [Body1, Type1], _), - ( - TypeQualifier = term.atom("with_type") - ; - TypeQualifier = term.atom(":") - ) - -> - Body = Body1, - parse_type(Type1, Result0), - ( - Result0 = ok(Type), - Result = ok(yes(Type)) - ; - Result0 = error(Msg, ErrorTerm), - Result = error(Msg, ErrorTerm) - ) - ; - Body = Body0, - Result = ok(no) - ). + ( + Body0 = term__functor(TypeQualifier, [Body1, Type1], _), + ( + TypeQualifier = term.atom("with_type") + ; + TypeQualifier = term.atom(":") + ) + -> + Body = Body1, + parse_type(Type1, Result0), + ( + Result0 = ok(Type), + Result = ok(yes(Type)) + ; + Result0 = error(Msg, ErrorTerm), + Result = error(Msg, ErrorTerm) + ) + ; + Body = Body0, + Result = ok(no) + ). %-----------------------------------------------------------------------------% - % get_condition(Term0, Term, Condition) binds Condition - % to a representation of the 'where' condition of Term0, if any, - % and binds Term to the other part of Term0. If Term0 does not - % contain a condition, then Condition is bound to true. - + % get_condition(Term0, Term, Condition) binds Condition + % to a representation of the 'where' condition of Term0, if any, + % and binds Term to the other part of Term0. If Term0 does not + % contain a condition, then Condition is bound to true. + % :- pred get_condition(term::in, term::out, condition::out) is det. get_condition(Body, Body, true). -/******** -% NU-Prolog supported type declarations of the form -% :- pred p(T) where p(X) : sorted(X). -% or -% :- type sorted_list(T) = list(T) where X : sorted(X). -% :- pred p(sorted_list(T). -% There is some code here to support that sort of thing, but -% probably we would now need to use a different syntax, since -% Mercury now uses `where' for different purposes (e.g. specifying -% user-defined equality predicates, and also for type classes ...) +% % NU-Prolog supported type declarations of the form +% % :- pred p(T) where p(X) : sorted(X). +% % or +% % :- type sorted_list(T) = list(T) where X : sorted(X). +% % :- pred p(sorted_list(T). +% % There is some code here to support that sort of thing, but +% % probably we would now need to use a different syntax, since +% % Mercury now uses `where' for different purposes (e.g. specifying +% % user-defined equality predicates, and also for type classes ...) % -get_condition(B, Body, Condition) :- - ( - B = term__functor(term__atom("where"), [Body1, Condition1], - _Context) - -> - Body = Body1, - Condition = where(Condition1) - ; - Body = B, - Condition = true - ). -********/ +% get_condition(B, Body, Condition) :- +% ( +% B = term__functor(term__atom("where"), [Body1, Condition1], +% _Context) +% -> +% Body = Body1, +% Condition = where(Condition1) +% ; +% Body = B, +% Condition = true +% ). %-----------------------------------------------------------------------------% :- type processed_type_body - ---> processed_type_body( - sym_name, - list(type_param), - type_defn - ). + ---> processed_type_body( + sym_name, + list(type_param), + type_defn + ). %-----------------------------------------------------------------------------% :- pred process_solver_type(module_name::in, term::in, - maybe(solver_type_details)::in, maybe(unify_compare)::in, - maybe1(processed_type_body)::out) is det. + maybe(solver_type_details)::in, maybe(unify_compare)::in, + maybe1(processed_type_body)::out) is det. process_solver_type(ModuleName, Head, MaybeSolverTypeDetails, MaybeUserEqComp, - Result) :- - ( - MaybeSolverTypeDetails = yes(SolverTypeDetails), - dummy_term(Body), - parse_type_defn_head(ModuleName, Head, Body, Result0), - ( - Result0 = error(String, Term), - Result = error(String, Term) - ; - Result0 = ok(Name, Params), - ( - RepnType = SolverTypeDetails ^ - representation_type, - type_contains_var(RepnType, Var), - not list__member(Var, Params) - -> - Result = error("free type variable in " ++ - "representation type", Head) - ; - Result = ok(processed_type_body(Name, Params, - solver_type(SolverTypeDetails, - MaybeUserEqComp))) - ) - ) - ; - MaybeSolverTypeDetails = no, - Result = error("solver type with no solver_type_details", Head) - ). + Result) :- + ( + MaybeSolverTypeDetails = yes(SolverTypeDetails), + dummy_term(Body), + parse_type_defn_head(ModuleName, Head, Body, Result0), + ( + Result0 = error(String, Term), + Result = error(String, Term) + ; + Result0 = ok(Name, Params), + ( + RepnType = SolverTypeDetails ^ representation_type, + type_contains_var(RepnType, Var), + not list__member(Var, Params) + -> + Result = error("free type variable in " ++ + "representation type", Head) + ; + Result = ok(processed_type_body(Name, Params, + solver_type(SolverTypeDetails, MaybeUserEqComp))) + ) + ) + ; + MaybeSolverTypeDetails = no, + Result = error("solver type with no solver_type_details", Head) + ). %-----------------------------------------------------------------------------% - % This is for "Head == Body" (equivalence) definitions. + % This is for "Head == Body" (equivalence) definitions. + % :- pred process_eqv_type(module_name::in, term::in, term::in, - maybe1(processed_type_body)::out) is det. + maybe1(processed_type_body)::out) is det. process_eqv_type(ModuleName, Head, Body, Result) :- - parse_type_defn_head(ModuleName, Head, Body, Result0), - process_eqv_type_2(Result0, Body, Result). + parse_type_defn_head(ModuleName, Head, Body, Result0), + process_eqv_type_2(Result0, Body, Result). :- pred process_eqv_type_2(maybe2(sym_name, list(type_param))::in, term::in, - maybe1(processed_type_body)::out) is det. + maybe1(processed_type_body)::out) is det. process_eqv_type_2(error(Error, Term), _, error(Error, Term)). process_eqv_type_2(ok(Name, Params), Body0, Result) :- - % Check that all the variables in the body occur in the head. - ( - ( - term__contains_var(Body0, Var), - term__coerce_var(Var, TVar), - \+ list__member(TVar, Params) - ) - -> - Result = error("free type parameter in RHS of " ++ - "type definition", Body0) - ; - parse_type(Body0, BodyResult), - ( - BodyResult = ok(Body), - Result = ok(processed_type_body(Name, Params, - eqv_type(Body))) - ; - BodyResult = error(Msg, ErrorTerm), - Result = error(Msg, ErrorTerm) - ) - ). + % Check that all the variables in the body occur in the head. + ( + term__contains_var(Body0, Var), + term__coerce_var(Var, TVar), + \+ list__member(TVar, Params) + -> + Result = error("free type parameter in RHS of type definition", Body0) + ; + parse_type(Body0, BodyResult), + ( + BodyResult = ok(Body), + Result = ok(processed_type_body(Name, Params, eqv_type(Body))) + ; + BodyResult = error(Msg, ErrorTerm), + Result = error(Msg, ErrorTerm) + ) + ). %-----------------------------------------------------------------------------% - % process_du_type(ModuleName, TypeHead, TypeBody, - % MaybeUserEqComp, Result) - % checks that its arguments are well formed, and if they are, - % binds Result to a representation of the type information about the - % TypeHead. - % This is for "Head ---> Body [where ...]" (constructor) definitions. - + % process_du_type(ModuleName, TypeHead, TypeBody, + % MaybeUserEqComp, Result): + % + % Checks that its arguments are well formed, and if they are, + % binds Result to a representation of the type information about the + % TypeHead. + % This is for "Head ---> Body [where ...]" (constructor) definitions. + % :- pred process_du_type(module_name::in, term::in, term::in, - list(constructor)::in, maybe(unify_compare)::in, - maybe1(processed_type_body)::out) is det. + list(constructor)::in, maybe(unify_compare)::in, + maybe1(processed_type_body)::out) is det. process_du_type(ModuleName, Head, Body, Ctors, MaybeUserEqComp, Result) :- - parse_type_defn_head(ModuleName, Head, Body, Result0), - ( - Result0 = error(String, Term), - Result = error(String, Term) - ; - Result0 = ok(Functor, Params), - process_du_type_2(Functor, Params, Body, Ctors, - MaybeUserEqComp, Result) - ). + parse_type_defn_head(ModuleName, Head, Body, Result0), + ( + Result0 = error(String, Term), + Result = error(String, Term) + ; + Result0 = ok(Functor, Params), + process_du_type_2(Functor, Params, Body, Ctors, MaybeUserEqComp, + Result) + ). :- pred process_du_type_2(sym_name::in, list(type_param)::in, term::in, - list(constructor)::in, maybe(unify_compare)::in, - maybe1(processed_type_body)::out) is det. + list(constructor)::in, maybe(unify_compare)::in, + maybe1(processed_type_body)::out) is det. process_du_type_2(Functor, Params, Body, Ctors, MaybeUserEqComp, Result) :- + ( + % Check that all type variables in the body are either explicitly + % existentially quantified or occur in the head. - % Check that all type variables in the body are either explicitly - % existentially quantified or occur in the head. - ( - list__member(Ctor, Ctors), - Ctor = ctor(ExistQVars, _Constraints, _CtorName, CtorArgs), - assoc_list__values(CtorArgs, CtorArgTypes), - type_list_contains_var(CtorArgTypes, Var), - \+ list__member(Var, ExistQVars), - \+ list__member(Var, Params) - -> - Result = error("free type parameter in RHS of " ++ - "type definition", Body) + list__member(Ctor, Ctors), + Ctor = ctor(ExistQVars, _Constraints, _CtorName, CtorArgs), + assoc_list__values(CtorArgs, CtorArgTypes), + type_list_contains_var(CtorArgTypes, Var), + \+ list__member(Var, ExistQVars), + \+ list__member(Var, Params) + -> + Result = error("free type parameter in RHS of type definition", Body) + ; + % Check that all type variables in existential quantifiers do not + % occur in the head (maybe this should just be a warning, not an error? + % If we were to allow it, we would need to rename them apart.) - % Check that all type variables in existential quantifiers do not - % occur in the head (maybe this should just be a warning, not an - % error? If we were to allow it, we would need to rename them - % apart.) - ; - list__member(Ctor, Ctors), - Ctor = ctor(ExistQVars, _Constraints, _CtorName, _CtorArgs), - list__member(Var, ExistQVars), - list__member(Var, Params) - -> - Result = error("type variable has overlapping " ++ - "scopes (explicit type quantifier " ++ - "shadows argument type)", Body) + list__member(Ctor, Ctors), + Ctor = ctor(ExistQVars, _Constraints, _CtorName, _CtorArgs), + list__member(Var, ExistQVars), + list__member(Var, Params) + -> + Result = error("type variable has overlapping scopes " ++ + "(explicit type quantifier shadows argument type)", Body) + ; + % Check that all type variables in existential quantifiers occur + % somewhere in the constructor argument types or constraints. - % Check that all type variables in existential quantifiers occur - % somewhere in the constructor argument types or constraints. - ; - list__member(Ctor, Ctors), - Ctor = ctor(ExistQVars, Constraints, _CtorName, CtorArgs), - list__member(Var, ExistQVars), - assoc_list__values(CtorArgs, CtorArgTypes), - \+ type_list_contains_var(CtorArgTypes, Var), - constraint_list_get_tvars(Constraints, ConstraintTVars), - \+ list__member(Var, ConstraintTVars) - -> - Result = error("type variable in existential " ++ - "quantifier does not occur in " ++ - "arguments or constraints of constructor", Body) + list__member(Ctor, Ctors), + Ctor = ctor(ExistQVars, Constraints, _CtorName, CtorArgs), + list__member(Var, ExistQVars), + assoc_list__values(CtorArgs, CtorArgTypes), + \+ type_list_contains_var(CtorArgTypes, Var), + constraint_list_get_tvars(Constraints, ConstraintTVars), + \+ list__member(Var, ConstraintTVars) + -> + Result = error("type variable in existential quantifier " ++ + "does not occur in arguments or constraints of constructor", Body) + ; + % Check that all type variables in existential constraints occur in + % the existential quantifiers. - % Check that all type variables in existential constraints occur in - % the existential quantifiers. - ; - list__member(Ctor, Ctors), - Ctor = ctor(ExistQVars, Constraints, _CtorName, _CtorArgs), - list__member(Constraint, Constraints), - Constraint = constraint(_Name, ConstraintArgs), - type_list_contains_var(ConstraintArgs, Var), - \+ list__member(Var, ExistQVars) - -> - Result = error("type variables in class " ++ - "constraints introduced " ++ - "with `=>' must be explicitly " ++ - "existentially quantified " ++ - "using `some'", Body) - ; - Result = ok(processed_type_body(Functor, Params, - du_type(Ctors, MaybeUserEqComp))) - ). + list__member(Ctor, Ctors), + Ctor = ctor(ExistQVars, Constraints, _CtorName, _CtorArgs), + list__member(Constraint, Constraints), + Constraint = constraint(_Name, ConstraintArgs), + type_list_contains_var(ConstraintArgs, Var), + \+ list__member(Var, ExistQVars) + -> + Result = error("type variables in class constraints introduced " ++ + "with `=>' must be explicitly existentially quantified " ++ + "using `some'", Body) + ; + Result = ok(processed_type_body(Functor, Params, + du_type(Ctors, MaybeUserEqComp))) + ). %-----------------------------------------------------------------------------% - % process_abstract_type(ModuleName, TypeHead, Result) - % checks that its argument is well formed, and if it is, - % binds Result to a representation of the type information about the - % TypeHead. - + % process_abstract_type(ModuleName, TypeHead, Result): + % + % Checks that its argument is well formed, and if it is, binds Result + % to a representation of the type information about the TypeHead. + % :- pred process_abstract_type(module_name::in, term::in, decl_attrs::in, - maybe1(processed_type_body)::out) is det. + maybe1(processed_type_body)::out) is det. process_abstract_type(ModuleName, Head, Attributes0, Result) :- - dummy_term(Body), - parse_type_defn_head(ModuleName, Head, Body, Result0), - get_is_solver_type(IsSolverType, Attributes0, Attributes), - process_abstract_type_2(Result0, IsSolverType, Result1), - check_no_attributes(Result1, Attributes, Result). + dummy_term(Body), + parse_type_defn_head(ModuleName, Head, Body, Result0), + get_is_solver_type(IsSolverType, Attributes0, Attributes), + process_abstract_type_2(Result0, IsSolverType, Result1), + check_no_attributes(Result1, Attributes, Result). :- pred process_abstract_type_2(maybe2(sym_name, list(type_param))::in, - is_solver_type::in, maybe1(processed_type_body)::out) is det. + is_solver_type::in, maybe1(processed_type_body)::out) is det. process_abstract_type_2(error(Error, Term), _, error(Error, Term)). process_abstract_type_2(ok(Functor, Params), IsSolverType, Result) :- - Result = ok(processed_type_body(Functor, Params, - abstract_type(IsSolverType))). + Result = ok(processed_type_body(Functor, Params, + abstract_type(IsSolverType))). %-----------------------------------------------------------------------------% parse_type_defn_head(ModuleName, Head, Body, Result) :- - ( Head = term__variable(_) -> - % - % `Head' has no term__context, so we need to get the - % context from `Body' - % - ( Body = term__functor(_, _, Context) -> - dummy_term_with_context(Context, ErrorTerm) - ; - dummy_term(ErrorTerm) - ), - Result = error("variable on LHS of type definition", ErrorTerm) - ; - parse_implicitly_qualified_term(ModuleName, - Head, Head, "type definition", R), - parse_type_defn_head_2(R, Head, Result) - ). + ( Head = term__variable(_) -> + % `Head' has no term__context, so we need to get the + % context from `Body' + ( Body = term__functor(_, _, Context) -> + dummy_term_with_context(Context, ErrorTerm) + ; + dummy_term(ErrorTerm) + ), + Result = error("variable on LHS of type definition", ErrorTerm) + ; + parse_implicitly_qualified_term(ModuleName, Head, Head, + "type definition", R), + parse_type_defn_head_2(R, Head, Result) + ). :- pred parse_type_defn_head_2(maybe_functor::in, term::in, - maybe2(sym_name, list(tvar))::out) is det. + maybe2(sym_name, list(tvar))::out) is det. parse_type_defn_head_2(error(Msg, Term), _, error(Msg, Term)). parse_type_defn_head_2(ok(Name, Args), Head, Result) :- - parse_type_defn_head_3(Name, Args, Head, Result). + parse_type_defn_head_3(Name, Args, Head, Result). :- pred parse_type_defn_head_3(sym_name::in, list(term)::in, term::in, - maybe2(sym_name, list(tvar))::out) is det. + maybe2(sym_name, list(tvar))::out) is det. parse_type_defn_head_3(Name, Args, Head, Result) :- - % Check that all the head args are variables. - ( - var_list_to_term_list(Params0, Args) - -> - % Check that all the head arg variables are distinct. - ( some [Param, OtherParams] - ( - list__member(_, Params0, - [Param | OtherParams]), - list__member(Param, OtherParams) - ) - -> - Result = error("repeated type parameters " - ++ "in LHS of type defn", Head) - ; - list__map(term__coerce_var, Params0, Params), - Result = ok(Name, Params) - ) - ; - Result = error("type parameters must be variables", Head) - ). + % Check that all the head args are variables. + ( var_list_to_term_list(Params0, Args) -> + % Check that all the head arg variables are distinct. + ( + list__member(_, Params0, [Param | OtherParams]), + list__member(Param, OtherParams) + -> + Result = error("repeated type parameters " + ++ "in LHS of type defn", Head) + ; + list__map(term__coerce_var, Params0, Params), + Result = ok(Name, Params) + ) + ; + Result = error("type parameters must be variables", Head) + ). %-----------------------------------------------------------------------------% - % Convert a list of terms separated by semi-colons - % (known as a "disjunction", even thought the terms aren't goals - % in this case) into a list of constructors. - + % Convert a list of terms separated by semi-colons (known as a + % "disjunction", even thought the terms aren't goals in this case) + % into a list of constructors. + % :- func convert_constructors(module_name, term) = maybe1(list(constructor)). convert_constructors(ModuleName, Body) = Result :- - disjunction_to_list(Body, List), - Result0 = convert_constructors_2(ModuleName, List), - ( - Result0 = ok(Constructors), - Result = ok(Constructors) - ; - Result0 = error(String, Term), - Result = error(String, Term) - ). - - % true if input argument is a valid list of constructors + disjunction_to_list(Body, List), + Result0 = convert_constructors_2(ModuleName, List), + ( + Result0 = ok(Constructors), + Result = ok(Constructors) + ; + Result0 = error(String, Term), + Result = error(String, Term) + ). + % True if input argument is a valid list of constructors. + % :- func convert_constructors_2(module_name, list(term)) = - maybe1(list(constructor)). + maybe1(list(constructor)). convert_constructors_2(_ModuleName, []) = ok([]). convert_constructors_2( ModuleName, [Term | Terms]) = Result :- - Result0 = convert_constructor(ModuleName, Term), - ( - Result0 = error(String0, Term0), - Result = error(String0, Term0) - ; - Result0 = ok(Constructor), - Result1 = convert_constructors_2(ModuleName, Terms), - ( - Result1 = error(String1, Term1), - Result = error(String1, Term1) - ; - Result1 = ok(Constructors), - Result = ok([Constructor | Constructors]) - ) - ). + Result0 = convert_constructor(ModuleName, Term), + ( + Result0 = error(String0, Term0), + Result = error(String0, Term0) + ; + Result0 = ok(Constructor), + Result1 = convert_constructors_2(ModuleName, Terms), + ( + Result1 = error(String1, Term1), + Result = error(String1, Term1) + ; + Result1 = ok(Constructors), + Result = ok([Constructor | Constructors]) + ) + ). :- func convert_constructor(module_name, term) = maybe1(constructor). convert_constructor(ModuleName, Term0) = Result :- - ( - Term0 = term__functor(term__atom("some"), [Vars, Term1], - _Context) - -> - ( - parse_list_of_vars(Vars, ExistQVars0) - -> - list__map(term__coerce_var, ExistQVars0, ExistQVars), - Result = convert_constructor_2(ModuleName, ExistQVars, - Term0, Term1) - ; - Result = error("syntax error in variable list", Term0) - ) - ; - ExistQVars = [], - Result = convert_constructor_2(ModuleName, ExistQVars, - Term0, Term0) - ). + ( Term0 = term__functor(term__atom("some"), [Vars, Term1], _Context) -> + ( parse_list_of_vars(Vars, ExistQVars0) -> + list__map(term__coerce_var, ExistQVars0, ExistQVars), + Result = convert_constructor_2(ModuleName, ExistQVars, + Term0, Term1) + ; + Result = error("syntax error in variable list", Term0) + ) + ; + ExistQVars = [], + Result = convert_constructor_2(ModuleName, ExistQVars, Term0, Term0) + ). :- func convert_constructor_2(module_name, list(tvar), term, term) = - maybe1(constructor). + maybe1(constructor). convert_constructor_2(ModuleName, ExistQVars, Term0, Term1) = Result :- - get_existential_constraints_from_term(ModuleName, Term1, Term2, - Result0), - ( - Result0 = error(String, Term), - Result = error(String, Term) - ; - Result0 = ok(Constraints), - ( - % Note that as a special case, one level of - % curly braces around the constructor are ignored. - % This is to allow you to define ';'/2 and 'some'/2 - % constructors. - Term2 = term__functor(term__atom("{}"), [Term3], - _Context) - -> - Term4 = Term3 - ; - Term4 = Term2 - ), - Result = convert_constructor_3(ModuleName, ExistQVars, - Constraints, Term0, Term4) - ). + get_existential_constraints_from_term(ModuleName, Term1, Term2, Result0), + ( + Result0 = error(String, Term), + Result = error(String, Term) + ; + Result0 = ok(Constraints), + ( + % Note that as a special case, one level of curly braces around + % the constructor are ignored. This is to allow you to define + % ';'/2 and 'some'/2 constructors. + Term2 = term__functor(term__atom("{}"), [Term3], _Context) + -> + Term4 = Term3 + ; + Term4 = Term2 + ), + Result = convert_constructor_3(ModuleName, ExistQVars, Constraints, + Term0, Term4) + ). -:- func convert_constructor_3(module_name, list(tvar), - list(prog_constraint), term, term) = maybe1(constructor). +:- func convert_constructor_3(module_name, list(tvar), list(prog_constraint), + term, term) = maybe1(constructor). convert_constructor_3(ModuleName, ExistQVars, Constraints, Term0, Term1) = - Result :- - parse_implicitly_qualified_term(ModuleName, - Term1, Term0, "constructor definition", Result0), - ( - Result0 = error(String, Term), - Result = error(String, Term) - ; - Result0 = ok(F, As), - Result1 = convert_constructor_arg_list(ModuleName, As), - ( - Result1 = error(String, Term), - Result = error(String, Term) - ; - Result1 = ok(Args), - Result = ok(ctor(ExistQVars, Constraints, F, Args)) - ) - ). + Result :- + parse_implicitly_qualified_term(ModuleName, Term1, Term0, + "constructor definition", Result0), + ( + Result0 = error(String, Term), + Result = error(String, Term) + ; + Result0 = ok(F, As), + Result1 = convert_constructor_arg_list(ModuleName, As), + ( + Result1 = error(String, Term), + Result = error(String, Term) + ; + Result1 = ok(Args), + Result = ok(ctor(ExistQVars, Constraints, F, Args)) + ) + ). %-----------------------------------------------------------------------------% - % parse a `:- pred p(...)' declaration or a - % `:- func f(...) `with_type` t' declaration - + % parse a `:- pred p(...)' declaration or a + % `:- func f(...) `with_type` t' declaration + % :- pred process_pred_or_func(pred_or_func::in, module_name::in, varset::in, - term::in, condition::in, maybe(type)::in, maybe(inst)::in, - maybe(determinism)::in, decl_attrs::in, maybe1(item)::out) is det. + term::in, condition::in, maybe(type)::in, maybe(inst)::in, + maybe(determinism)::in, decl_attrs::in, maybe1(item)::out) is det. process_pred_or_func(PredOrFunc, ModuleName, VarSet, PredType, Cond, WithType, - WithInst, MaybeDet, Attributes0, Result) :- - get_class_context_and_inst_constraints(ModuleName, Attributes0, - Attributes, MaybeContext), - ( - MaybeContext = ok(ExistQVars, Constraints, InstConstraints), - parse_implicitly_qualified_term(ModuleName, - PredType, PredType, - pred_or_func_decl_string(PredOrFunc), R), - process_pred_or_func_2(PredOrFunc, R, PredType, VarSet, - WithType, WithInst, MaybeDet, Cond, ExistQVars, - Constraints, InstConstraints, Attributes, Result) - ; - MaybeContext = error(String, Term), - Result = error(String, Term) - ). + WithInst, MaybeDet, Attributes0, Result) :- + get_class_context_and_inst_constraints(ModuleName, Attributes0, + Attributes, MaybeContext), + ( + MaybeContext = ok(ExistQVars, Constraints, InstConstraints), + parse_implicitly_qualified_term(ModuleName, PredType, PredType, + pred_or_func_decl_string(PredOrFunc), R), + process_pred_or_func_2(PredOrFunc, R, PredType, VarSet, + WithType, WithInst, MaybeDet, Cond, ExistQVars, + Constraints, InstConstraints, Attributes, Result) + ; + MaybeContext = error(String, Term), + Result = error(String, Term) + ). :- pred process_pred_or_func_2(pred_or_func::in, maybe_functor::in, term::in, - varset::in, maybe(type)::in, maybe(inst)::in, maybe(determinism)::in, - condition::in, existq_tvars::in, prog_constraints::in, - inst_var_sub::in, decl_attrs::in, maybe1(item)::out) is det. + varset::in, maybe(type)::in, maybe(inst)::in, maybe(determinism)::in, + condition::in, existq_tvars::in, prog_constraints::in, + inst_var_sub::in, decl_attrs::in, maybe1(item)::out) is det. process_pred_or_func_2(PredOrFunc, ok(F, As0), PredType, VarSet0, - WithType, WithInst, MaybeDet, Cond, ExistQVars, - ClassContext, InstConstraints, Attributes0, Result) :- - ( convert_type_and_mode_list(InstConstraints, As0, As) -> - ( verify_type_and_mode_list(As) -> - ( - WithInst = yes(_), - As = [type_only(_) | _] - -> - Result = error("`with_inst` specified " ++ - "without argument modes", PredType) - ; - WithInst = no, - WithType = yes(_), - As = [type_and_mode(_, _) | _] - -> - Result = error("arguments have modes but " ++ - "`with_inst` not specified", PredType) - ; - \+ inst_var_constraints_are_consistent_in_type_and_modes(As) - -> - Result = error("inconsistent constraints " ++ - "on inst variables in " ++ - pred_or_func_decl_string(PredOrFunc), - PredType) - ; - get_purity(Purity, Attributes0, Attributes), - varset__coerce(VarSet0, TVarSet), - varset__coerce(VarSet0, IVarSet), - Result0 = ok(pred_or_func(TVarSet, IVarSet, - ExistQVars, PredOrFunc, F, As, - WithType, WithInst, MaybeDet, Cond, - Purity, ClassContext)), - check_no_attributes(Result0, Attributes, - Result) - ) - ; - Result = error("some but not all arguments " ++ - "have modes", PredType) - ) - ; - Result = error("syntax error in " ++ - pred_or_func_decl_string(PredOrFunc), - PredType) - ). + WithType, WithInst, MaybeDet, Cond, ExistQVars, + ClassContext, InstConstraints, Attributes0, Result) :- + ( convert_type_and_mode_list(InstConstraints, As0, As) -> + ( verify_type_and_mode_list(As) -> + ( + WithInst = yes(_), + As = [type_only(_) | _] + -> + Result = error("`with_inst` specified " ++ + "without argument modes", PredType) + ; + WithInst = no, + WithType = yes(_), + As = [type_and_mode(_, _) | _] + -> + Result = error("arguments have modes but " ++ + "`with_inst` not specified", PredType) + ; + \+ inst_var_constraints_are_consistent_in_type_and_modes(As) + -> + Result = error("inconsistent constraints " ++ + "on inst variables in " ++ + pred_or_func_decl_string(PredOrFunc), PredType) + ; + get_purity(Purity, Attributes0, Attributes), + varset__coerce(VarSet0, TVarSet), + varset__coerce(VarSet0, IVarSet), + Result0 = ok(pred_or_func(TVarSet, IVarSet, ExistQVars, + PredOrFunc, F, As, WithType, WithInst, MaybeDet, Cond, + Purity, ClassContext)), + check_no_attributes(Result0, Attributes, Result) + ) + ; + Result = error("some but not all arguments " ++ + "have modes", PredType) + ) + ; + Result = error("syntax error in " ++ + pred_or_func_decl_string(PredOrFunc), PredType) + ). process_pred_or_func_2(_, error(M, T), - _, _, _, _, _, _, _, _, _, _, error(M, T)). + _, _, _, _, _, _, _, _, _, _, error(M, T)). :- pred get_purity(purity::out, decl_attrs::in, decl_attrs::out) is det. get_purity(Purity, !Attributes) :- - ( !.Attributes = [purity(Purity0) - _ | !:Attributes] -> - Purity = Purity0 - ; - Purity = (pure) - ). + ( !.Attributes = [purity(Purity0) - _ | !:Attributes] -> + Purity = Purity0 + ; + Purity = (pure) + ). :- func pred_or_func_decl_string(pred_or_func) = string. @@ -2997,844 +2840,800 @@ pred_or_func_decl_string(predicate) = "`:- pred' declaration". %-----------------------------------------------------------------------------% - % We could perhaps get rid of some code duplication between here and - % prog_io_typeclass.m? - - % get_class_context_and_inst_constraints(ModuleName, Attributes0, - % Attributes, MaybeContext, MaybeInstConstraints): - % Parse type quantifiers, type class constraints and inst constraints - % from the declaration attributes in Attributes0. - % MaybeContext is either bound to the correctly parsed context, or - % an appropriate error message (if there was a syntax error). - % MaybeInstConstraints is either bound to a map containing the inst - % constraints or an appropriate error message (if there was a syntax - % error). - % Attributes is bound to the remaining attributes. + % We could perhaps get rid of some code duplication between here and + % prog_io_typeclass.m? + % get_class_context_and_inst_constraints(ModuleName, Attributes0, + % Attributes, MaybeContext, MaybeInstConstraints): + % + % Parse type quantifiers, type class constraints and inst constraints + % from the declaration attributes in Attributes0. + % MaybeContext is either bound to the correctly parsed context, or + % an appropriate error message (if there was a syntax error). + % MaybeInstConstraints is either bound to a map containing the inst + % constraints or an appropriate error message (if there was a syntax + % error). + % Attributes is bound to the remaining attributes. + % :- pred get_class_context_and_inst_constraints(module_name::in, - decl_attrs::in, decl_attrs::out, - maybe3(existq_tvars, prog_constraints, inst_var_sub)::out) is det. + decl_attrs::in, decl_attrs::out, + maybe3(existq_tvars, prog_constraints, inst_var_sub)::out) is det. get_class_context_and_inst_constraints(ModuleName, RevAttributes0, - RevAttributes, MaybeContext) :- - % - % constraints and quantifiers should occur in the following - % order (outermost to innermost): - % - % operator precedence - % ------- ---------- - % 1. universal quantifiers all 950 - % 2. existential quantifiers some 950 - % 3. universal constraints <= 920 - % 4. existential constraints => 920 [*] - % 5. the decl itself pred or func 800 - % - % When we reach here, Attributes0 contains declaration attributes - % in the opposite order -- innermost to outermost -- so we reverse - % them before we start. - % - % [*] Note that the semantic meaning of `=>' is not quite - % the same as implication; logically speaking it's more - % like conjunction. Oh well, at least it has the right - % precedence. - % - % In theory it could make sense to allow the order of 2 & 3 to be - % swapped, or (in the case of multiple constraints & multiple - % quantifiers) to allow arbitrary interleaving of 2 & 3, but in - % practice it seems there would be little benefit in allowing that - % flexibility, so we don't. - % - % Universal quantification is the default, so we just ignore - % universal quantifiers. (XXX It might be a good idea to check - % that any universally quantified type variables do actually - % occur somewhere in the type declaration, and are not also - % existentially quantified, and if not, issue a warning or - % error message.) + RevAttributes, MaybeContext) :- + % Constraints and quantifiers should occur in the following order + % (outermost to innermost): + % + % operator precedence + % -------- ---------- + % 1. universal quantifiers all 950 + % 2. existential quantifiers some 950 + % 3. universal constraints <= 920 + % 4. existential constraints => 920 [*] + % 5. the decl itself pred or func 800 + % + % When we reach here, Attributes0 contains declaration attributes + % in the opposite order -- innermost to outermost -- so we reverse + % them before we start. + % + % [*] Note that the semantic meaning of `=>' is not quite the same + % as implication; logically speaking it's more like conjunction. + % Oh well, at least it has the right precedence. + % + % In theory it could make sense to allow the order of 2 & 3 to be + % swapped, or (in the case of multiple constraints & multiple + % quantifiers) to allow arbitrary interleaving of 2 & 3, but in + % practice it seems there would be little benefit in allowing that + % flexibility, so we don't. + % + % Universal quantification is the default, so we just ignore + % universal quantifiers. (XXX It might be a good idea to check + % that any universally quantified type variables do actually + % occur somewhere in the type declaration, and are not also + % existentially quantified, and if not, issue a warning or + % error message.) - list__reverse(RevAttributes0, Attributes0), - get_quant_vars(univ, ModuleName, Attributes0, Attributes1, - [], _UnivQVars), - get_quant_vars(exist, ModuleName, Attributes1, Attributes2, - [], ExistQVars0), - list__map(term__coerce_var, ExistQVars0, ExistQVars), - get_constraints(univ, ModuleName, Attributes2, - Attributes3, MaybeUnivConstraints), - get_constraints(exist, ModuleName, Attributes3, - Attributes, MaybeExistConstraints), - list__reverse(Attributes, RevAttributes), + list__reverse(RevAttributes0, Attributes0), + get_quant_vars(univ, ModuleName, Attributes0, Attributes1, + [], _UnivQVars), + get_quant_vars(exist, ModuleName, Attributes1, Attributes2, + [], ExistQVars0), + list__map(term__coerce_var, ExistQVars0, ExistQVars), + get_constraints(univ, ModuleName, Attributes2, + Attributes3, MaybeUnivConstraints), + get_constraints(exist, ModuleName, Attributes3, + Attributes, MaybeExistConstraints), + list__reverse(Attributes, RevAttributes), - combine_quantifier_results(MaybeUnivConstraints, MaybeExistConstraints, - ExistQVars, MaybeContext). + combine_quantifier_results(MaybeUnivConstraints, MaybeExistConstraints, + ExistQVars, MaybeContext). :- pred combine_quantifier_results(maybe_class_and_inst_constraints::in, - maybe_class_and_inst_constraints::in, existq_tvars::in, - maybe3(existq_tvars, prog_constraints, inst_var_sub)::out) is det. + maybe_class_and_inst_constraints::in, existq_tvars::in, + maybe3(existq_tvars, prog_constraints, inst_var_sub)::out) is det. combine_quantifier_results(error(Msg, Term), _, _, error(Msg, Term)). combine_quantifier_results(ok(_, _), error(Msg, Term), _, error(Msg, Term)). combine_quantifier_results(ok(UnivConstraints, InstConstraints0), - ok(ExistConstraints, InstConstraints1), ExistQVars, - ok(ExistQVars, constraints(UnivConstraints, ExistConstraints), - InstConstraints0 `map__merge` InstConstraints1)). + ok(ExistConstraints, InstConstraints1), ExistQVars, + ok(ExistQVars, constraints(UnivConstraints, ExistConstraints), + InstConstraints0 `map__merge` InstConstraints1)). :- pred get_quant_vars(quantifier_type::in, module_name::in, - decl_attrs::in, decl_attrs::out, list(var)::in, list(var)::out) is det. + decl_attrs::in, decl_attrs::out, list(var)::in, list(var)::out) is det. get_quant_vars(QuantType, ModuleName, !Attributes, !Vars) :- - ( - !.Attributes = [quantifier(QuantType, QuantVars) - _ - | !:Attributes] - -> - list__append(!.Vars, QuantVars, !:Vars), - get_quant_vars(QuantType, ModuleName, !Attributes, !Vars) - ; - true - ). + ( + !.Attributes = [quantifier(QuantType, QuantVars) - _ | !:Attributes] + -> + list__append(!.Vars, QuantVars, !:Vars), + get_quant_vars(QuantType, ModuleName, !Attributes, !Vars) + ; + true + ). :- pred get_constraints(quantifier_type::in, module_name::in, decl_attrs::in, - decl_attrs::out, maybe_class_and_inst_constraints::out) is det. + decl_attrs::out, maybe_class_and_inst_constraints::out) is det. get_constraints(QuantType, ModuleName, !Attributes, MaybeConstraints) :- - ( - !.Attributes = [constraints(QuantType, ConstraintsTerm) - _Term - | !:Attributes] - -> - parse_class_and_inst_constraints(ModuleName, ConstraintsTerm, - MaybeConstraints0), - % there may be more constraints of the same type -- - % collect them all and combine them - get_constraints(QuantType, ModuleName, !Attributes, - MaybeConstraints1), - combine_constraint_list_results(MaybeConstraints1, - MaybeConstraints0, MaybeConstraints) - ; - MaybeConstraints = ok([], map__init) - ). + ( + !.Attributes = [constraints(QuantType, ConstraintsTerm) - _Term + | !:Attributes] + -> + parse_class_and_inst_constraints(ModuleName, ConstraintsTerm, + MaybeConstraints0), + % there may be more constraints of the same type -- + % collect them all and combine them + get_constraints(QuantType, ModuleName, !Attributes, + MaybeConstraints1), + combine_constraint_list_results(MaybeConstraints1, + MaybeConstraints0, MaybeConstraints) + ; + MaybeConstraints = ok([], map__init) + ). :- pred combine_constraint_list_results(maybe_class_and_inst_constraints::in, - maybe_class_and_inst_constraints::in, - maybe_class_and_inst_constraints::out) is det. + maybe_class_and_inst_constraints::in, + maybe_class_and_inst_constraints::out) is det. combine_constraint_list_results(error(Msg, Term), _, error(Msg, Term)). combine_constraint_list_results(ok(_, _), error(Msg, Term), error(Msg, Term)). combine_constraint_list_results(ok(CC0, IC0), ok(CC1, IC1), - ok(CC0 ++ CC1, IC0 `map__merge` IC1)). + ok(CC0 ++ CC1, IC0 `map__merge` IC1)). :- pred get_existential_constraints_from_term(module_name::in, - term::in, term::out, maybe1(list(prog_constraint))::out) is det. + term::in, term::out, maybe1(list(prog_constraint))::out) is det. get_existential_constraints_from_term(ModuleName, !PredType, - MaybeExistentialConstraints) :- - ( - !.PredType = term__functor(term__atom("=>"), - [!:PredType, ExistentialConstraints], _) - -> - parse_class_constraints(ModuleName, ExistentialConstraints, - MaybeExistentialConstraints) - ; - MaybeExistentialConstraints = ok([]) - ). + MaybeExistentialConstraints) :- + ( + !.PredType = term__functor(term__atom("=>"), + [!:PredType, ExistentialConstraints], _) + -> + parse_class_constraints(ModuleName, ExistentialConstraints, + MaybeExistentialConstraints) + ; + MaybeExistentialConstraints = ok([]) + ). %-----------------------------------------------------------------------------% - % Verify that among the arguments of a :- pred declaration, - % either all arguments specify a mode or none of them do. - + % Verify that among the arguments of a :- pred declaration, + % either all arguments specify a mode or none of them do. + % :- pred verify_type_and_mode_list(list(type_and_mode)::in) is semidet. verify_type_and_mode_list([]). verify_type_and_mode_list([First | Rest]) :- - verify_type_and_mode_list_2(Rest, First). + verify_type_and_mode_list_2(Rest, First). :- pred verify_type_and_mode_list_2(list(type_and_mode)::in, type_and_mode::in) - is semidet. + is semidet. verify_type_and_mode_list_2([], _). verify_type_and_mode_list_2([Head | Tail], First) :- - ( - Head = type_only(_), - First = type_only(_) - ; - Head = type_and_mode(_, _), - First = type_and_mode(_, _) - ), - verify_type_and_mode_list_2(Tail, First). + ( + Head = type_only(_), + First = type_only(_) + ; + Head = type_and_mode(_, _), + First = type_and_mode(_, _) + ), + verify_type_and_mode_list_2(Tail, First). %-----------------------------------------------------------------------------% - % parse a `:- func p(...)' declaration - + % Parse a `:- func p(...)' declaration. + % :- pred process_func(module_name::in, varset::in, term::in, condition::in, - maybe(determinism)::in, decl_attrs::in, maybe1(item)::out) is det. + maybe(determinism)::in, decl_attrs::in, maybe1(item)::out) is det. process_func(ModuleName, VarSet, Term, Cond, MaybeDet, Attributes0, Result) :- - get_class_context_and_inst_constraints(ModuleName, Attributes0, - Attributes, MaybeContext), - ( - MaybeContext = ok(ExistQVars, Constraints, InstConstraints), - process_func_2(ModuleName, VarSet, Term, - Cond, MaybeDet, ExistQVars, Constraints, - InstConstraints, Attributes, Result) - ; - MaybeContext = error(String, ErrorTerm), - Result = error(String, ErrorTerm) - ). + get_class_context_and_inst_constraints(ModuleName, Attributes0, + Attributes, MaybeContext), + ( + MaybeContext = ok(ExistQVars, Constraints, InstConstraints), + process_func_2(ModuleName, VarSet, Term, Cond, MaybeDet, ExistQVars, + Constraints, InstConstraints, Attributes, Result) + ; + MaybeContext = error(String, ErrorTerm), + Result = error(String, ErrorTerm) + ). :- pred process_func_2(module_name::in, varset::in, term::in, condition::in, - maybe(determinism)::in, existq_tvars::in, prog_constraints::in, - inst_var_sub::in, decl_attrs::in, maybe1(item)::out) is det. + maybe(determinism)::in, existq_tvars::in, prog_constraints::in, + inst_var_sub::in, decl_attrs::in, maybe1(item)::out) is det. -process_func_2(ModuleName, VarSet, Term, Cond, MaybeDet, - ExistQVars, Constraints, InstConstraints, Attributes, - Result) :- - ( - Term = term__functor(term__atom("="), - [FuncTerm0, ReturnTypeTerm], _Context), - FuncTerm = desugar_field_access(FuncTerm0) - -> - parse_implicitly_qualified_term(ModuleName, FuncTerm, Term, - "`:- func' declaration", R), - process_func_3(R, FuncTerm, ReturnTypeTerm, Term, VarSet, - MaybeDet, Cond, ExistQVars, Constraints, - InstConstraints, Attributes, Result) - ; - Result = error("`=' expected in `:- func' declaration", Term) - ). +process_func_2(ModuleName, VarSet, Term, Cond, MaybeDet, ExistQVars, + Constraints, InstConstraints, Attributes, Result) :- + ( + Term = term__functor(term__atom("="), + [FuncTerm0, ReturnTypeTerm], _Context), + FuncTerm = desugar_field_access(FuncTerm0) + -> + parse_implicitly_qualified_term(ModuleName, FuncTerm, Term, + "`:- func' declaration", R), + process_func_3(R, FuncTerm, ReturnTypeTerm, Term, VarSet, MaybeDet, + Cond, ExistQVars, Constraints, InstConstraints, Attributes, Result) + ; + Result = error("`=' expected in `:- func' declaration", Term) + ). :- pred process_func_3(maybe_functor::in, term::in, term::in, term::in, - varset::in, maybe(determinism)::in, condition::in, existq_tvars::in, - prog_constraints::in, inst_var_sub::in, decl_attrs::in, - maybe1(item)::out) is det. + varset::in, maybe(determinism)::in, condition::in, existq_tvars::in, + prog_constraints::in, inst_var_sub::in, decl_attrs::in, + maybe1(item)::out) is det. process_func_3(ok(F, As0), FuncTerm, ReturnTypeTerm, FullTerm, VarSet0, - MaybeDet, Cond, ExistQVars, ClassContext, InstConstraints, - Attributes0, Result) :- - ( convert_type_and_mode_list(InstConstraints, As0, As) -> - ( - \+ verify_type_and_mode_list(As) - -> - Result = error("some but not all arguments have modes", - FuncTerm) - ; - convert_type_and_mode(InstConstraints, ReturnTypeTerm, - ReturnType) - -> - ( - As = [type_and_mode(_, _) | _], - ReturnType = type_only(_) - -> - Result = error("function arguments have " ++ - "modes, but function result doesn't", - FuncTerm) - ; - As = [type_only(_) | _], - ReturnType = type_and_mode(_, _) - -> - Result = error("function result has mode, " ++ - "but function arguments don't", - FuncTerm) - ; - get_purity(Purity, Attributes0, Attributes), - varset__coerce(VarSet0, TVarSet), - varset__coerce(VarSet0, IVarSet), - list__append(As, [ReturnType], Args), - ( - inst_var_constraints_are_consistent_in_type_and_modes(Args) - -> - Result0 = ok(pred_or_func(TVarSet, - IVarSet, ExistQVars, - function, F, Args, no, no, - MaybeDet, Cond, Purity, - ClassContext)), - check_no_attributes(Result0, - Attributes, Result) - ; - Result = error("inconsistent " ++ - "constraints on inst " ++ - "variables in function " ++ - "declaration", FullTerm) - ) - ) - ; - Result = error("syntax error in return type of " ++ - "`:- func' declaration", ReturnTypeTerm) - ) - ; - Result = error("syntax error in arguments of `:- func' " ++ - "declaration", FuncTerm) - ). + MaybeDet, Cond, ExistQVars, ClassContext, InstConstraints, + Attributes0, Result) :- + ( convert_type_and_mode_list(InstConstraints, As0, As) -> + ( + \+ verify_type_and_mode_list(As) + -> + Result = error("some but not all arguments have modes", FuncTerm) + ; + convert_type_and_mode(InstConstraints, ReturnTypeTerm, ReturnType) + -> + ( + As = [type_and_mode(_, _) | _], + ReturnType = type_only(_) + -> + Result = error("function arguments have modes, " ++ + "but function result doesn't", FuncTerm) + ; + As = [type_only(_) | _], + ReturnType = type_and_mode(_, _) + -> + Result = error("function result has mode, " ++ + "but function arguments don't", + FuncTerm) + ; + get_purity(Purity, Attributes0, Attributes), + varset__coerce(VarSet0, TVarSet), + varset__coerce(VarSet0, IVarSet), + list__append(As, [ReturnType], Args), + ( + inst_var_constraints_are_consistent_in_type_and_modes(Args) + -> + Result0 = ok(pred_or_func(TVarSet, IVarSet, ExistQVars, + function, F, Args, no, no, MaybeDet, Cond, Purity, + ClassContext)), + check_no_attributes(Result0, Attributes, Result) + ; + Result = error("inconsistent constraints on inst " ++ + "variables in function declaration", FullTerm) + ) + ) + ; + Result = error("syntax error in return type of " ++ + "`:- func' declaration", ReturnTypeTerm) + ) + ; + Result = error("syntax error in arguments of `:- func' " ++ + "declaration", FuncTerm) + ). process_func_3(error(M, T), _, _, _, _, _, _, _, _, _, _, error(M, T)). %-----------------------------------------------------------------------------% - % Perform one of the following field-access syntax rewrites if - % possible: - % - % A ^ f(B, ...) ---> f(B, ..., A) - % (A ^ f(B, ...) := X) ---> 'f :='(B, ..., A, X) - % + % Perform one of the following field-access syntax rewrites if possible: + % + % A ^ f(B, ...) ---> f(B, ..., A) + % (A ^ f(B, ...) := X) ---> 'f :='(B, ..., A, X) + % :- func desugar_field_access(term) = term. desugar_field_access(Term) = - ( - Term = functor(atom("^"), [A, RHS], _), - RHS = functor(atom(FieldName), Bs, Context) - -> - functor(atom(FieldName), Bs ++ [A], Context) - ; - Term = functor(atom(":="), [LHS, X], _), - LHS = functor(atom("^"), [A, RHS], Context), - RHS = functor(atom(FieldName), Bs, Context) - -> - functor(atom(FieldName ++ " :="), Bs ++ [A, X], Context) - ; - Term - ). + ( + Term = functor(atom("^"), [A, RHS], _), + RHS = functor(atom(FieldName), Bs, Context) + -> + functor(atom(FieldName), Bs ++ [A], Context) + ; + Term = functor(atom(":="), [LHS, X], _), + LHS = functor(atom("^"), [A, RHS], Context), + RHS = functor(atom(FieldName), Bs, Context) + -> + functor(atom(FieldName ++ " :="), Bs ++ [A, X], Context) + ; + Term + ). %-----------------------------------------------------------------------------% - % parse a `:- mode p(...)' declaration - % + % Parse a `:- mode p(...)' declaration. + % :- pred process_mode(module_name::in, varset::in, term::in, condition::in, - decl_attrs::in, maybe(inst)::in, maybe(determinism)::in, - maybe1(item)::out) is det. + decl_attrs::in, maybe(inst)::in, maybe(determinism)::in, + maybe1(item)::out) is det. process_mode(ModuleName, VarSet, Term, Cond, Attributes, WithInst, MaybeDet, - Result) :- - ( - WithInst = no, - Term = term__functor(term__atom("="), - [FuncTerm0, ReturnTypeTerm], _Context), - FuncTerm = desugar_field_access(FuncTerm0) - -> - parse_implicitly_qualified_term(ModuleName, FuncTerm, Term, - "function `:- mode' declaration", R), - process_func_mode(R, ModuleName, FuncTerm, ReturnTypeTerm, - Term, VarSet, MaybeDet, Cond, Attributes, Result) - ; - parse_implicitly_qualified_term(ModuleName, Term, Term, - "`:- mode' declaration", R), - process_pred_or_func_mode(R, ModuleName, Term, VarSet, - WithInst, MaybeDet, Cond, Attributes, Result) - ). + Result) :- + ( + WithInst = no, + Term = term__functor(term__atom("="), [FuncTerm0, ReturnTypeTerm], + _Context), + FuncTerm = desugar_field_access(FuncTerm0) + -> + parse_implicitly_qualified_term(ModuleName, FuncTerm, Term, + "function `:- mode' declaration", R), + process_func_mode(R, ModuleName, FuncTerm, ReturnTypeTerm, + Term, VarSet, MaybeDet, Cond, Attributes, Result) + ; + parse_implicitly_qualified_term(ModuleName, Term, Term, + "`:- mode' declaration", R), + process_pred_or_func_mode(R, ModuleName, Term, VarSet, + WithInst, MaybeDet, Cond, Attributes, Result) + ). :- pred process_pred_or_func_mode(maybe_functor::in, module_name::in, term::in, - varset::in, maybe(inst)::in, maybe(determinism)::in, condition::in, - decl_attrs::in, maybe1(item)::out) is det. + varset::in, maybe(inst)::in, maybe(determinism)::in, condition::in, + decl_attrs::in, maybe1(item)::out) is det. process_pred_or_func_mode(ok(F, As0), ModuleName, PredMode, VarSet0, WithInst, - MaybeDet, Cond, Attributes0, Result) :- - ( - convert_mode_list(allow_constrained_inst_var, As0, As1) - -> - get_class_context_and_inst_constraints(ModuleName, Attributes0, - Attributes, MaybeConstraints), - ( - MaybeConstraints = ok(_, _, InstConstraints), - list__map(constrain_inst_vars_in_mode(InstConstraints), - As1, As), - varset__coerce(VarSet0, VarSet), - ( inst_var_constraints_are_consistent_in_modes(As) -> - ( - WithInst = no, - PredOrFunc = yes(predicate) - ; - WithInst = yes(_), - % We don't know whether it's a - % predicate or a function until we - % expand out the inst. - PredOrFunc = no - ), - Result0 = ok(pred_or_func_mode(VarSet, - PredOrFunc, F, As, WithInst, MaybeDet, - Cond)) - ; - Result0 = error("inconsistent constraints " ++ - "on inst variables in predicate " ++ - "mode declaration", PredMode) - ) - ; - MaybeConstraints = error(String, Term), - Result0 = error(String, Term) - ), - check_no_attributes(Result0, Attributes, Result) - ; - Result = error("syntax error in mode declaration", PredMode) - ). + MaybeDet, Cond, Attributes0, Result) :- + ( + convert_mode_list(allow_constrained_inst_var, As0, As1) + -> + get_class_context_and_inst_constraints(ModuleName, Attributes0, + Attributes, MaybeConstraints), + ( + MaybeConstraints = ok(_, _, InstConstraints), + list__map(constrain_inst_vars_in_mode(InstConstraints), + As1, As), + varset__coerce(VarSet0, VarSet), + ( inst_var_constraints_are_consistent_in_modes(As) -> + ( + WithInst = no, + PredOrFunc = yes(predicate) + ; + WithInst = yes(_), + % We don't know whether it's a predicate or a function + % until we expand out the inst. + PredOrFunc = no + ), + Result0 = ok(pred_or_func_mode(VarSet, PredOrFunc, F, As, + WithInst, MaybeDet, Cond)) + ; + Result0 = error("inconsistent constraints " ++ + "on inst variables in predicate " ++ + "mode declaration", PredMode) + ) + ; + MaybeConstraints = error(String, Term), + Result0 = error(String, Term) + ), + check_no_attributes(Result0, Attributes, Result) + ; + Result = error("syntax error in mode declaration", PredMode) + ). process_pred_or_func_mode(error(M, T), _, _, _, _, _, _, _, error(M, T)). :- pred process_func_mode(maybe_functor::in, module_name::in, term::in, - term::in, term::in, varset::in, maybe(determinism)::in, condition::in, - decl_attrs::in, maybe1(item)::out) is det. + term::in, term::in, varset::in, maybe(determinism)::in, condition::in, + decl_attrs::in, maybe1(item)::out) is det. process_func_mode(ok(F, As0), ModuleName, FuncMode, RetMode0, FullTerm, - VarSet0, MaybeDet, Cond, Attributes0, Result) :- - ( - convert_mode_list(allow_constrained_inst_var, As0, As1) - -> - get_class_context_and_inst_constraints(ModuleName, Attributes0, - Attributes, MaybeConstraints), - ( - MaybeConstraints = ok(_, _, InstConstraints), - list__map(constrain_inst_vars_in_mode(InstConstraints), - As1, As), - ( - convert_mode(allow_constrained_inst_var, - RetMode0, RetMode1) - -> - constrain_inst_vars_in_mode(InstConstraints, - RetMode1, RetMode), - varset__coerce(VarSet0, VarSet), - list__append(As, [RetMode], ArgModes), - ( inst_var_constraints_are_consistent_in_modes(ArgModes) -> - Result0 = ok(pred_or_func_mode(VarSet, - yes(function), F, ArgModes, - no, MaybeDet, Cond)) - ; - Result0 = error("inconsistent " ++ - "constraints on inst " ++ - "variables in function " ++ - "mode declaration", FullTerm) - ) - ; - Result0 = error("syntax error in return " ++ - "mode of function mode declaration", - RetMode0) - ) - ; - MaybeConstraints = error(String, Term), - Result0 = error(String, Term) - ), - check_no_attributes(Result0, Attributes, Result) - ; - Result = error("syntax error in arguments of function " ++ - "mode declaration", FuncMode) - ). + VarSet0, MaybeDet, Cond, Attributes0, Result) :- + ( + convert_mode_list(allow_constrained_inst_var, As0, As1) + -> + get_class_context_and_inst_constraints(ModuleName, Attributes0, + Attributes, MaybeConstraints), + ( + MaybeConstraints = ok(_, _, InstConstraints), + list__map(constrain_inst_vars_in_mode(InstConstraints), As1, As), + ( + convert_mode(allow_constrained_inst_var, RetMode0, RetMode1) + -> + constrain_inst_vars_in_mode(InstConstraints, + RetMode1, RetMode), + varset__coerce(VarSet0, VarSet), + list__append(As, [RetMode], ArgModes), + ( inst_var_constraints_are_consistent_in_modes(ArgModes) -> + Result0 = ok(pred_or_func_mode(VarSet, yes(function), F, + ArgModes, no, MaybeDet, Cond)) + ; + Result0 = error("inconsistent " ++ + "constraints on inst " ++ + "variables in function " ++ + "mode declaration", FullTerm) + ) + ; + Result0 = error("syntax error in return mode " ++ + "of function mode declaration", RetMode0) + ) + ; + MaybeConstraints = error(String, Term), + Result0 = error(String, Term) + ), + check_no_attributes(Result0, Attributes, Result) + ; + Result = error("syntax error in arguments of function " ++ + "mode declaration", FuncMode) + ). process_func_mode(error(M, T), _, _, _, _, _, _, _, _, error(M, T)). %-----------------------------------------------------------------------------% constrain_inst_vars_in_mode(Mode0, Mode) :- - constrain_inst_vars_in_mode(map__init, Mode0, Mode). + constrain_inst_vars_in_mode(map__init, Mode0, Mode). constrain_inst_vars_in_mode(InstConstraints, I0 -> F0, I -> F) :- - constrain_inst_vars_in_inst(InstConstraints, I0, I), - constrain_inst_vars_in_inst(InstConstraints, F0, F). + constrain_inst_vars_in_inst(InstConstraints, I0, I), + constrain_inst_vars_in_inst(InstConstraints, F0, F). constrain_inst_vars_in_mode(InstConstraints, user_defined_mode(Name, Args0), - user_defined_mode(Name, Args)) :- - list__map(constrain_inst_vars_in_inst(InstConstraints), Args0, Args). + user_defined_mode(Name, Args)) :- + list__map(constrain_inst_vars_in_inst(InstConstraints), Args0, Args). :- pred constrain_inst_vars_in_inst(inst_var_sub::in, (inst)::in, (inst)::out) - is det. + is det. constrain_inst_vars_in_inst(_, any(U), any(U)). constrain_inst_vars_in_inst(_, free, free). constrain_inst_vars_in_inst(_, free(T), free(T)). constrain_inst_vars_in_inst(InstConstraints, bound(U, BIs0), bound(U, BIs)) :- - list__map((pred(functor(C, Is0)::in, functor(C, Is)::out) is det :- - list__map(constrain_inst_vars_in_inst(InstConstraints), - Is0, Is)), - BIs0, BIs). + list__map((pred(functor(C, Is0)::in, functor(C, Is)::out) is det :- + list__map(constrain_inst_vars_in_inst(InstConstraints), Is0, Is)), + BIs0, BIs). constrain_inst_vars_in_inst(_, ground(U, none), ground(U, none)). constrain_inst_vars_in_inst(InstConstraints, - ground(U, higher_order(PredInstInfo0)), - ground(U, higher_order(PredInstInfo))) :- - constrain_inst_vars_in_pred_inst_info(InstConstraints, PredInstInfo0, - PredInstInfo). + ground(U, higher_order(PredInstInfo0)), + ground(U, higher_order(PredInstInfo))) :- + constrain_inst_vars_in_pred_inst_info(InstConstraints, PredInstInfo0, + PredInstInfo). constrain_inst_vars_in_inst(InstConstraints, - constrained_inst_vars(Vars0, Inst0), - constrained_inst_vars(Vars, Inst)) :- - constrain_inst_vars_in_inst(InstConstraints, Inst0, Inst1), - ( Inst1 = constrained_inst_vars(Vars2, Inst2) -> - Vars = Vars0 `set__union` Vars2, - Inst = Inst2 - ; - Vars = Vars0, - Inst = Inst1 - ). + constrained_inst_vars(Vars0, Inst0), + constrained_inst_vars(Vars, Inst)) :- + constrain_inst_vars_in_inst(InstConstraints, Inst0, Inst1), + ( Inst1 = constrained_inst_vars(Vars2, Inst2) -> + Vars = Vars0 `set__union` Vars2, + Inst = Inst2 + ; + Vars = Vars0, + Inst = Inst1 + ). constrain_inst_vars_in_inst(_, not_reached, not_reached). constrain_inst_vars_in_inst(InstConstraints, inst_var(Var), - constrained_inst_vars(set__make_singleton_set(Var), Inst)) :- - ( map__search(InstConstraints, Var, Inst0) -> - Inst = Inst0 - ; - Inst = ground(shared, none) - ). + constrained_inst_vars(set__make_singleton_set(Var), Inst)) :- + ( map__search(InstConstraints, Var, Inst0) -> + Inst = Inst0 + ; + Inst = ground(shared, none) + ). constrain_inst_vars_in_inst(InstConstraints, defined_inst(Name0), - defined_inst(Name)) :- - constrain_inst_vars_in_inst_name(InstConstraints, Name0, Name). + defined_inst(Name)) :- + constrain_inst_vars_in_inst_name(InstConstraints, Name0, Name). constrain_inst_vars_in_inst(InstConstraints, abstract_inst(N, Is0), - abstract_inst(N, Is)) :- - list__map(constrain_inst_vars_in_inst(InstConstraints), Is0, Is). + abstract_inst(N, Is)) :- + list__map(constrain_inst_vars_in_inst(InstConstraints), Is0, Is). :- pred constrain_inst_vars_in_pred_inst_info(inst_var_sub::in, - pred_inst_info::in, pred_inst_info::out) is det. + pred_inst_info::in, pred_inst_info::out) is det. constrain_inst_vars_in_pred_inst_info(InstConstraints, PII0, PII) :- - PII0 = pred_inst_info(PredOrFunc, Modes0, Det), - list__map(constrain_inst_vars_in_mode(InstConstraints), Modes0, Modes), - PII = pred_inst_info(PredOrFunc, Modes, Det). + PII0 = pred_inst_info(PredOrFunc, Modes0, Det), + list__map(constrain_inst_vars_in_mode(InstConstraints), Modes0, Modes), + PII = pred_inst_info(PredOrFunc, Modes, Det). :- pred constrain_inst_vars_in_inst_name(inst_var_sub::in, - inst_name::in, inst_name::out) is det. + inst_name::in, inst_name::out) is det. constrain_inst_vars_in_inst_name(InstConstraints, Name0, Name) :- - ( Name0 = user_inst(SymName, Args0) -> - list__map(constrain_inst_vars_in_inst(InstConstraints), - Args0, Args), - Name = user_inst(SymName, Args) - ; - Name = Name0 - ). + ( Name0 = user_inst(SymName, Args0) -> + list__map(constrain_inst_vars_in_inst(InstConstraints), Args0, Args), + Name = user_inst(SymName, Args) + ; + Name = Name0 + ). %-----------------------------------------------------------------------------% inst_var_constraints_are_consistent_in_modes(Modes) :- - inst_var_constraints_are_consistent_in_modes(Modes, map__init, _). + inst_var_constraints_are_consistent_in_modes(Modes, map__init, _). :- pred inst_var_constraints_are_consistent_in_modes(list(mode)::in, - inst_var_sub::in, inst_var_sub::out) is semidet. + inst_var_sub::in, inst_var_sub::out) is semidet. inst_var_constraints_are_consistent_in_modes(Modes, !Sub) :- - list__foldl(inst_var_constraints_are_consistent_in_mode, Modes, !Sub). + list__foldl(inst_var_constraints_are_consistent_in_mode, Modes, !Sub). :- pred inst_var_constraints_are_consistent_in_type_and_modes( - list(type_and_mode)::in) is semidet. + list(type_and_mode)::in) is semidet. inst_var_constraints_are_consistent_in_type_and_modes(TypeAndModes) :- - list__foldl((pred(TypeAndMode::in, in, out) is semidet --> - ( { TypeAndMode = type_only(_) } - ; { TypeAndMode = type_and_mode(_, Mode) }, - inst_var_constraints_are_consistent_in_mode(Mode) - )), TypeAndModes, map__init, _). + list__foldl((pred(TypeAndMode::in, in, out) is semidet --> + ( { TypeAndMode = type_only(_) } + ; { TypeAndMode = type_and_mode(_, Mode) }, + inst_var_constraints_are_consistent_in_mode(Mode) + )), TypeAndModes, map__init, _). :- pred inst_var_constraints_are_consistent_in_mode((mode)::in, - inst_var_sub::in, inst_var_sub::out) is semidet. + inst_var_sub::in, inst_var_sub::out) is semidet. inst_var_constraints_are_consistent_in_mode(InitialInst -> FinalInst, !Sub) :- - inst_var_constraints_are_consistent_in_inst(InitialInst, !Sub), - inst_var_constraints_are_consistent_in_inst(FinalInst, !Sub). + inst_var_constraints_are_consistent_in_inst(InitialInst, !Sub), + inst_var_constraints_are_consistent_in_inst(FinalInst, !Sub). inst_var_constraints_are_consistent_in_mode(user_defined_mode(_, ArgInsts), - !Sub) :- - inst_var_constraints_are_consistent_in_insts(ArgInsts, !Sub). + !Sub) :- + inst_var_constraints_are_consistent_in_insts(ArgInsts, !Sub). :- pred inst_var_constraints_are_consistent_in_insts(list(inst)::in, - inst_var_sub::in, inst_var_sub::out) is semidet. + inst_var_sub::in, inst_var_sub::out) is semidet. inst_var_constraints_are_consistent_in_insts(Insts, !Sub) :- - list__foldl(inst_var_constraints_are_consistent_in_inst, Insts, !Sub). + list__foldl(inst_var_constraints_are_consistent_in_inst, Insts, !Sub). :- pred inst_var_constraints_are_consistent_in_inst((inst)::in, - inst_var_sub::in, inst_var_sub::out) is semidet. + inst_var_sub::in, inst_var_sub::out) is semidet. inst_var_constraints_are_consistent_in_inst(any(_), !Sub). inst_var_constraints_are_consistent_in_inst(free, !Sub). inst_var_constraints_are_consistent_in_inst(free(_), !Sub). inst_var_constraints_are_consistent_in_inst(bound(_, BoundInsts), !Sub) :- - list__foldl((pred(functor(_, Insts)::in, in, out) is semidet --> - inst_var_constraints_are_consistent_in_insts(Insts)), - BoundInsts, !Sub). + list__foldl((pred(functor(_, Insts)::in, in, out) is semidet --> + inst_var_constraints_are_consistent_in_insts(Insts)), + BoundInsts, !Sub). inst_var_constraints_are_consistent_in_inst(ground(_, GroundInstInfo), !Sub) :- - ( - GroundInstInfo = none - ; - GroundInstInfo = higher_order(pred_inst_info(_, Modes, _)), - inst_var_constraints_are_consistent_in_modes(Modes, !Sub) - ). + ( + GroundInstInfo = none + ; + GroundInstInfo = higher_order(pred_inst_info(_, Modes, _)), + inst_var_constraints_are_consistent_in_modes(Modes, !Sub) + ). inst_var_constraints_are_consistent_in_inst(not_reached, !Sub). inst_var_constraints_are_consistent_in_inst(inst_var(_), !Sub) :- - error("inst_var_constraints_are_consistent_in_inst: " ++ - "unconstrained inst_var"). + error("inst_var_constraints_are_consistent_in_inst: " ++ + "unconstrained inst_var"). inst_var_constraints_are_consistent_in_inst(defined_inst(InstName), !Sub) :- - ( InstName = user_inst(_, Insts) -> - inst_var_constraints_are_consistent_in_insts(Insts, !Sub) - ; - true - ). + ( InstName = user_inst(_, Insts) -> + inst_var_constraints_are_consistent_in_insts(Insts, !Sub) + ; + true + ). inst_var_constraints_are_consistent_in_inst(abstract_inst(_, Insts), !Sub) :- - inst_var_constraints_are_consistent_in_insts(Insts, !Sub). + inst_var_constraints_are_consistent_in_insts(Insts, !Sub). inst_var_constraints_are_consistent_in_inst( - constrained_inst_vars(InstVars, Inst), !Sub) :- - set__fold((pred(InstVar::in, in, out) is semidet --> - ( Inst0 =^ map__elem(InstVar) -> - % Check that the inst_var constraint is consistent with - % the previous constraint on this inst_var. - { Inst = Inst0 } - ; - ^ map__elem(InstVar) := Inst - )), InstVars, !Sub), - inst_var_constraints_are_consistent_in_inst(Inst, !Sub). + constrained_inst_vars(InstVars, Inst), !Sub) :- + set__fold((pred(InstVar::in, in, out) is semidet --> + ( Inst0 =^ map__elem(InstVar) -> + % Check that the inst_var constraint is consistent with + % the previous constraint on this inst_var. + { Inst = Inst0 } + ; + ^ map__elem(InstVar) := Inst + )), InstVars, !Sub), + inst_var_constraints_are_consistent_in_inst(Inst, !Sub). %-----------------------------------------------------------------------------% - % Parse a `:- inst .' declaration. - % + % Parse a `:- inst .' declaration. + % :- pred parse_inst_decl(module_name::in, varset::in, term::in, - maybe1(item)::out) is det. + maybe1(item)::out) is det. parse_inst_decl(ModuleName, VarSet, InstDefn, Result) :- - ( - InstDefn = term__functor(term__atom(Op), [H, B], _Context), - Op = "==" - -> - get_condition(B, Body, Condition), - convert_inst_defn(ModuleName, H, Body, R), - process_maybe1(make_inst_defn(VarSet, Condition), R, Result) - ; - % XXX this is for `abstract inst' declarations, - % which are not really supported - InstDefn = term__functor(term__atom("is"), - [Head, term__functor(term__atom("private"), [], _)], _) - -> - Condition = true, - convert_abstract_inst_defn(ModuleName, Head, R), - process_maybe1(make_inst_defn(VarSet, Condition), R, Result) - ; - InstDefn = term__functor(term__atom("--->"), [H, B], Context) - -> - get_condition(B, Body, Condition), - Body1 = term__functor(term__atom("bound"), [Body], Context), - convert_inst_defn(ModuleName, H, Body1, R), - process_maybe1(make_inst_defn(VarSet, Condition), R, Result) - ; - Result = error("`==' expected in `:- inst' definition", - InstDefn) - ). - % we should check the condition for errs - % (don't bother at the moment, since we ignore - % conditions anyhow :-) + ( + InstDefn = term__functor(term__atom(Op), [H, B], _Context), + Op = "==" + -> + get_condition(B, Body, Condition), + convert_inst_defn(ModuleName, H, Body, R), + process_maybe1(make_inst_defn(VarSet, Condition), R, Result) + ; + % XXX This is for `abstract inst' declarations, + % which are not really supported. + InstDefn = term__functor(term__atom("is"), + [Head, term__functor(term__atom("private"), [], _)], _) + -> + Condition = true, + convert_abstract_inst_defn(ModuleName, Head, R), + process_maybe1(make_inst_defn(VarSet, Condition), R, Result) + ; + InstDefn = term__functor(term__atom("--->"), [H, B], Context) + -> + get_condition(B, Body, Condition), + Body1 = term__functor(term__atom("bound"), [Body], Context), + convert_inst_defn(ModuleName, H, Body1, R), + % We should check the condition for errs (don't bother at the moment, + % since we ignore conditions anyhow :-) + process_maybe1(make_inst_defn(VarSet, Condition), R, Result) + ; + Result = error("`==' expected in `:- inst' definition", InstDefn) + ). - % Parse a `:- inst ---> .' definition. - % + % Parse a `:- inst ---> .' definition. + % :- pred convert_inst_defn(module_name::in, term::in, term::in, - maybe1(processed_inst_body)::out) is det. + maybe1(processed_inst_body)::out) is det. convert_inst_defn(ModuleName, Head, Body, Result) :- - parse_implicitly_qualified_term(ModuleName, - Head, Body, "inst definition", R), - convert_inst_defn_2(R, Head, Body, Result). + parse_implicitly_qualified_term(ModuleName, Head, Body, + "inst definition", R), + convert_inst_defn_2(R, Head, Body, Result). :- pred convert_inst_defn_2(maybe_functor::in, term::in, term::in, - maybe1(processed_inst_body)::out) is det. + maybe1(processed_inst_body)::out) is det. convert_inst_defn_2(error(M, T), _, _, error(M, T)). convert_inst_defn_2(ok(Name, ArgTerms), Head, Body, Result) :- - ( - % check that all the head args are variables - term__var_list_to_term_list(Args, ArgTerms) - -> - ( - % check that all the head arg variables are distinct - list__member(Arg2, Args, [Arg2|OtherArgs]), - list__member(Arg2, OtherArgs) - -> - Result = error( - "repeated inst parameters in LHS of inst defn", - Head) - ; - % check that all the variables in the body occur - % in the head - term__contains_var(Body, Var2), - \+ list__member(Var2, Args) - -> - Result = error( - "free inst parameter in RHS of inst definition", - Body) - ; - % check that the inst is a valid user-defined - % inst, i.e. that it does not have the form of - % one of the builtin insts - \+ ( - convert_inst(no_allow_constrained_inst_var, - Head, UserInst), - UserInst = defined_inst(user_inst(_, _)) - ) - -> - Result = error("attempt to redefine builtin inst", Head) - ; - % should improve the error message here - ( - convert_inst(no_allow_constrained_inst_var, - Body, ConvertedBody) - -> - list__map(term__coerce_var, Args, InstArgs), - Result = ok( - processed_inst_body(Name, InstArgs, - eqv_inst(ConvertedBody))) - ; - Result = error("syntax error in inst body", - Body) - ) - ) - ; - Result = error("inst parameters must be variables", Head) - ). + ( + % Check that all the head args are variables. + term__var_list_to_term_list(Args, ArgTerms) + -> + ( + % Check that all the head arg variables are distinct. + list__member(Arg2, Args, [Arg2|OtherArgs]), + list__member(Arg2, OtherArgs) + -> + Result = error("repeated inst parameters in LHS of inst defn", + Head) + ; + % Check that all the variables in the body occur in the head. + term__contains_var(Body, Var2), + \+ list__member(Var2, Args) + -> + Result = error("free inst parameter in RHS of inst definition", + Body) + ; + % Check that the inst is a valid user-defined inst, i.e. that it + % does not have the form of one of the builtin insts. + \+ ( + convert_inst(no_allow_constrained_inst_var, Head, UserInst), + UserInst = defined_inst(user_inst(_, _)) + ) + -> + Result = error("attempt to redefine builtin inst", Head) + ; + % Should improve the error message here. + ( + convert_inst(no_allow_constrained_inst_var, Body, + ConvertedBody) + -> + list__map(term__coerce_var, Args, InstArgs), + Result = ok(processed_inst_body(Name, InstArgs, + eqv_inst(ConvertedBody))) + ; + Result = error("syntax error in inst body", Body) + ) + ) + ; + Result = error("inst parameters must be variables", Head) + ). :- type processed_inst_body - ---> processed_inst_body( - sym_name, - list(inst_var), - inst_defn - ). + ---> processed_inst_body( + sym_name, + list(inst_var), + inst_defn + ). :- pred convert_abstract_inst_defn(module_name::in, term::in, - maybe1(processed_inst_body)::out) is det. + maybe1(processed_inst_body)::out) is det. convert_abstract_inst_defn(ModuleName, Head, Result) :- - parse_implicitly_qualified_term(ModuleName, Head, Head, - "inst definition", R), - convert_abstract_inst_defn_2(R, Head, Result). + parse_implicitly_qualified_term(ModuleName, Head, Head, + "inst definition", R), + convert_abstract_inst_defn_2(R, Head, Result). :- pred convert_abstract_inst_defn_2(maybe_functor::in, term::in, - maybe1(processed_inst_body)::out) is det. + maybe1(processed_inst_body)::out) is det. convert_abstract_inst_defn_2(error(M, T), _, error(M, T)). convert_abstract_inst_defn_2(ok(Name, ArgTerms), Head, Result) :- - ( - % check that all the head args are variables - term__var_list_to_term_list(Args, ArgTerms) - -> - ( - % check that all the head arg variables are distinct - list__member(Arg2, Args, [Arg2|OtherArgs]), - list__member(Arg2, OtherArgs) - -> - Result = error( - "repeated inst parameters in abstract inst definition", - Head) - ; - list__map(term__coerce_var, Args, InstArgs), - Result = ok(processed_inst_body(Name, InstArgs, - abstract_inst)) - ) - ; - Result = error("inst parameters must be variables", Head) - ). + ( + % Check that all the head args are variables. + term__var_list_to_term_list(Args, ArgTerms) + -> + ( + % Check that all the head arg variables are distinct. + list__member(Arg2, Args, [Arg2|OtherArgs]), + list__member(Arg2, OtherArgs) + -> + Result = error("repeated inst parameters " ++ + "in abstract inst definition", Head) + ; + list__map(term__coerce_var, Args, InstArgs), + Result = ok(processed_inst_body(Name, InstArgs, abstract_inst)) + ) + ; + Result = error("inst parameters must be variables", Head) + ). :- pred make_inst_defn(varset::in, condition::in, processed_inst_body::in, - item::out) is det. + item::out) is det. make_inst_defn(VarSet0, Cond, processed_inst_body(Name, Params, InstDefn), - inst_defn(VarSet, Name, Params, InstDefn, Cond)) :- - varset__coerce(VarSet0, VarSet). + inst_defn(VarSet, Name, Params, InstDefn, Cond)) :- + varset__coerce(VarSet0, VarSet). %-----------------------------------------------------------------------------% - % Parse a `:- mode foo == ...' definition. - % + % Parse a `:- mode foo == ...' definition. + % :- pred parse_mode_decl(module_name::in, varset::in, term::in, decl_attrs::in, - maybe1(item)::out) is det. + maybe1(item)::out) is det. parse_mode_decl(ModuleName, VarSet, ModeDefn, Attributes, Result) :- - ( %%% some [H, B] - mode_op(ModeDefn, H, B) - -> - get_condition(B, Body, Condition), - convert_mode_defn(ModuleName, H, Body, R), - process_maybe1(make_mode_defn(VarSet, Condition), R, Result) - ; - parse_mode_decl_pred(ModuleName, VarSet, ModeDefn, Attributes, - Result) - ). + ( mode_op(ModeDefn, H, B) -> + get_condition(B, Body, Condition), + convert_mode_defn(ModuleName, H, Body, R), + process_maybe1(make_mode_defn(VarSet, Condition), R, Result) + ; + parse_mode_decl_pred(ModuleName, VarSet, ModeDefn, Attributes, Result) + ). :- pred mode_op(term::in, term::out, term::out) is semidet. mode_op(term__functor(term__atom(Op), [H, B], _), H, B) :- - Op = "==". + Op = "==". :- type processed_mode_body - ---> processed_mode_body( - sym_name, - list(inst_var), - mode_defn - ). + ---> processed_mode_body( + sym_name, + list(inst_var), + mode_defn + ). :- pred convert_mode_defn(module_name::in, term::in, term::in, - maybe1(processed_mode_body)::out) is det. + maybe1(processed_mode_body)::out) is det. convert_mode_defn(ModuleName, Head, Body, Result) :- - parse_implicitly_qualified_term(ModuleName, Head, Head, - "mode definition", R), - convert_mode_defn_2(R, Head, Body, Result). + parse_implicitly_qualified_term(ModuleName, Head, Head, + "mode definition", R), + convert_mode_defn_2(R, Head, Body, Result). :- pred convert_mode_defn_2(maybe_functor::in, term::in, term::in, - maybe1(processed_mode_body)::out) is det. + maybe1(processed_mode_body)::out) is det. convert_mode_defn_2(error(M, T), _, _, error(M, T)). convert_mode_defn_2(ok(Name, ArgTerms), Head, Body, Result) :- - ( - % check that all the head args are variables - term__var_list_to_term_list(Args, ArgTerms) - -> - ( - % check that all the head arg variables are distinct - list__member(Arg2, Args, [Arg2|OtherArgs]), - list__member(Arg2, OtherArgs) - -> - Result = error( - "repeated parameters in LHS of mode defn", - Head) - % check that all the variables in the body occur - % in the head - ; - term__contains_var(Body, Var2), - \+ list__member(Var2, Args) - -> - Result = error( - "free inst parameter in RHS of mode definition", - Body) - ; - % should improve the error message here - ( - convert_mode(no_allow_constrained_inst_var, - Body, ConvertedBody) - -> - list__map(term__coerce_var, Args, InstArgs), - Result = ok(processed_mode_body(Name, - InstArgs, eqv_mode(ConvertedBody))) - ; - % catch-all error message - we should do - % better than this - Result = error( - "syntax error in mode definition body", - Body) - ) - ) - ; - Result = error("mode parameters must be variables", Head) - ). + ( + % Check that all the head args are variables. + term__var_list_to_term_list(Args, ArgTerms) + -> + ( + % Check that all the head arg variables are distinct. + list__member(Arg2, Args, [Arg2|OtherArgs]), + list__member(Arg2, OtherArgs) + -> + Result = error("repeated parameters in LHS of mode defn", + Head) + ; + % Check that all the variables in the body occur in the head. + term__contains_var(Body, Var2), + \+ list__member(Var2, Args) + -> + Result = error("free inst parameter in RHS of mode definition", + Body) + ; + % Should improve the error message here. + ( + convert_mode(no_allow_constrained_inst_var, Body, + ConvertedBody) + -> + list__map(term__coerce_var, Args, InstArgs), + Result = ok(processed_mode_body(Name, InstArgs, + eqv_mode(ConvertedBody))) + ; + % Catch-all error message - we should do better than this. + Result = error("syntax error in mode definition body", + Body) + ) + ) + ; + Result = error("mode parameters must be variables", Head) + ). :- pred convert_type_and_mode_list(inst_var_sub::in, list(term)::in, - list(type_and_mode)::out) is semidet. + list(type_and_mode)::out) is semidet. convert_type_and_mode_list(_, [], []). convert_type_and_mode_list(InstConstraints, [H0|T0], [H|T]) :- - convert_type_and_mode(InstConstraints, H0, H), - convert_type_and_mode_list(InstConstraints, T0, T). + convert_type_and_mode(InstConstraints, H0, H), + convert_type_and_mode_list(InstConstraints, T0, T). :- pred convert_type_and_mode(inst_var_sub::in, term::in, type_and_mode::out) - is semidet. + is semidet. convert_type_and_mode(InstConstraints, Term, Result) :- - ( - Term = term__functor(term__atom("::"), [TypeTerm, ModeTerm], - _Context) - -> - parse_type(TypeTerm, ok(Type)), - convert_mode(allow_constrained_inst_var, ModeTerm, Mode0), - constrain_inst_vars_in_mode(InstConstraints, Mode0, Mode), - Result = type_and_mode(Type, Mode) - ; - parse_type(Term, ok(Type)), - Result = type_only(Type) - ). + ( Term = term__functor(term__atom("::"), [TypeTerm, ModeTerm], _Context) -> + parse_type(TypeTerm, ok(Type)), + convert_mode(allow_constrained_inst_var, ModeTerm, Mode0), + constrain_inst_vars_in_mode(InstConstraints, Mode0, Mode), + Result = type_and_mode(Type, Mode) + ; + parse_type(Term, ok(Type)), + Result = type_only(Type) + ). :- pred make_mode_defn(varset::in, condition::in, processed_mode_body::in, - item::out) is det. + item::out) is det. make_mode_defn(VarSet0, Cond, processed_mode_body(Name, Params, ModeDefn), - mode_defn(VarSet, Name, Params, ModeDefn, Cond)) :- - varset__coerce(VarSet0, VarSet). + mode_defn(VarSet, Name, Params, ModeDefn, Cond)) :- + varset__coerce(VarSet0, VarSet). %-----------------------------------------------------------------------------% @@ -3842,35 +3641,37 @@ make_mode_defn(VarSet0, Cond, processed_mode_body(Name, Params, ModeDefn), :- mode maker == (pred(in, out) is det). :- pred parse_symlist_decl(parser(T)::parser, maker(list(T), sym_list)::maker, - maker(sym_list, module_defn)::maker, - term::in, decl_attrs::in, varset::in, maybe1(item)::out) is det. + maker(sym_list, module_defn)::maker, + term::in, decl_attrs::in, varset::in, maybe1(item)::out) is det. parse_symlist_decl(ParserPred, MakeSymListPred, MakeModuleDefnPred, - Term, Attributes, VarSet, Result) :- - parse_list(ParserPred, Term, Result0), - process_maybe1(make_module_defn(MakeSymListPred, MakeModuleDefnPred, - VarSet), Result0, Result1), - check_no_attributes(Result1, Attributes, Result). + Term, Attributes, VarSet, Result) :- + parse_list(ParserPred, Term, Result0), + process_maybe1(make_module_defn(MakeSymListPred, MakeModuleDefnPred, + VarSet), Result0, Result1), + check_no_attributes(Result1, Attributes, Result). :- pred make_module_defn(maker(T, sym_list)::maker, - maker(sym_list, module_defn)::maker, varset::in, T::in, item::out) - is det. + maker(sym_list, module_defn)::maker, varset::in, T::in, item::out) + is det. make_module_defn(MakeSymListPred, MakeModuleDefnPred, VarSet0, T, - module_defn(VarSet, ModuleDefn)) :- - varset__coerce(VarSet0, VarSet), - call(MakeSymListPred, T, SymList), - call(MakeModuleDefnPred, SymList, ModuleDefn). + module_defn(VarSet, ModuleDefn)) :- + varset__coerce(VarSet0, VarSet), + call(MakeSymListPred, T, SymList), + call(MakeModuleDefnPred, SymList, ModuleDefn). %-----------------------------------------------------------------------------% -:- pred process_maybe1(maker(T1, T2), maybe1(T1), maybe1(T2)). -:- mode process_maybe1(maker, in, out) is det. +:- pred process_maybe1(maker(T1, T2)::maker, maybe1(T1)::in, maybe1(T2)::out) + is det. + process_maybe1(Maker, ok(X), ok(Y)) :- call(Maker, X, Y). process_maybe1(_, error(M, T), error(M, T)). -:- pred process_maybe1_to_t(maker(T1, maybe1(T2)), maybe1(T1), maybe1(T2)). -:- mode process_maybe1_to_t(maker, in, out) is det. +:- pred process_maybe1_to_t(maker(T1, maybe1(T2))::maker, + maybe1(T1)::in, maybe1(T2)::out) is det. + process_maybe1_to_t(Maker, ok(X), Y) :- call(Maker, X, Y). process_maybe1_to_t(_, error(M, T), error(M, T)). @@ -3902,91 +3703,81 @@ make_op(X, op(X)). %-----------------------------------------------------------------------------% % -% A symbol specifier is one of +% A symbol specifier is one of % -% SymbolNameSpecifier -% Matches any symbol matched by the SymbolNameSpecifier. -% TypedConstructorSpecifier -% Matches any constructors matched by the -% TypedConstructorSpecifier. -% cons(ConstructorSpecifier) -% Matches only constructors. -% pred(PredSpecifier) -% Matches only predicates, ie. constructors of type -% `pred'. -% adt(SymbolNameSpecifier) -% Matches only type names. -% type(SymbolNameSpecifier) -% Matches type names matched by the SymbolNameSpecifier, -% and also matches any constructors for the matched type -% names. -% op(SymbolNameSpecifier) -% Matches only operators. -% module(ModuleSpecifier) -% Matches all symbols in the specified module. +% SymbolNameSpecifier +% Matches any symbol matched by the SymbolNameSpecifier. +% TypedConstructorSpecifier +% Matches any constructors matched by the +% TypedConstructorSpecifier. +% cons(ConstructorSpecifier) +% Matches only constructors. +% pred(PredSpecifier) +% Matches only predicates, ie. constructors of type `pred'. +% adt(SymbolNameSpecifier) +% Matches only type names. +% type(SymbolNameSpecifier) +% Matches type names matched by the SymbolNameSpecifier, +% and also matches any constructors for the matched type names. +% op(SymbolNameSpecifier) +% Matches only operators. +% module(ModuleSpecifier) +% Matches all symbols in the specified module. :- pred parse_symbol_specifier(term::in, maybe1(sym_specifier)::out) is det. parse_symbol_specifier(MainTerm, Result) :- - ( MainTerm = term__functor(term__atom(Functor), [Term], _Context) -> - ( Functor = "cons" -> - parse_constructor_specifier(Term, Result0), - process_maybe1(make_cons_symbol_specifier, Result0, - Result) - ; Functor = "pred" -> - parse_predicate_specifier(Term, Result0), - process_maybe1(make_pred_symbol_specifier, Result0, - Result) - ; Functor = "func" -> - parse_function_specifier(Term, Result0), - process_maybe1(make_func_symbol_specifier, Result0, - Result) - ; Functor = "type" -> - parse_type_specifier(Term, Result0), - process_maybe1(make_type_symbol_specifier, Result0, - Result) - ; Functor = "adt" -> - parse_adt_specifier(Term, Result0), - process_maybe1(make_adt_symbol_specifier, Result0, - Result) - ; Functor = "op" -> - parse_op_specifier(Term, Result0), - process_maybe1(make_op_symbol_specifier, Result0, - Result) - ; Functor = "module" -> - parse_module_specifier(Term, Result0), - process_maybe1(make_module_symbol_specifier, Result0, - Result) - ; - parse_constructor_specifier(MainTerm, Result0), - process_maybe1(make_cons_symbol_specifier, Result0, - Result) - ) - ; - parse_constructor_specifier(MainTerm, Result0), - process_maybe1(make_cons_symbol_specifier, Result0, Result) - ). - -% Once we've parsed the appropriate type of symbol specifier, we -% need to convert it to a sym_specifier. + ( MainTerm = term__functor(term__atom(Functor), [Term], _Context) -> + ( Functor = "cons" -> + parse_constructor_specifier(Term, Result0), + process_maybe1(make_cons_symbol_specifier, Result0, Result) + ; Functor = "pred" -> + parse_predicate_specifier(Term, Result0), + process_maybe1(make_pred_symbol_specifier, Result0, Result) + ; Functor = "func" -> + parse_function_specifier(Term, Result0), + process_maybe1(make_func_symbol_specifier, Result0, Result) + ; Functor = "type" -> + parse_type_specifier(Term, Result0), + process_maybe1(make_type_symbol_specifier, Result0, Result) + ; Functor = "adt" -> + parse_adt_specifier(Term, Result0), + process_maybe1(make_adt_symbol_specifier, Result0, Result) + ; Functor = "op" -> + parse_op_specifier(Term, Result0), + process_maybe1(make_op_symbol_specifier, Result0, Result) + ; Functor = "module" -> + parse_module_specifier(Term, Result0), + process_maybe1(make_module_symbol_specifier, Result0, Result) + ; + parse_constructor_specifier(MainTerm, Result0), + process_maybe1(make_cons_symbol_specifier, Result0, Result) + ) + ; + parse_constructor_specifier(MainTerm, Result0), + process_maybe1(make_cons_symbol_specifier, Result0, Result) + ). + % Once we've parsed the appropriate type of symbol specifier, we need to + % convert it to a sym_specifier. + % :- pred make_pred_symbol_specifier(pred_specifier::in, sym_specifier::out) - is det. + is det. make_pred_symbol_specifier(PredSpec, pred(PredSpec)). :- pred make_func_symbol_specifier(func_specifier::in, sym_specifier::out) - is det. + is det. make_func_symbol_specifier(FuncSpec, func(FuncSpec)). :- pred make_cons_symbol_specifier(cons_specifier::in, sym_specifier::out) - is det. + is det. make_cons_symbol_specifier(ConsSpec, cons(ConsSpec)). :- pred make_type_symbol_specifier(type_specifier::in, sym_specifier::out) - is det. + is det. make_type_symbol_specifier(TypeSpec, type(TypeSpec)). @@ -3999,167 +3790,152 @@ make_adt_symbol_specifier(ADT_Spec, adt(ADT_Spec)). make_op_symbol_specifier(OpSpec, op(OpSpec)). :- pred make_module_symbol_specifier(module_specifier::in, sym_specifier::out) - is det. + is det. make_module_symbol_specifier(ModuleSpec, module(ModuleSpec)). :- pred cons_specifier_to_sym_specifier(cons_specifier::in, - sym_specifier::out) is det. + sym_specifier::out) is det. cons_specifier_to_sym_specifier(sym(SymSpec), sym(SymSpec)). cons_specifier_to_sym_specifier(typed(SymSpec), typed_sym(SymSpec)). %-----------------------------------------------------------------------------% -% A ModuleSpecifier is just an sym_name. - + % A ModuleSpecifier is just an sym_name. + % :- pred parse_module_specifier(term::in, maybe1(module_specifier)::out) is det. parse_module_specifier(Term, Result) :- - parse_symbol_name(Term, Result). - -% A ModuleName is an implicitly-quantified sym_name. -% -% We check for module names starting with capital letters -% as a special case, so that we can report a better error -% message for that case. + parse_symbol_name(Term, Result). + % A ModuleName is an implicitly-quantified sym_name. + % + % We check for module names starting with capital letters as a special + % case, so that we can report a better error message for that case. + % :- pred parse_module_name(module_name::in, term::in, - maybe1(module_name)::out) is det. + maybe1(module_name)::out) is det. parse_module_name(DefaultModuleName, Term, Result) :- - ( - Term = term__variable(_) - -> - dummy_term(ErrorContext), - Result = error("module names starting with " ++ - "capital letters must be quoted using " ++ - "single quotes (e.g. "":- module 'Foo'."")", - ErrorContext) - ; - parse_implicitly_qualified_symbol_name(DefaultModuleName, - Term, Result) - ). + ( Term = term__variable(_) -> + dummy_term(ErrorContext), + Result = error("module names starting with " ++ + "capital letters must be quoted using " ++ + "single quotes (e.g. "":- module 'Foo'."")", + ErrorContext) + ; + parse_implicitly_qualified_symbol_name(DefaultModuleName, Term, Result) + ). %-----------------------------------------------------------------------------% -% A ConstructorSpecifier is one of -% SymbolNameSpecifier -% TypedConstructorSpecifier -% -% A TypedConstructorSpecifier is one of -% SymbolNameSpecifier::Type -% Matches only constructors with the specified result -% type. -% SymbolName(ArgType1, ..., ArgTypeN) -% Matches only constructors with the specified argument -% types. -% SymbolName(ArgType1, ..., ArgTypeN)::Type -% Matches only constructors with the specified argument -% and result types. - + % A ConstructorSpecifier is one of + % SymbolNameSpecifier + % TypedConstructorSpecifier + % + % A TypedConstructorSpecifier is one of + % SymbolNameSpecifier::Type + % Matches only constructors with the specified result type. + % SymbolName(ArgType1, ..., ArgTypeN) + % Matches only constructors with the specified argument types. + % SymbolName(ArgType1, ..., ArgTypeN)::Type + % Matches only constructors with the specified argument + % and result types. + % :- pred parse_constructor_specifier(term::in, maybe1(cons_specifier)::out) - is det. + is det. parse_constructor_specifier(Term, Result) :- - ( - Term = term__functor(term__atom("::"), - [NameArgsTerm, TypeTerm], _Context) - -> - parse_arg_types_specifier(NameArgsTerm, NameArgsResult), - parse_type(TypeTerm, TypeResult), - process_typed_constructor_specifier(NameArgsResult, TypeResult, - Result) - ; - parse_arg_types_specifier(Term, TermResult), - process_maybe1(make_untyped_cons_spec, TermResult, Result) - ). + ( + Term = term__functor(term__atom("::"), [NameArgsTerm, TypeTerm], + _Context) + -> + parse_arg_types_specifier(NameArgsTerm, NameArgsResult), + parse_type(TypeTerm, TypeResult), + process_typed_constructor_specifier(NameArgsResult, TypeResult, Result) + ; + parse_arg_types_specifier(Term, TermResult), + process_maybe1(make_untyped_cons_spec, TermResult, Result) + ). %-----------------------------------------------------------------------------% -% A PredicateSpecifier is one of -% SymbolName(ArgType1, ..., ArgTypeN) -% Matches only predicates with the specified argument -% types. -% SymbolNameSpecifier - + % A PredicateSpecifier is one of + % SymbolName(ArgType1, ..., ArgTypeN) + % Matches only predicates with the specified argument types. + % SymbolNameSpecifier + % :- pred parse_predicate_specifier(term::in, maybe1(pred_specifier)::out) - is det. + is det. parse_predicate_specifier(Term, Result) :- - ( - Term = term__functor(term__atom("/"), [_,_], _Context) - -> - parse_symbol_name_specifier(Term, NameResult), - process_maybe1(make_arity_predicate_specifier, - NameResult, Result) - ; - parse_qualified_term(Term, Term, "predicate specifier", - TermResult), - process_typed_predicate_specifier(TermResult, Result) - ). + ( Term = term__functor(term__atom("/"), [_,_], _Context) -> + parse_symbol_name_specifier(Term, NameResult), + process_maybe1(make_arity_predicate_specifier, NameResult, Result) + ; + parse_qualified_term(Term, Term, "predicate specifier", TermResult), + process_typed_predicate_specifier(TermResult, Result) + ). :- pred process_typed_predicate_specifier(maybe_functor::in, - maybe1(pred_specifier)::out) is det. + maybe1(pred_specifier)::out) is det. process_typed_predicate_specifier(ok(Name, Args0), Result) :- - ( Args0 = [] -> - Result = ok(sym(name(Name))) - ; - parse_types(Args0, ArgsResult), - ( - ArgsResult = ok(Args), - Result = ok(name_args(Name, Args)) - ; - ArgsResult = error(Msg, ErrorTerm), - Result = error(Msg, ErrorTerm) - ) - ). + ( + Args0 = [], + Result = ok(sym(name(Name))) + ; + Args0 = [_ | _], + parse_types(Args0, ArgsResult), + ( + ArgsResult = ok(Args), + Result = ok(name_args(Name, Args)) + ; + ArgsResult = error(Msg, ErrorTerm), + Result = error(Msg, ErrorTerm) + ) + ). process_typed_predicate_specifier(error(Msg, Term), error(Msg, Term)). :- pred make_arity_predicate_specifier(sym_name_specifier::in, - pred_specifier::out) is det. + pred_specifier::out) is det. make_arity_predicate_specifier(Result, sym(Result)). %-----------------------------------------------------------------------------% -% Parsing the name & argument types of a constructor specifier is -% exactly the same as parsing a predicate specifier... - + % Parsing the name & argument types of a constructor specifier is exactly + % the same as parsing a predicate specifier... + % :- pred parse_arg_types_specifier(term::in, maybe1(pred_specifier)::out) - is det. + is det. parse_arg_types_specifier(Term, Result) :- - ( - Term = term__functor(term__atom("/"), [_,_], _Context) - -> - parse_symbol_name_specifier(Term, NameResult), - process_maybe1(make_arity_predicate_specifier, - NameResult, Result) - ; - parse_qualified_term(Term, Term, "constructor specifier", - TermResult), - process_typed_predicate_specifier(TermResult, Result) - ). - -% ... but we have to convert the result back into the appropriate -% format. + ( Term = term__functor(term__atom("/"), [_,_], _Context) -> + parse_symbol_name_specifier(Term, NameResult), + process_maybe1(make_arity_predicate_specifier, NameResult, Result) + ; + parse_qualified_term(Term, Term, "constructor specifier", TermResult), + process_typed_predicate_specifier(TermResult, Result) + ). + % ... but we have to convert the result back into the appropriate format. + % :- pred process_typed_constructor_specifier(maybe1(pred_specifier)::in, - maybe1(type)::in, maybe1(cons_specifier)::out) is det. + maybe1(type)::in, maybe1(cons_specifier)::out) is det. process_typed_constructor_specifier(error(Msg, Term), _, error(Msg, Term)). process_typed_constructor_specifier(ok(_), error(Msg, Term), error(Msg, Term)). process_typed_constructor_specifier(ok(NameArgs), ok(ResType), ok(Result)) :- - process_typed_cons_spec_2(NameArgs, ResType, Result). + process_typed_cons_spec_2(NameArgs, ResType, Result). :- pred process_typed_cons_spec_2(pred_specifier::in, (type)::in, - cons_specifier::out) is det. + cons_specifier::out) is det. process_typed_cons_spec_2(sym(Name), Res, typed(name_res(Name, Res))). process_typed_cons_spec_2(name_args(Name, Args), Res, - typed(name_args_res(Name, Args, Res))). + typed(name_args_res(Name, Args, Res))). :- pred make_untyped_cons_spec(pred_specifier::in, cons_specifier::out) is det. @@ -4168,55 +3944,50 @@ make_untyped_cons_spec(name_args(Name, Args), typed(name_args(Name, Args))). %-----------------------------------------------------------------------------% -% A SymbolNameSpecifier is one of -% SymbolName -% SymbolName/Arity -% Matches only symbols of the specified arity. -% - + % A SymbolNameSpecifier is one of + % SymbolName + % SymbolName/Arity + % Matches only symbols of the specified arity. + % :- pred parse_symbol_name_specifier(term::in, maybe1(sym_name_specifier)::out) - is det. + is det. parse_symbol_name_specifier(Term, Result) :- - root_module_name(DefaultModule), - parse_implicitly_qualified_symbol_name_specifier(DefaultModule, - Term, Result). + root_module_name(DefaultModule), + parse_implicitly_qualified_symbol_name_specifier(DefaultModule, + Term, Result). :- pred parse_implicitly_qualified_symbol_name_specifier(module_name::in, - term::in, maybe1(sym_name_specifier)::out) is det. + term::in, maybe1(sym_name_specifier)::out) is det. parse_implicitly_qualified_symbol_name_specifier(DefaultModule, Term, Result) :- - ( %%% some [NameTerm, ArityTerm, Context] - Term = term__functor(term__atom("/"), [NameTerm, ArityTerm], - _Context) - -> - ( %%% some [Arity, Context2] - ArityTerm = term__functor(term__integer(Arity), [], - _Context2) - -> - ( Arity >= 0 -> - parse_implicitly_qualified_symbol_name( - DefaultModule, NameTerm, NameResult), - process_maybe1( - make_name_arity_specifier(Arity), - NameResult, Result) - ; - Result = error("arity in symbol name " ++ - "specifier must be a non-negative " ++ - "integer", Term) - ) - ; - Result = error("arity in symbol name " ++ - "specifier must be an integer", Term) - ) - ; - parse_implicitly_qualified_symbol_name(DefaultModule, - Term, SymbolNameResult), - process_maybe1(make_name_specifier, SymbolNameResult, Result) - ). + ( + Term = term__functor(term__atom("/"), [NameTerm, ArityTerm], _Context) + -> + ( + ArityTerm = term__functor(term__integer(Arity), [], _Context2) + -> + ( Arity >= 0 -> + parse_implicitly_qualified_symbol_name(DefaultModule, NameTerm, + NameResult), + process_maybe1(make_name_arity_specifier(Arity), + NameResult, Result) + ; + Result = error("arity in symbol name specifier " ++ + "must be a non-negative integer", Term) + ) + ; + Result = error("arity in symbol name " ++ + "specifier must be an integer", Term) + ) + ; + parse_implicitly_qualified_symbol_name(DefaultModule, Term, + SymbolNameResult), + process_maybe1(make_name_specifier, SymbolNameResult, Result) + ). :- pred make_name_arity_specifier(arity::in, sym_name::in, - sym_name_specifier::out) is det. + sym_name_specifier::out) is det. make_name_arity_specifier(Arity, Name, name_arity(Name, Arity)). @@ -4226,173 +3997,154 @@ make_name_specifier(Name, name(Name)). %-----------------------------------------------------------------------------% -% A SymbolName is one of -% Name -% Matches symbols with the specified name in the -% current namespace. -% Module:Name -% Matches symbols with the specified name exported -% by the specified module (where Module is itself -% a SymbolName). -% -% We also allow the syntax `Module__Name' -% as an alternative for `Module:Name'. - + % A SymbolName is one of + % Name + % Matches symbols with the specified name in the + % current namespace. + % Module.Name + % Matches symbols with the specified name exported + % by the specified module (where Module is itself a SymbolName). + % + % We also allow the syntax `Module__Name' as an alternative + % for `Module.Name'. + % :- pred parse_symbol_name(term(T)::in, maybe1(sym_name)::out) is det. parse_symbol_name(Term, Result) :- - ( - Term = term__functor(term__atom(FunctorName), - [ModuleTerm, NameTerm], _Context), - ( FunctorName = ":" - ; FunctorName = "." - ) - -> - ( - NameTerm = term__functor(term__atom(Name), [], - _Context1) - -> - parse_symbol_name(ModuleTerm, ModuleResult), - ( - ModuleResult = ok(Module), - Result = ok(qualified(Module, Name)) - ; - ModuleResult = error(_, _), - term__coerce(Term, ErrorTerm), - Result = error("module name identifier " ++ - "expected before ':' in qualified " ++ - "symbol name", ErrorTerm) - ) - ; - term__coerce(Term, ErrorTerm), - Result = error("identifier expected after ':' " ++ - "in qualified symbol name", ErrorTerm) - ) - ; - ( - Term = term__functor(term__atom(Name), [], _Context3) - -> - string_to_sym_name(Name, "__", SymName), - Result = ok(SymName) - ; - term__coerce(Term, ErrorTerm), - Result = error("symbol name expected", ErrorTerm) - ) - ). + ( + Term = term__functor(term__atom(FunctorName), [ModuleTerm, NameTerm], + _Context), + ( FunctorName = ":" + ; FunctorName = "." + ) + -> + ( + NameTerm = term__functor(term__atom(Name), [], _Context1) + -> + parse_symbol_name(ModuleTerm, ModuleResult), + ( + ModuleResult = ok(Module), + Result = ok(qualified(Module, Name)) + ; + ModuleResult = error(_, _), + term__coerce(Term, ErrorTerm), + Result = error("module name identifier " ++ + "expected before ':' in qualified " ++ + "symbol name", ErrorTerm) + ) + ; + term__coerce(Term, ErrorTerm), + Result = error("identifier expected after ':' " ++ + "in qualified symbol name", ErrorTerm) + ) + ; + ( Term = term__functor(term__atom(Name), [], _Context3) -> + string_to_sym_name(Name, "__", SymName), + Result = ok(SymName) + ; + term__coerce(Term, ErrorTerm), + Result = error("symbol name expected", ErrorTerm) + ) + ). :- pred parse_implicitly_qualified_symbol_name(module_name::in, term::in, - maybe1(sym_name)::out) is det. + maybe1(sym_name)::out) is det. parse_implicitly_qualified_symbol_name(DefaultModName, Term, Result) :- - parse_symbol_name(Term, Result0), - ( Result0 = ok(SymName) -> - ( - root_module_name(DefaultModName) - -> - Result = Result0 - ; - SymName = qualified(ModName, _), - \+ match_sym_name(ModName, DefaultModName) - -> - Result = error("module qualifier in definition does not match preceding `:- module' declaration", Term) - ; - unqualify_name(SymName, UnqualName), - Result = ok(qualified(DefaultModName, UnqualName)) - ) - ; - Result = Result0 - ). + parse_symbol_name(Term, Result0), + ( Result0 = ok(SymName) -> + ( + root_module_name(DefaultModName) + -> + Result = Result0 + ; + SymName = qualified(ModName, _), + \+ match_sym_name(ModName, DefaultModName) + -> + Result = error("module qualifier in definition " ++ + "does not match preceding `:- module' declaration", Term) + ; + unqualify_name(SymName, UnqualName), + Result = ok(qualified(DefaultModName, UnqualName)) + ) + ; + Result = Result0 + ). %-----------------------------------------------------------------------------% -% A QualifiedTerm is one of -% Name(Args) -% Module:Name(Args) -% (or if Args is empty, one of -% Name -% Module:Name) -% where Module is a SymName. -% For backwards compatibility, we allow `__' -% as an alternative to `:'. - sym_name_and_args(Term, SymName, Args) :- - parse_qualified_term(Term, Term, "", ok(SymName, Args)). + parse_qualified_term(Term, Term, "", ok(SymName, Args)). parse_implicitly_qualified_term(DefaultModName, Term, ContainingTerm, Msg, - Result) :- - parse_qualified_term(Term, ContainingTerm, Msg, Result0), - ( Result0 = ok(SymName, Args) -> - ( - root_module_name(DefaultModName) - -> - Result = Result0 - ; - SymName = qualified(ModName, _), - \+ match_sym_name(ModName, DefaultModName) - -> - term__coerce(Term, ErrorTerm), - Result = error("module qualifier in definition " ++ - "does not match preceding " ++ " - `:- module' declaration", ErrorTerm) - ; - unqualify_name(SymName, UnqualName), - Result = ok(qualified(DefaultModName, UnqualName), Args) - ) - ; - Result = Result0 - ). + Result) :- + parse_qualified_term(Term, ContainingTerm, Msg, Result0), + ( Result0 = ok(SymName, Args) -> + ( + root_module_name(DefaultModName) + -> + Result = Result0 + ; + SymName = qualified(ModName, _), + \+ match_sym_name(ModName, DefaultModName) + -> + term__coerce(Term, ErrorTerm), + Result = error("module qualifier in definition " ++ + "does not match preceding " ++ " + `:- module' declaration", ErrorTerm) + ; + unqualify_name(SymName, UnqualName), + Result = ok(qualified(DefaultModName, UnqualName), Args) + ) + ; + Result = Result0 + ). parse_qualified_term(Term, ContainingTerm, Msg, Result) :- - ( - Term = term__functor(term__atom(FunctorName), - [ModuleTerm, NameArgsTerm], _), - FunctorName = "." - -> - ( - NameArgsTerm = term__functor(term__atom(Name), Args, _) - -> - parse_symbol_name(ModuleTerm, ModuleResult), - ( - ModuleResult = ok(Module), - Result = ok(qualified(Module, Name), Args) - ; - ModuleResult = error(_, _), - term__coerce(Term, ErrorTerm), - Result = error("module name identifier " ++ - "expected before '.' in " ++ - "qualified symbol name", ErrorTerm) - ) - ; - term__coerce(Term, ErrorTerm), - Result = error("identifier expected after '.' " ++ - "in qualified symbol name", ErrorTerm) - ) - ; - ( - Term = term__functor(term__atom(Name), Args, _) - -> - string_to_sym_name(Name, "__", SymName), - Result = ok(SymName, Args) - ; - string__append("atom expected in ", Msg, ErrorMsg), - % - % since variables don't have any term__context, - % if Term is a variable, we use ContainingTerm instead - % (hopefully that _will_ have a term__context). - % - ( Term = term__variable(_) -> - ErrorTerm0 = ContainingTerm - ; - ErrorTerm0 = Term - ), - term__coerce(ErrorTerm0, ErrorTerm), - Result = error(ErrorMsg, ErrorTerm) - ) - ). + ( + Term = term__functor(term__atom(FunctorName), + [ModuleTerm, NameArgsTerm], _), + FunctorName = "." + -> + ( NameArgsTerm = term__functor(term__atom(Name), Args, _) -> + parse_symbol_name(ModuleTerm, ModuleResult), + ( + ModuleResult = ok(Module), + Result = ok(qualified(Module, Name), Args) + ; + ModuleResult = error(_, _), + term__coerce(Term, ErrorTerm), + Result = error("module name identifier " ++ + "expected before '.' in " ++ + "qualified symbol name", ErrorTerm) + ) + ; + term__coerce(Term, ErrorTerm), + Result = error("identifier expected after '.' " ++ + "in qualified symbol name", ErrorTerm) + ) + ; + ( Term = term__functor(term__atom(Name), Args, _) -> + string_to_sym_name(Name, "__", SymName), + Result = ok(SymName, Args) + ; + string__append("atom expected in ", Msg, ErrorMsg), + % Since variables don't have any term__context, if Term is + % a variable, we use ContainingTerm instead (hopefully that + % _will_ have a term__context). + ( Term = term__variable(_) -> + ErrorTerm0 = ContainingTerm + ; + ErrorTerm0 = Term + ), + term__coerce(ErrorTerm0, ErrorTerm), + Result = error(ErrorMsg, ErrorTerm) + ) + ). %-----------------------------------------------------------------------------% - -% predicates used to convert a sym_list to a program item +% +% Predicates used to convert a sym_list to a program item. :- pred make_use(sym_list::in, module_defn::out) is det. @@ -4408,37 +4160,37 @@ make_export(Syms, export(Syms)). %-----------------------------------------------------------------------------% -% A FuncSpecifier is just a constructur name specifier. - + % A FuncSpecifier is just a constructur name specifier. + % :- pred parse_function_specifier(term::in, maybe1(func_specifier)::out) is det. parse_function_specifier(Term, Result) :- - parse_constructor_specifier(Term, Result). - -% A TypeSpecifier is just a symbol name specifier. + parse_constructor_specifier(Term, Result). + % A TypeSpecifier is just a symbol name specifier. + % :- pred parse_type_specifier(term::in, maybe1(sym_name_specifier)::out) is det. parse_type_specifier(Term, Result) :- - parse_symbol_name_specifier(Term, Result). - -% An ADT_Specifier is just a symbol name specifier. + parse_symbol_name_specifier(Term, Result). + % An ADT_Specifier is just a symbol name specifier. + % :- pred parse_adt_specifier(term::in, maybe1(sym_name_specifier)::out) is det. parse_adt_specifier(Term, Result) :- - parse_symbol_name_specifier(Term, Result). + parse_symbol_name_specifier(Term, Result). %-----------------------------------------------------------------------------% -% For the moment, an OpSpecifier is just a symbol name specifier. -% XXX We should allow specifying the fixity of an operator - + % For the moment, an OpSpecifier is just a symbol name specifier. + % XXX We should allow specifying the fixity of an operator + % :- pred parse_op_specifier(term::in, maybe1(op_specifier)::out) is det. parse_op_specifier(Term, Result) :- - parse_symbol_name_specifier(Term, R), - process_maybe1(make_op_specifier, R, Result). + parse_symbol_name_specifier(Term, R), + process_maybe1(make_op_specifier, R, Result). :- pred make_op_specifier(sym_name_specifier::in, op_specifier::out) is det. @@ -4447,64 +4199,60 @@ make_op_specifier(X, sym(X)). %-----------------------------------------------------------------------------% :- func convert_constructor_arg_list(module_name, list(term)) = - maybe1(list(constructor_arg)). + maybe1(list(constructor_arg)). convert_constructor_arg_list(_ModuleName, []) = ok([]). convert_constructor_arg_list( ModuleName, [Term | Terms]) = Result :- - ( - Term = term__functor(term__atom("::"), [NameTerm, TypeTerm], - _) - -> - parse_implicitly_qualified_term(ModuleName, NameTerm, Term, - "field name", NameResult), - ( - NameResult = error(String1, Term1), - Result = error(String1, Term1) - ; - NameResult = ok(_SymName, [_ | _]), - Result = error("syntax error in constructor name", - Term) - ; - NameResult = ok(SymName, []), - MaybeFieldName = yes(SymName), - Result = convert_constructor_arg_list_2(ModuleName, - MaybeFieldName, TypeTerm, Terms) - ) - ; - MaybeFieldName = no, - TypeTerm = Term, - Result = convert_constructor_arg_list_2(ModuleName, - MaybeFieldName, TypeTerm, Terms) - ). + ( Term = term__functor(term__atom("::"), [NameTerm, TypeTerm], _) -> + parse_implicitly_qualified_term(ModuleName, NameTerm, Term, + "field name", NameResult), + ( + NameResult = error(String1, Term1), + Result = error(String1, Term1) + ; + NameResult = ok(_SymName, [_ | _]), + Result = error("syntax error in constructor name", Term) + ; + NameResult = ok(SymName, []), + MaybeFieldName = yes(SymName), + Result = convert_constructor_arg_list_2(ModuleName, MaybeFieldName, + TypeTerm, Terms) + ) + ; + MaybeFieldName = no, + TypeTerm = Term, + Result = convert_constructor_arg_list_2(ModuleName, MaybeFieldName, + TypeTerm, Terms) + ). :- func convert_constructor_arg_list_2(module_name, maybe(sym_name), term, - list(term)) = maybe1(list(constructor_arg)). + list(term)) = maybe1(list(constructor_arg)). convert_constructor_arg_list_2(ModuleName, MaybeFieldName, TypeTerm, Terms) = - Result :- - parse_type(TypeTerm, TypeResult), - ( - TypeResult = ok(Type), - Arg = MaybeFieldName - Type, - Result0 = convert_constructor_arg_list(ModuleName, Terms), - ( - Result0 = error(String, Term), - Result = error(String, Term) - ; - Result0 = ok(Args), - Result = ok([Arg | Args]) - ) - ; - TypeResult = error(String, Term), - Result = error(String, Term) - ). + Result :- + parse_type(TypeTerm, TypeResult), + ( + TypeResult = ok(Type), + Arg = MaybeFieldName - Type, + Result0 = convert_constructor_arg_list(ModuleName, Terms), + ( + Result0 = error(String, Term), + Result = error(String, Term) + ; + Result0 = ok(Args), + Result = ok([Arg | Args]) + ) + ; + TypeResult = error(String, Term), + Result = error(String, Term) + ). %-----------------------------------------------------------------------------% -% We use the empty module name ('') as the "root" module name; when adding -% default module qualifiers in parse_implicitly_qualified_{term,symbol}, -% if the default module is the root module then we don't add any qualifier. - + % We use the empty module name ('') as the "root" module name; when adding + % default module qualifiers in parse_implicitly_qualified_{term,symbol}, + % if the default module is the root module then we don't add any qualifier. + % :- pred root_module_name(module_name::out) is det. root_module_name(unqualified("")). diff --git a/compiler/prog_io_dcg.m b/compiler/prog_io_dcg.m index 7edf3e7b2..acb46fc86 100644 --- a/compiler/prog_io_dcg.m +++ b/compiler/prog_io_dcg.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 1996-2001, 2003-2005 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. @@ -12,8 +14,8 @@ % % XXX This module performs no error checking. % XXX It may be an idea to recode this as a state variable transformation: -% roughly Head --> G1, G2, {G3}, G4. -% becomes Head(!DCG) :- G1(!DCG), G2(!DCG), G3, G4(!DCG). +% roughly Head --> G1, G2, {G3}, G4. +% becomes Head(!DCG) :- G1(!DCG), G2(!DCG), G3, G4(!DCG). :- module parse_tree__prog_io_dcg. @@ -27,16 +29,16 @@ :- import_module varset. :- pred parse_dcg_clause(module_name::in, varset::in, term::in, term::in, - prog_context::in, maybe_item_and_context::out) is det. + prog_context::in, maybe_item_and_context::out) is det. - % parse_dcg_pred_goal(GoalTerm, Goal, - % DCGVarInitial, DCGVarFinal, VarSet0, Varset) - % parses `GoalTerm' and expands it as a DCG goal, - % `VarSet0' is the initial varset, and `VarSet' is - % the final varset. `DCGVarInitial' is the first DCG variable, - % and `DCGVarFinal' is the final DCG variable. + % parse_dcg_pred_goal(GoalTerm, Goal, DCGVarInitial, DCGVarFinal, !Varset): + % + % Parses `GoalTerm' and expands it as a DCG goal. + % `DCGVarInitial' is the first DCG variable, + % and `DCGVarFinal' is the final DCG variable. + % :- pred parse_dcg_pred_goal(term::in, goal::out, prog_var::out, prog_var::out, - prog_varset::in, prog_varset::out) is det. + prog_varset::in, prog_varset::out) is det. :- implementation. @@ -55,491 +57,474 @@ %-----------------------------------------------------------------------------% parse_dcg_clause(ModuleName, VarSet0, DCG_Head, DCG_Body, DCG_Context, - Result) :- - varset__coerce(VarSet0, ProgVarSet0), - new_dcg_var(ProgVarSet0, ProgVarSet1, counter__init(0), Counter0, - DCG_0_Var), - parse_dcg_goal(DCG_Body, Body, ProgVarSet1, ProgVarSet, - Counter0, _Counter, DCG_0_Var, DCG_Var), - parse_implicitly_qualified_term(ModuleName, - DCG_Head, DCG_Body, "DCG clause head", HeadResult), - process_dcg_clause(HeadResult, ProgVarSet, DCG_0_Var, DCG_Var, - Body, R), - add_context(R, DCG_Context, Result). + Result) :- + varset__coerce(VarSet0, ProgVarSet0), + new_dcg_var(ProgVarSet0, ProgVarSet1, counter__init(0), Counter0, + DCG_0_Var), + parse_dcg_goal(DCG_Body, Body, ProgVarSet1, ProgVarSet, Counter0, _Counter, + DCG_0_Var, DCG_Var), + parse_implicitly_qualified_term(ModuleName, DCG_Head, DCG_Body, + "DCG clause head", HeadResult), + process_dcg_clause(HeadResult, ProgVarSet, DCG_0_Var, DCG_Var, Body, R), + add_context(R, DCG_Context, Result). %-----------------------------------------------------------------------------% parse_dcg_pred_goal(GoalTerm, Goal, DCGVar0, DCGVar, !VarSet) :- - new_dcg_var(!VarSet, counter__init(0), Counter0, DCGVar0), - parse_dcg_goal(GoalTerm, Goal, !VarSet, Counter0, _Counter, - DCGVar0, DCGVar). + new_dcg_var(!VarSet, counter__init(0), Counter0, DCGVar0), + parse_dcg_goal(GoalTerm, Goal, !VarSet, Counter0, _Counter, + DCGVar0, DCGVar). %-----------------------------------------------------------------------------% - % Used to allocate fresh variables needed for the DCG expansion. - + % Used to allocate fresh variables needed for the DCG expansion. + % :- pred new_dcg_var(prog_varset::in, prog_varset::out, - counter::in, counter::out, prog_var::out) is det. + counter::in, counter::out, prog_var::out) is det. new_dcg_var(!VarSet, !Counter, DCG_0_Var) :- - counter__allocate(N, !Counter), - string__int_to_string(N, StringN), - string__append("DCG_", StringN, VarName), - varset__new_var(!.VarSet, DCG_0_Var, !:VarSet), - varset__name_var(!.VarSet, DCG_0_Var, VarName, !:VarSet). + counter__allocate(N, !Counter), + string__int_to_string(N, StringN), + string__append("DCG_", StringN, VarName), + varset__new_var(!.VarSet, DCG_0_Var, !:VarSet), + varset__name_var(!.VarSet, DCG_0_Var, VarName, !:VarSet). %-----------------------------------------------------------------------------% - % Expand a DCG goal. - + % Expand a DCG goal. + % :- pred parse_dcg_goal(term::in, goal::out, prog_varset::in, prog_varset::out, - counter::in, counter::out, prog_var::in, prog_var::out) is det. + counter::in, counter::out, prog_var::in, prog_var::out) is det. parse_dcg_goal(Term, Goal, !VarSet, !Counter, !Var) :- - % first, figure out the context for the goal - ( - Term = term__functor(_, _, Context) - ; - Term = term__variable(_), - term__context_init(Context) - ), - % next, parse it - ( - term__coerce(Term, ProgTerm), - sym_name_and_args(ProgTerm, SymName, Args0) - -> - % First check for the special cases: - ( - SymName = unqualified(Functor), - list__map(term__coerce, Args0, Args1), - parse_dcg_goal_2(Functor, Args1, Context, - Goal1, !VarSet, !Counter, !Var) - -> - Goal = Goal1 - ; - % It's the ordinary case of non-terminal. - % Create a fresh var as the DCG output var from this - % goal, and append the DCG argument pair to the - % non-terminal's argument list. - new_dcg_var(!VarSet, !Counter, Var), - list__append(Args0, - [term__variable(!.Var), - term__variable(Var)], Args), - Goal = call(SymName, Args, pure) - Context, - !:Var = Var - ) - ; - % A call to a free variable, or to a number or string. - % Just translate it into a call to call/3 - the typechecker - % will catch calls to numbers and strings. - new_dcg_var(!VarSet, !Counter, Var), - term__coerce(Term, ProgTerm), - Goal = call(unqualified("call"), [ProgTerm, - term__variable(!.Var), term__variable(Var)], - pure) - Context, - !:Var = Var - ). - - % parse_dcg_goal_2(Functor, Args, Context, VarSet0, Counter0, Var0, - % Goal, VarSet, Counter, Var): - % VarSet0/VarSet are an accumulator pair which we use to - % allocate fresh DCG variables; Counter0 and Counter are a pair - % we use to keep track of the number to give to the next DCG - % variable (so that we can give it a semi-meaningful name "DCG_" - % for use in error messages, debugging, etc.). - % Var0 and Var are an accumulator pair we use to keep track of - % the current DCG variable. - % - % Since (A -> B) has different semantics in standard Prolog - % (A -> B ; fail) than it does in NU-Prolog or Mercury (A -> B ; true), - % for the moment we'll just disallow it. + % First, figure out the context for the goal. + ( + Term = term__functor(_, _, Context) + ; + Term = term__variable(_), + term__context_init(Context) + ), + % Next, parse it. + ( + term__coerce(Term, ProgTerm), + sym_name_and_args(ProgTerm, SymName, Args0) + -> + % First check for the special cases: + ( + SymName = unqualified(Functor), + list__map(term__coerce, Args0, Args1), + parse_dcg_goal_2(Functor, Args1, Context, Goal1, + !VarSet, !Counter, !Var) + -> + Goal = Goal1 + ; + % It's the ordinary case of non-terminal. Create a fresh var + % as the DCG output var from this goal, and append the DCG argument + % pair to the non-terminal's argument list. + new_dcg_var(!VarSet, !Counter, Var), + Args = Args0 ++ [term__variable(!.Var), term__variable(Var)], + Goal = call(SymName, Args, pure) - Context, + !:Var = Var + ) + ; + % A call to a free variable, or to a number or string. + % Just translate it into a call to call/3 - the typechecker + % will catch calls to numbers and strings. + new_dcg_var(!VarSet, !Counter, Var), + term__coerce(Term, ProgTerm), + Goal = call(unqualified("call"), + [ProgTerm, term__variable(!.Var), term__variable(Var)], pure) + - Context, + !:Var = Var + ). + % parse_dcg_goal_2(Functor, Args, Context, Goal, !VarSet, !Counter, !Var): + % + % We use !VarSet to allocate fresh DCG variables; We use !Counter + % to keep track of the number to give to the next DCG variable + % (so that we can give it a semi-meaningful name "DCG_" for use + % in error messages, debugging, etc.). We use !Var to keep track of + % the current DCG variable. + % + % Since (A -> B) has different semantics in standard Prolog + % (A -> B ; fail) than it does in NU-Prolog or Mercury (A -> B ; true), + % for the moment we'll just disallow it. + % :- pred parse_dcg_goal_2(string::in, list(term)::in, prog_context::in, - goal::out, prog_varset::in, prog_varset::out, - counter::in, counter::out, prog_var::in, prog_var::out) is semidet. + goal::out, prog_varset::in, prog_varset::out, + counter::in, counter::out, prog_var::in, prog_var::out) is semidet. - % Ordinary goal inside { curly braces }. parse_dcg_goal_2("{}", [G0 | Gs], Context, Goal, !VarSet, !Counter, !Var) :- - % The parser treats '{}/N' terms as tuples, so we need - % to undo the parsing of the argument conjunction here. - list_to_conjunction(Context, G0, Gs, G), - parse_goal(G, Goal, !VarSet). + % Ordinary goal inside { curly braces }. + % The parser treats '{}/N' terms as tuples, so we need + % to undo the parsing of the argument conjunction here. + list_to_conjunction(Context, G0, Gs, G), + parse_goal(G, Goal, !VarSet). parse_dcg_goal_2("impure", [G], _, Goal, !VarSet, !Counter, !Var) :- - parse_dcg_goal_with_purity(G, (impure), Goal, !VarSet, !Counter, !Var). + parse_dcg_goal_with_purity(G, (impure), Goal, !VarSet, !Counter, !Var). parse_dcg_goal_2("semipure", [G], _, Goal, !VarSet, !Counter, !Var) :- - parse_dcg_goal_with_purity(G, (semipure), Goal, !VarSet, !Counter, - !Var). + parse_dcg_goal_with_purity(G, (semipure), Goal, !VarSet, !Counter, !Var). parse_dcg_goal_2("promise_pure", [G], Context, Goal, - !VarSet, !Counter, !Var) :- - parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), - Goal = promise_purity(dont_make_implicit_promises, (pure), Goal0) - - Context. + !VarSet, !Counter, !Var) :- + parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), + Goal = promise_purity(dont_make_implicit_promises, (pure), Goal0) + - Context. parse_dcg_goal_2("promise_semipure", [G], Context, Goal, - !VarSet, !Counter, !Var) :- - parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), - Goal = promise_purity(dont_make_implicit_promises, (semipure), Goal0) - - Context. + !VarSet, !Counter, !Var) :- + parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), + Goal = promise_purity(dont_make_implicit_promises, (semipure), Goal0) + - Context. parse_dcg_goal_2("promise_impure", [G], Context, Goal, - !VarSet, !Counter, !Var) :- - parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), - Goal = promise_purity(dont_make_implicit_promises, (impure), Goal0) - - Context. + !VarSet, !Counter, !Var) :- + parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), + Goal = promise_purity(dont_make_implicit_promises, (impure), Goal0) + - Context. parse_dcg_goal_2("promise_pure_implicit", [G], Context, Goal, - !VarSet, !Counter, !Var) :- - parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), - Goal = promise_purity(make_implicit_promises, (pure), Goal0) - - Context. + !VarSet, !Counter, !Var) :- + parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), + Goal = promise_purity(make_implicit_promises, (pure), Goal0) + - Context. parse_dcg_goal_2("promise_semipure_implicit", [G], Context, Goal, - !VarSet, !Counter, !Var) :- - parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), - Goal = promise_purity(make_implicit_promises, (semipure), Goal0) - - Context. + !VarSet, !Counter, !Var) :- + parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), + Goal = promise_purity(make_implicit_promises, (semipure), Goal0) + - Context. parse_dcg_goal_2("promise_impure_implicit", [G], Context, Goal, - !VarSet, !Counter, !Var) :- - parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), - Goal = promise_purity(make_implicit_promises, (impure), Goal0) - - Context. + !VarSet, !Counter, !Var) :- + parse_dcg_goal(G, Goal0, !VarSet, !Counter, !Var), + Goal = promise_purity(make_implicit_promises, (impure), Goal0) + - Context. - % Empty list - just unify the input and output DCG args. parse_dcg_goal_2("[]", [], Context, Goal, !VarSet, !Counter, Var0, Var) :- - new_dcg_var(!VarSet, !Counter, Var), - Goal = unify(term__variable(Var0), term__variable(Var), pure) - - Context. + % Empty list - just unify the input and output DCG args. + new_dcg_var(!VarSet, !Counter, Var), + Goal = unify(term__variable(Var0), term__variable(Var), pure) + - Context. - % Non-empty list of terminals. Append the DCG output arg - % as the new tail of the list, and unify the result with - % the DCG input arg. parse_dcg_goal_2("[|]", [X, Xs], Context, Goal, !VarSet, !Counter, - Var0, Var) :- - new_dcg_var(!VarSet, !Counter, Var), - ConsTerm0 = term__functor(term__atom("[|]"), [X, Xs], Context), - term__coerce(ConsTerm0, ConsTerm), - term_list_append_term(ConsTerm, term__variable(Var), Term), - Goal = unify(term__variable(Var0), Term, pure) - Context. + Var0, Var) :- + % Non-empty list of terminals. Append the DCG output arg as the new tail + % of the list, and unify the result with the DCG input arg. + new_dcg_var(!VarSet, !Counter, Var), + ConsTerm0 = term__functor(term__atom("[|]"), [X, Xs], Context), + term__coerce(ConsTerm0, ConsTerm), + term_list_append_term(ConsTerm, term__variable(Var), Term), + Goal = unify(term__variable(Var0), Term, pure) - Context. - % Call to '='/1 - unify argument with DCG input arg. parse_dcg_goal_2("=", [A0], Context, Goal, !VarSet, !Counter, Var, Var) :- - term__coerce(A0, A), - Goal = unify(A, term__variable(Var), pure) - Context. + % Call to '='/1 - unify argument with DCG input arg. + term__coerce(A0, A), + Goal = unify(A, term__variable(Var), pure) - Context. - % Call to ':='/1 - unify argument with DCG output arg. parse_dcg_goal_2(":=", [A0], Context, Goal, !VarSet, !Counter, _Var0, Var) :- - new_dcg_var(!VarSet, !Counter, Var), - term__coerce(A0, A), - Goal = unify(A, term__variable(Var), pure) - Context. + % Call to ':='/1 - unify argument with DCG output arg. + new_dcg_var(!VarSet, !Counter, Var), + term__coerce(A0, A), + Goal = unify(A, term__variable(Var), pure) - Context. - % If-then (Prolog syntax). - % We need to add an else part to unify the DCG args. - -% /****** % parse_dcg_goal_2("->", [Cond0, Then0], Context, VarSet0, Counter0, Var0, -% Goal, VarSet, Counter, Var) :- -% parse_dcg_if_then(Cond0, Then0, Context, VarSet0, Counter0, Var0, -% SomeVars, StateVars, Cond, Then, VarSet, Counter, Var), -% ( Var = Var0 -> -% Goal = if_then(SomeVars, StateVars, Cond, Then) - Context -% ; -% Unify = unify(term__variable(Var), term__variable(Var0)), -% Goal = if_then_else(SomeVars, StateVars, Cond, Then, -% Unify - Context) - Context -% ). -% ******/ +% Goal, VarSet, Counter, Var) :- +% % If-then (Prolog syntax). +% % We need to add an else part to unify the DCG args. +% parse_dcg_if_then(Cond0, Then0, Context, VarSet0, Counter0, Var0, +% SomeVars, StateVars, Cond, Then, VarSet, Counter, Var), +% ( Var = Var0 -> +% Goal = if_then(SomeVars, StateVars, Cond, Then) - Context +% ; +% Unify = unify(term__variable(Var), term__variable(Var0)), +% Goal = if_then_else(SomeVars, StateVars, Cond, Then, +% Unify - Context) - Context +% ). - % If-then (NU-Prolog syntax). parse_dcg_goal_2("if", [term__functor(term__atom("then"), [Cond0, Then0], _)], - Context, Goal, !VarSet, !Counter, Var0, Var) :- - parse_dcg_if_then(Cond0, Then0, Context, SomeVars, StateVars, - Cond, Then, !VarSet, !Counter, Var0, Var), - ( Var = Var0 -> - Goal = if_then(SomeVars, StateVars, Cond, Then) - Context - ; - Unify = unify(term__variable(Var), term__variable(Var0), pure), - Goal = if_then_else(SomeVars, StateVars, Cond, Then, - Unify - Context) - Context - ). + Context, Goal, !VarSet, !Counter, Var0, Var) :- + % If-then (NU-Prolog syntax). + parse_dcg_if_then(Cond0, Then0, Context, SomeVars, StateVars, + Cond, Then, !VarSet, !Counter, Var0, Var), + ( Var = Var0 -> + Goal = if_then(SomeVars, StateVars, Cond, Then) - Context + ; + Unify = unify(term__variable(Var), term__variable(Var0), pure), + Goal = if_then_else(SomeVars, StateVars, Cond, Then, Unify - Context) + - Context + ). - % Conjunction. parse_dcg_goal_2(",", [A0, B0], Context, (A, B) - Context, !VarSet, !Counter, - !Var) :- - parse_dcg_goal(A0, A, !VarSet, !Counter, !Var), - parse_dcg_goal(B0, B, !VarSet, !Counter, !Var). + !Var) :- + % Conjunction. + parse_dcg_goal(A0, A, !VarSet, !Counter, !Var), + parse_dcg_goal(B0, B, !VarSet, !Counter, !Var). parse_dcg_goal_2("&", [A0, B0], Context, (A & B) - Context, - !VarSet, !Counter, !Var) :- - parse_dcg_goal(A0, A, !VarSet, !Counter, !Var), - parse_dcg_goal(B0, B, !VarSet, !Counter, !Var). + !VarSet, !Counter, !Var) :- + parse_dcg_goal(A0, A, !VarSet, !Counter, !Var), + parse_dcg_goal(B0, B, !VarSet, !Counter, !Var). - % Disjunction or if-then-else (Prolog syntax). parse_dcg_goal_2(";", [A0, B0], Context, Goal, !VarSet, !Counter, Var0, Var) :- - ( - A0 = term__functor(term__atom("->"), [Cond0, Then0], _Context) - -> - parse_dcg_if_then_else(Cond0, Then0, B0, Context, Goal, - !VarSet, !Counter, Var0, Var) - ; - parse_dcg_goal(A0, A1, !VarSet, !Counter, Var0, VarA), - parse_dcg_goal(B0, B1, !VarSet, !Counter, Var0, VarB), - ( VarA = Var0, VarB = Var0 -> - Var = Var0, - Goal = (A1 ; B1) - Context - ; VarA = Var0 -> - Var = VarB, - Unify = unify(term__variable(Var), - term__variable(VarA), pure), - append_to_disjunct(A1, Unify, Context, A2), - Goal = (A2 ; B1) - Context - ; VarB = Var0 -> - Var = VarA, - Unify = unify(term__variable(Var), - term__variable(VarB), pure), - append_to_disjunct(B1, Unify, Context, B2), - Goal = (A1 ; B2) - Context - ; - Var = VarB, - prog_util__rename_in_goal(VarA, VarB, A1, A2), - Goal = (A2 ; B1) - Context - ) - ). + % Disjunction or if-then-else (Prolog syntax). + ( + A0 = term__functor(term__atom("->"), [Cond0, Then0], _Context) + -> + parse_dcg_if_then_else(Cond0, Then0, B0, Context, Goal, + !VarSet, !Counter, Var0, Var) + ; + parse_dcg_goal(A0, A1, !VarSet, !Counter, Var0, VarA), + parse_dcg_goal(B0, B1, !VarSet, !Counter, Var0, VarB), + ( VarA = Var0, VarB = Var0 -> + Var = Var0, + Goal = (A1 ; B1) - Context + ; VarA = Var0 -> + Var = VarB, + Unify = unify(term__variable(Var), term__variable(VarA), pure), + append_to_disjunct(A1, Unify, Context, A2), + Goal = (A2 ; B1) - Context + ; VarB = Var0 -> + Var = VarA, + Unify = unify(term__variable(Var), term__variable(VarB), pure), + append_to_disjunct(B1, Unify, Context, B2), + Goal = (A1 ; B2) - Context + ; + Var = VarB, + prog_util__rename_in_goal(VarA, VarB, A1, A2), + Goal = (A2 ; B1) - Context + ) + ). - % If-then-else (NU-Prolog syntax). parse_dcg_goal_2("else", [IF, Else0], _, Goal, !VarSet, !Counter, !Var) :- - IF = term__functor(term__atom("if"), - [term__functor(term__atom("then"), [Cond0, Then0], _)], - Context), - parse_dcg_if_then_else(Cond0, Then0, Else0, Context, Goal, - !VarSet, !Counter, !Var). + % If-then-else (NU-Prolog syntax). + IF = term__functor(term__atom("if"), + [term__functor(term__atom("then"), [Cond0, Then0], _)], Context), + parse_dcg_if_then_else(Cond0, Then0, Else0, Context, Goal, + !VarSet, !Counter, !Var). - % Negation (NU-Prolog syntax). parse_dcg_goal_2("not", [A0], Context, not(A) - Context, - !VarSet, !Counter, Var0, Var0) :- - parse_dcg_goal(A0, A, !VarSet, !Counter, Var0, _). + !VarSet, !Counter, Var0, Var0) :- + % Negation (NU-Prolog syntax). + parse_dcg_goal(A0, A, !VarSet, !Counter, Var0, _). - % Negation (Prolog syntax). parse_dcg_goal_2("\\+", [A0], Context, not(A) - Context, - !VarSet, !Counter, Var0, Var0) :- - parse_dcg_goal(A0, A, !VarSet, !Counter, Var0, _). + !VarSet, !Counter, Var0, Var0) :- + % Negation (Prolog syntax). + parse_dcg_goal(A0, A, !VarSet, !Counter, Var0, _). - % Universal quantification. parse_dcg_goal_2("all", [QVars, A0], Context, GoalExpr - Context, - !VarSet, !Counter, !Var) :- + !VarSet, !Counter, !Var) :- + % Universal quantification. + % Extract any state variables in the quantifier. + parse_quantifier_vars(QVars, StateVars0, Vars0), + list__map(term__coerce_var, StateVars0, StateVars), + list__map(term__coerce_var, Vars0, Vars), - % Extract any state variables in the quantifier. - % - parse_quantifier_vars(QVars, StateVars0, Vars0), - list__map(term__coerce_var, StateVars0, StateVars), - list__map(term__coerce_var, Vars0, Vars), + parse_dcg_goal(A0, A @ (GoalExprA - ContextA), !VarSet, !Counter, !Var), + ( + Vars = [], + StateVars = [], + GoalExpr = GoalExprA + ; + Vars = [], + StateVars = [_ | _], + GoalExpr = all_state_vars(StateVars, A) + ; + Vars = [_ | _], + StateVars = [], + GoalExpr = all(Vars, A) + ; + Vars = [_ | _], + StateVars = [_ | _], + GoalExpr = all(Vars, all_state_vars(StateVars, A) - ContextA) + ). - parse_dcg_goal(A0, A @ (GoalExprA - ContextA), !VarSet, !Counter, - !Var), - - ( - Vars = [], StateVars = [], - GoalExpr = GoalExprA - ; - Vars = [], StateVars = [_|_], - GoalExpr = all_state_vars(StateVars, A) - ; - Vars = [_|_], StateVars = [], - GoalExpr = all(Vars, A) - ; - Vars = [_|_], StateVars = [_|_], - GoalExpr = all(Vars, all_state_vars(StateVars, A) - ContextA) - ). - - % Existential quantification. parse_dcg_goal_2("some", [QVars, A0], Context, GoalExpr - Context, - !VarSet, !Counter, !Var) :- + !VarSet, !Counter, !Var) :- + % Existential quantification. + % Extract any state variables in the quantifier. + parse_quantifier_vars(QVars, StateVars0, Vars0), + list__map(term__coerce_var, StateVars0, StateVars), + list__map(term__coerce_var, Vars0, Vars), - % Extract any state variables in the quantifier. - % - parse_quantifier_vars(QVars, StateVars0, Vars0), - list__map(term__coerce_var, StateVars0, StateVars), - list__map(term__coerce_var, Vars0, Vars), - - parse_dcg_goal(A0, A @ (GoalExprA - ContextA), !VarSet, !Counter, - !Var), - - ( - Vars = [], StateVars = [], - GoalExpr = GoalExprA - ; - Vars = [], StateVars = [_|_], - GoalExpr = some_state_vars(StateVars, A) - ; - Vars = [_|_], StateVars = [], - GoalExpr = some(Vars, A) - ; - Vars = [_|_], StateVars = [_|_], - GoalExpr = some(Vars, some_state_vars(StateVars, A) - ContextA) - ). + parse_dcg_goal(A0, A @ (GoalExprA - ContextA), !VarSet, !Counter, !Var), + ( + Vars = [], + StateVars = [], + GoalExpr = GoalExprA + ; + Vars = [], + StateVars = [_ | _], + GoalExpr = some_state_vars(StateVars, A) + ; + Vars = [_ | _], + StateVars = [], + GoalExpr = some(Vars, A) + ; + Vars = [_ | _], + StateVars = [_ | _], + GoalExpr = some(Vars, some_state_vars(StateVars, A) - ContextA) + ). :- pred parse_dcg_goal_with_purity(term::in, purity::in, goal::out, - prog_varset::in, prog_varset::out, counter::in, counter::out, - prog_var::in, prog_var::out) is det. + prog_varset::in, prog_varset::out, counter::in, counter::out, + prog_var::in, prog_var::out) is det. parse_dcg_goal_with_purity(G, Purity, Goal, !VarSet, !Counter, !Var) :- - parse_dcg_goal(G, Goal1, !VarSet, !Counter, !Var), - ( Goal1 = call(Pred, Args, pure) - Context -> - Goal = call(Pred, Args, Purity) - Context - ; Goal1 = unify(ProgTerm1, ProgTerm2, pure) - Context -> - Goal = unify(ProgTerm1, ProgTerm2, Purity) - Context - ; - % Inappropriate placement of an impurity marker, so we treat - % it like a predicate call. typecheck.m prints out something - % descriptive for these errors. - Goal1 = _ - Context, - purity_name(Purity, PurityString), - term__coerce(G, G1), - Goal = call(unqualified(PurityString), [G1], pure) - Context - ). + parse_dcg_goal(G, Goal1, !VarSet, !Counter, !Var), + ( Goal1 = call(Pred, Args, pure) - Context -> + Goal = call(Pred, Args, Purity) - Context + ; Goal1 = unify(ProgTerm1, ProgTerm2, pure) - Context -> + Goal = unify(ProgTerm1, ProgTerm2, Purity) - Context + ; + % Inappropriate placement of an impurity marker, so we treat + % it like a predicate call. typecheck.m prints out something + % descriptive for these errors. + Goal1 = _ - Context, + purity_name(Purity, PurityString), + term__coerce(G, G1), + Goal = call(unqualified(PurityString), [G1], pure) - Context + ). :- pred append_to_disjunct(goal::in, goal_expr::in, prog_context::in, - goal::out) is det. + goal::out) is det. append_to_disjunct(Disjunct0, Goal, Context, Disjunct) :- - ( Disjunct0 = (A0 ; B0) - Context2 -> - append_to_disjunct(A0, Goal, Context, A), - append_to_disjunct(B0, Goal, Context, B), - Disjunct = (A ; B) - Context2 - ; - Disjunct = (Disjunct0, Goal - Context) - Context - ). + ( Disjunct0 = (A0 ; B0) - Context2 -> + append_to_disjunct(A0, Goal, Context, A), + append_to_disjunct(B0, Goal, Context, B), + Disjunct = (A ; B) - Context2 + ; + Disjunct = (Disjunct0, Goal - Context) - Context + ). :- pred parse_some_vars_dcg_goal(term::in, list(prog_var)::out, - list(prog_var)::out, goal::out, prog_varset::in, prog_varset::out, - counter::in, counter::out, prog_var::in, prog_var::out) is det. + list(prog_var)::out, goal::out, prog_varset::in, prog_varset::out, + counter::in, counter::out, prog_var::in, prog_var::out) is det. parse_some_vars_dcg_goal(A0, SomeVars, StateVars, A, !VarSet, !Counter, - !Var) :- - ( A0 = term__functor(term__atom("some"), [QVars0, A1], _Context) -> - term__coerce(QVars0, QVars), - ( parse_quantifier_vars(QVars, StateVars0, SomeVars0) -> - SomeVars = SomeVars0, - StateVars = StateVars0 - ; - % XXX a hack because we do not do - % error checking in this module. - term__vars(QVars, SomeVars), - StateVars = [] - ), - A2 = A1 - ; - SomeVars = [], - StateVars = [], - A2 = A0 - ), - parse_dcg_goal(A2, A, !VarSet, !Counter, !Var). - - % Parse the "if" and the "then" part of an if-then or an - % if-then-else. - % If the condition is a DCG goal, but then "then" part - % is not, then we need to translate - % ( a -> { b } ; c ) - % as - % ( a(DCG_1, DCG_2) -> - % b, - % DCG_3 = DCG_2 - % ; - % c(DCG_1, DCG_3) - % ) - % rather than - % ( a(DCG_1, DCG_2) -> - % b - % ; - % c(DCG_1, DCG_2) - % ) - % so that the implicit quantification of DCG_2 is correct. + !Var) :- + ( A0 = term__functor(term__atom("some"), [QVars0, A1], _Context) -> + term__coerce(QVars0, QVars), + ( parse_quantifier_vars(QVars, StateVars0, SomeVars0) -> + SomeVars = SomeVars0, + StateVars = StateVars0 + ; + % XXX A hack because we do not do error checking in this module. + term__vars(QVars, SomeVars), + StateVars = [] + ), + A2 = A1 + ; + SomeVars = [], + StateVars = [], + A2 = A0 + ), + parse_dcg_goal(A2, A, !VarSet, !Counter, !Var). + % Parse the "if" and the "then" part of an if-then or an if-then-else. + % If the condition is a DCG goal, but then "then" part is not, + % then we need to translate + % ( a -> { b } ; c ) + % as + % ( a(DCG_1, DCG_2) -> + % b, + % DCG_3 = DCG_2 + % ; + % c(DCG_1, DCG_3) + % ) + % rather than + % ( a(DCG_1, DCG_2) -> + % b + % ; + % c(DCG_1, DCG_2) + % ) + % so that the implicit quantification of DCG_2 is correct. + % :- pred parse_dcg_if_then(term::in, term::in, prog_context::in, - list(prog_var)::out, list(prog_var)::out, goal::out, goal::out, - prog_varset::in, prog_varset::out, counter::in, counter::out, - prog_var::in, prog_var::out) is det. + list(prog_var)::out, list(prog_var)::out, goal::out, goal::out, + prog_varset::in, prog_varset::out, counter::in, counter::out, + prog_var::in, prog_var::out) is det. parse_dcg_if_then(Cond0, Then0, Context, SomeVars, StateVars, Cond, Then, - !VarSet, !Counter, Var0, Var) :- - parse_some_vars_dcg_goal(Cond0, SomeVars, StateVars, Cond, - !VarSet, !Counter, Var0, Var1), - parse_dcg_goal(Then0, Then1, !VarSet, !Counter, Var1, Var2), - ( Var0 \= Var1, Var1 = Var2 -> - new_dcg_var(!VarSet, !Counter, Var), - Unify = unify(term__variable(Var), term__variable(Var2), pure), - Then = (Then1, Unify - Context) - Context - ; - Then = Then1, - Var = Var2 - ). + !VarSet, !Counter, Var0, Var) :- + parse_some_vars_dcg_goal(Cond0, SomeVars, StateVars, Cond, + !VarSet, !Counter, Var0, Var1), + parse_dcg_goal(Then0, Then1, !VarSet, !Counter, Var1, Var2), + ( + Var0 \= Var1, + Var1 = Var2 + -> + new_dcg_var(!VarSet, !Counter, Var), + Unify = unify(term__variable(Var), term__variable(Var2), pure), + Then = (Then1, Unify - Context) - Context + ; + Then = Then1, + Var = Var2 + ). :- pred parse_dcg_if_then_else(term::in, term::in, term::in, prog_context::in, - goal::out, prog_varset::in, prog_varset::out, - counter::in, counter::out, prog_var::in, prog_var::out) is det. + goal::out, prog_varset::in, prog_varset::out, + counter::in, counter::out, prog_var::in, prog_var::out) is det. parse_dcg_if_then_else(Cond0, Then0, Else0, Context, Goal, - !VarSet, !Counter, Var0, Var) :- - parse_dcg_if_then(Cond0, Then0, Context, SomeVars, StateVars, - Cond, Then1, !VarSet, !Counter, Var0, VarThen), - parse_dcg_goal(Else0, Else1, !VarSet, !Counter, Var0, VarElse), - ( VarThen = Var0, VarElse = Var0 -> - Var = Var0, - Then = Then1, - Else = Else1 - ; VarThen = Var0 -> - Var = VarElse, - Unify = unify(term__variable(Var), term__variable(VarThen), - pure), - Then = (Then1, Unify - Context) - Context, - Else = Else1 - ; VarElse = Var0 -> - Var = VarThen, - Then = Then1, - Unify = unify(term__variable(Var), term__variable(VarElse), - pure), - Else = (Else1, Unify - Context) - Context - ; - % We prefer to substitute the then part since it is likely - % to be smaller than the else part, since the else part may - % have a deeply nested chain of if-then-elses. + !VarSet, !Counter, Var0, Var) :- + parse_dcg_if_then(Cond0, Then0, Context, SomeVars, StateVars, + Cond, Then1, !VarSet, !Counter, Var0, VarThen), + parse_dcg_goal(Else0, Else1, !VarSet, !Counter, Var0, VarElse), + ( VarThen = Var0, VarElse = Var0 -> + Var = Var0, + Then = Then1, + Else = Else1 + ; VarThen = Var0 -> + Var = VarElse, + Unify = unify(term__variable(Var), term__variable(VarThen), pure), + Then = (Then1, Unify - Context) - Context, + Else = Else1 + ; VarElse = Var0 -> + Var = VarThen, + Then = Then1, + Unify = unify(term__variable(Var), term__variable(VarElse), pure), + Else = (Else1, Unify - Context) - Context + ; + % We prefer to substitute the then part since it is likely to be + % smaller than the else part, since the else part may have a deeply + % nested chain of if-then-elses. - % parse_dcg_if_then guarantees that if VarThen \= Var0, - % then the then part introduces a new DCG variable (i.e. - % VarThen does not appear in the condition). We therefore - % don't need to do the substitution in the condition. + % parse_dcg_if_then guarantees that if VarThen \= Var0, then the + % then part introduces a new DCG variable (i.e. VarThen does not appear + % in the condition). We therefore don't need to do the substitution + % in the condition. - Var = VarElse, - prog_util__rename_in_goal(VarThen, VarElse, Then1, Then), - Else = Else1 - ), - Goal = if_then_else(SomeVars, StateVars, Cond, Then, Else) - Context. - - % term_list_append_term(ListTerm, Term, Result): - % if ListTerm is a term representing a proper list, - % this predicate will append the term Term - % onto the end of the list + Var = VarElse, + prog_util__rename_in_goal(VarThen, VarElse, Then1, Then), + Else = Else1 + ), + Goal = if_then_else(SomeVars, StateVars, Cond, Then, Else) - Context. + % term_list_append_term(ListTerm, Term, Result): + % + % If ListTerm is a term representing a proper list, this predicate + % will append the term Term onto the end of the list. + % :- pred term_list_append_term(term(T)::in, term(T)::in, term(T)::out) - is semidet. + is semidet. term_list_append_term(List0, Term, List) :- - ( List0 = term__functor(term__atom("[]"), [], _Context) -> - List = Term - ; - List0 = term__functor(term__atom("[|]"), - [Head, Tail0], Context2), - List = term__functor(term__atom("[|]"), - [Head, Tail], Context2), - term_list_append_term(Tail0, Term, Tail) - ). + ( List0 = term__functor(term__atom("[]"), [], _Context) -> + List = Term + ; + List0 = term__functor(term__atom("[|]"), [Head, Tail0], Context2), + List = term__functor(term__atom("[|]"), [Head, Tail], Context2), + term_list_append_term(Tail0, Term, Tail) + ). :- pred process_dcg_clause(maybe_functor::in, prog_varset::in, prog_var::in, - prog_var::in, goal::in, maybe1(item)::out) is det. + prog_var::in, goal::in, maybe1(item)::out) is det. process_dcg_clause(ok(Name, Args0), VarSet, Var0, Var, Body, - ok(clause(user, VarSet, predicate, Name, Args, Body))) :- - list__map(term__coerce, Args0, Args1), - list__append(Args1, [term__variable(Var0), term__variable(Var)], Args). + ok(clause(user, VarSet, predicate, Name, Args, Body))) :- + list__map(term__coerce, Args0, Args1), + list__append(Args1, [term__variable(Var0), term__variable(Var)], Args). process_dcg_clause(error(Message, Term), _, _, _, _, error(Message, Term)). diff --git a/compiler/prog_io_goal.m b/compiler/prog_io_goal.m index 8ffa005c4..c359003bc 100644 --- a/compiler/prog_io_goal.m +++ b/compiler/prog_io_goal.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 1996-2005 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. @@ -18,64 +20,64 @@ :- import_module list. :- import_module term. - % Convert a single term into a goal. - % + % Convert a single term into a goal. + % :- pred parse_goal(term::in, goal::out, prog_varset::in, prog_varset::out) - is det. + is det. - % Convert a term, possibly starting with `some [Vars]', into - % a list of the quantified variables, a list of quantified - % state variables, and a goal. (If the term doesn't start - % with `some [Vars]', we return empty lists of variables.) - % + % Convert a term, possibly starting with `some [Vars]', into + % a list of the quantified variables, a list of quantified + % state variables, and a goal. (If the term doesn't start + % with `some [Vars]', we return empty lists of variables.) + % :- pred parse_some_vars_goal(term::in, list(prog_var)::out, - list(prog_var)::out, goal::out, prog_varset::in, prog_varset::out) - is det. + list(prog_var)::out, goal::out, prog_varset::in, prog_varset::out) + is det. - % parse_pred_expression/3 converts the first argument to a :-/2 - % higher-order pred expression into a list of variables, a list - % of their corresponding modes, and a determinism. - % + % parse_pred_expression/3 converts the first argument to a :-/2 + % higher-order pred expression into a list of variables, a list + % of their corresponding modes, and a determinism. + % :- pred parse_pred_expression(term::in, lambda_eval_method::out, - list(prog_term)::out, list(mode)::out, determinism::out) is semidet. + list(prog_term)::out, list(mode)::out, determinism::out) is semidet. - % parse_dcg_pred_expression/3 converts the first argument to a -->/2 - % higher-order dcg pred expression into a list of arguments, a list - % of their corresponding modes and the two dcg argument modes, and a - % determinism. - % This is a variant of the higher-order pred syntax: - % `(pred(Var1::Mode1, ..., VarN::ModeN, DCG0Mode, DCGMode) - % is Det --> Goal)'. - % + % parse_dcg_pred_expression/3 converts the first argument to a -->/2 + % higher-order DCG pred expression into a list of arguments, a list + % of their corresponding modes and the two DCG argument modes, and a + % determinism. + % This is a variant of the higher-order pred syntax: + % `(pred(Var1::Mode1, ..., VarN::ModeN, DCG0Mode, DCGMode) + % is Det --> Goal)'. + % :- pred parse_dcg_pred_expression(term::in, lambda_eval_method::out, - list(prog_term)::out, list(mode)::out, determinism::out) is semidet. + list(prog_term)::out, list(mode)::out, determinism::out) is semidet. - % parse_func_expression/3 converts the first argument to a :-/2 - % higher-order func expression into a list of arguments, a list - % of their corresponding modes, and a determinism. The syntax - % of a higher-order func expression is - % `(func(Var1::Mode1, ..., VarN::ModeN) = (VarN1::ModeN1) is Det - % :- Goal)' - % or - % `(func(Var1, ..., VarN) = (VarN1) is Det :- Goal)' - % where the modes are assumed to be `in' for the - % function arguments and `out' for the result - % or - % `(func(Var1, ..., VarN) = (VarN1) :- Goal)' - % where the modes are assumed as above, and the - % determinism is assumed to be det - % or - % `(func(Var1, ..., VarN) = (VarN1). ' - % + % parse_func_expression/3 converts the first argument to a :-/2 + % higher-order func expression into a list of arguments, a list + % of their corresponding modes, and a determinism. The syntax + % of a higher-order func expression is + % `(func(Var1::Mode1, ..., VarN::ModeN) = (VarN1::ModeN1) is Det + % :- Goal)' + % or + % `(func(Var1, ..., VarN) = (VarN1) is Det :- Goal)' + % where the modes are assumed to be `in' for the + % function arguments and `out' for the result + % or + % `(func(Var1, ..., VarN) = (VarN1) :- Goal)' + % where the modes are assumed as above, and the + % determinism is assumed to be det + % or + % `(func(Var1, ..., VarN) = (VarN1). ' + % :- pred parse_func_expression(term::in, lambda_eval_method::out, - list(prog_term)::out, list(mode)::out, determinism::out) is semidet. + list(prog_term)::out, list(mode)::out, determinism::out) is semidet. - % parse_lambda_eval_method/3 extracts the `aditi_bottom_up' - % annotation (if any) from a pred expression and returns the - % rest of the term. - % + % parse_lambda_eval_method/3 extracts the `aditi_bottom_up' + % annotation (if any) from a pred expression and returns the + % rest of the term. + % :- pred parse_lambda_eval_method(term(T)::in, lambda_eval_method::out, - term(T)::out) is det. + term(T)::out) is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -96,240 +98,230 @@ %-----------------------------------------------------------------------------% - % Parse a goal. - % - % We could do some error-checking here, but all errors are picked up - % in either the type-checker or parser anyway. - parse_goal(Term, Goal, !VarSet) :- - % first, get the goal context - ( - Term = term__functor(_, _, Context) - ; - Term = term__variable(_), - term__context_init(Context) - ), - % We just check if it matches the appropriate pattern - % for one of the builtins. If it doesn't match any of the - % builtins, then it's just a predicate call. - ( - % check for builtins... - Term = term__functor(term__atom(Name), Args, Context), - parse_goal_2(Name, Args, GoalExpr, !VarSet) - -> - Goal = GoalExpr - Context - ; - % it's not a builtin - term__coerce(Term, ArgsTerm), - ( - % check for predicate calls - sym_name_and_args(ArgsTerm, SymName, Args) - -> - Goal = call(SymName, Args, pure) - Context - ; - % A call to a free variable, or to a number or string. - % Just translate it into a call to call/1 - the - % typechecker will catch calls to numbers and strings. - Goal = call(unqualified("call"), [ArgsTerm], pure) - - Context - ) - ). + % We could do some error-checking here, but all errors are picked up + % in either the type-checker or parser anyway. + + % First, get the goal context. + ( + Term = term__functor(_, _, Context) + ; + Term = term__variable(_), + term__context_init(Context) + ), + % We just check if it matches the appropriate pattern for one of the + % builtins. If it doesn't match any of the builtins, then it's just + % a predicate call. + ( + % Check for builtins... + Term = term__functor(term__atom(Name), Args, Context), + parse_goal_2(Name, Args, GoalExpr, !VarSet) + -> + Goal = GoalExpr - Context + ; + % It's not a builtin. + term__coerce(Term, ArgsTerm), + ( + % Check for predicate calls. + sym_name_and_args(ArgsTerm, SymName, Args) + -> + Goal = call(SymName, Args, pure) - Context + ; + % A call to a free variable, or to a number or string. + % Just translate it into a call to call/1 - the + % typechecker will catch calls to numbers and strings. + Goal = call(unqualified("call"), [ArgsTerm], pure) - Context + ) + ). %-----------------------------------------------------------------------------% :- pred parse_goal_2(string::in, list(term)::in, goal_expr::out, - prog_varset::in, prog_varset::out) is semidet. + prog_varset::in, prog_varset::out) is semidet. - % Since (A -> B) has different semantics in standard Prolog - % (A -> B ; fail) than it does in NU-Prolog or Mercury (A -> B ; true), - % for the moment we'll just disallow it. - % For consistency we also disallow if-then without the else. + % Since (A -> B) has different semantics in standard Prolog + % (A -> B ; fail) than it does in NU-Prolog or Mercury (A -> B ; true), + % for the moment we'll just disallow it. + % For consistency we also disallow if-then without the else. parse_goal_2("true", [], true, !V). parse_goal_2("fail", [], fail, !V). parse_goal_2("=", [A0, B0], unify(A, B, pure), !V) :- - term__coerce(A0, A), - term__coerce(B0, B). + term__coerce(A0, A), + term__coerce(B0, B). parse_goal_2(",", [A0, B0], (A, B), !V) :- - parse_goal(A0, A, !V), - parse_goal(B0, B, !V). + parse_goal(A0, A, !V), + parse_goal(B0, B, !V). parse_goal_2("&", [A0, B0], (A & B), !V) :- - parse_goal(A0, A, !V), - parse_goal(B0, B, !V). + parse_goal(A0, A, !V), + parse_goal(B0, B, !V). parse_goal_2(";", [A0, B0], R, !V) :- - ( - A0 = term__functor(term__atom("->"), [X0, Y0], _Context) - -> - parse_some_vars_goal(X0, Vars, StateVars, X, !V), - parse_goal(Y0, Y, !V), - parse_goal(B0, B, !V), - R = if_then_else(Vars, StateVars, X, Y, B) - ; - parse_goal(A0, A, !V), - parse_goal(B0, B, !V), - R = (A;B) - ). + ( A0 = term__functor(term__atom("->"), [X0, Y0], _Context) -> + parse_some_vars_goal(X0, Vars, StateVars, X, !V), + parse_goal(Y0, Y, !V), + parse_goal(B0, B, !V), + R = if_then_else(Vars, StateVars, X, Y, B) + ; + parse_goal(A0, A, !V), + parse_goal(B0, B, !V), + R = (A;B) + ). parse_goal_2("else", [IF, C0], if_then_else(Vars, StateVars, A, B, C), !V) :- - IF = term__functor(term__atom("if"), - [term__functor(term__atom("then"), [A0, B0], _)], _), - parse_some_vars_goal(A0, Vars, StateVars, A, !V), - parse_goal(B0, B, !V), - parse_goal(C0, C, !V). + IF = term__functor(term__atom("if"), + [term__functor(term__atom("then"), [A0, B0], _)], _), + parse_some_vars_goal(A0, Vars, StateVars, A, !V), + parse_goal(B0, B, !V), + parse_goal(C0, C, !V). parse_goal_2("not", [A0], not(A), !V) :- - parse_goal(A0, A, !V). + parse_goal(A0, A, !V). parse_goal_2("\\+", [A0], not(A), !V) :- - parse_goal(A0, A, !V). + parse_goal(A0, A, !V). parse_goal_2("all", [QVars, A0], GoalExpr, !V):- + % Extract any state variables in the quantifier. + parse_quantifier_vars(QVars, StateVars0, Vars0), + list__map(term__coerce_var, StateVars0, StateVars), + list__map(term__coerce_var, Vars0, Vars), - % Extract any state variables in the quantifier. - % - parse_quantifier_vars(QVars, StateVars0, Vars0), - list__map(term__coerce_var, StateVars0, StateVars), - list__map(term__coerce_var, Vars0, Vars), + parse_goal(A0, A @ (GoalExprA - ContextA), !V), - parse_goal(A0, A @ (GoalExprA - ContextA), !V), + ( + Vars = [], StateVars = [], + GoalExpr = GoalExprA + ; + Vars = [], StateVars = [_|_], + GoalExpr = all_state_vars(StateVars, A) + ; + Vars = [_|_], StateVars = [], + GoalExpr = all(Vars, A) + ; + Vars = [_|_], StateVars = [_|_], + GoalExpr = all(Vars, all_state_vars(StateVars, A) - ContextA) + ). - ( - Vars = [], StateVars = [], - GoalExpr = GoalExprA - ; - Vars = [], StateVars = [_|_], - GoalExpr = all_state_vars(StateVars, A) - ; - Vars = [_|_], StateVars = [], - GoalExpr = all(Vars, A) - ; - Vars = [_|_], StateVars = [_|_], - GoalExpr = all(Vars, all_state_vars(StateVars, A) - ContextA) - ). - - % handle implication + % Handle implication. parse_goal_2("<=", [A0, B0], implies(B, A), !V):- - parse_goal(A0, A, !V), - parse_goal(B0, B, !V). + parse_goal(A0, A, !V), + parse_goal(B0, B, !V). parse_goal_2("=>", [A0, B0], implies(A, B), !V):- - parse_goal(A0, A, !V), - parse_goal(B0, B, !V). + parse_goal(A0, A, !V), + parse_goal(B0, B, !V). - % handle equivalence + % handle equivalence parse_goal_2("<=>", [A0, B0], equivalent(A, B), !V):- - parse_goal(A0, A, !V), - parse_goal(B0, B, !V). + parse_goal(A0, A, !V), + parse_goal(B0, B, !V). parse_goal_2("some", [QVars, A0], GoalExpr, !V):- + % Extract any state variables in the quantifier. + parse_quantifier_vars(QVars, StateVars0, Vars0), + list__map(term__coerce_var, StateVars0, StateVars), + list__map(term__coerce_var, Vars0, Vars), - % Extract any state variables in the quantifier. - % - parse_quantifier_vars(QVars, StateVars0, Vars0), - list__map(term__coerce_var, StateVars0, StateVars), - list__map(term__coerce_var, Vars0, Vars), - - parse_goal(A0, A @ (GoalExprA - ContextA), !V), - ( - Vars = [], StateVars = [], - GoalExpr = GoalExprA - ; - Vars = [], StateVars = [_|_], - GoalExpr = some_state_vars(StateVars, A) - ; - Vars = [_|_], StateVars = [], - GoalExpr = some(Vars, A) - ; - Vars = [_|_], StateVars = [_|_], - GoalExpr = some(Vars, some_state_vars(StateVars, A) - ContextA) - ). + parse_goal(A0, A @ (GoalExprA - ContextA), !V), + ( + Vars = [], StateVars = [], + GoalExpr = GoalExprA + ; + Vars = [], StateVars = [_|_], + GoalExpr = some_state_vars(StateVars, A) + ; + Vars = [_|_], StateVars = [], + GoalExpr = some(Vars, A) + ; + Vars = [_|_], StateVars = [_|_], + GoalExpr = some(Vars, some_state_vars(StateVars, A) - ContextA) + ). parse_goal_2("promise_equivalent_solutions", [OVars, A0], GoalExpr, !V):- - parse_goal(A0, A, !V), - parse_vars_and_state_vars(OVars, Vars0, DotSVars0, ColonSVars0), - list__map(term__coerce_var, Vars0, Vars), - list__map(term__coerce_var, DotSVars0, DotSVars), - list__map(term__coerce_var, ColonSVars0, ColonSVars), - GoalExpr = promise_equivalent_solutions(Vars, DotSVars, ColonSVars, A). + parse_goal(A0, A, !V), + parse_vars_and_state_vars(OVars, Vars0, DotSVars0, ColonSVars0), + list__map(term__coerce_var, Vars0, Vars), + list__map(term__coerce_var, DotSVars0, DotSVars), + list__map(term__coerce_var, ColonSVars0, ColonSVars), + GoalExpr = promise_equivalent_solutions(Vars, DotSVars, ColonSVars, A). parse_goal_2("promise_pure", [A0], GoalExpr, !V):- - parse_goal(A0, A, !V), - GoalExpr = promise_purity(dont_make_implicit_promises, pure, A). + parse_goal(A0, A, !V), + GoalExpr = promise_purity(dont_make_implicit_promises, pure, A). parse_goal_2("promise_semipure", [A0], GoalExpr, !V):- - parse_goal(A0, A, !V), - GoalExpr = promise_purity(dont_make_implicit_promises, semipure, A). + parse_goal(A0, A, !V), + GoalExpr = promise_purity(dont_make_implicit_promises, semipure, A). parse_goal_2("promise_impure", [A0], GoalExpr, !V):- - parse_goal(A0, A, !V), - GoalExpr = promise_purity(dont_make_implicit_promises, impure, A). + parse_goal(A0, A, !V), + GoalExpr = promise_purity(dont_make_implicit_promises, impure, A). parse_goal_2("promise_pure_implicit", [A0], GoalExpr, !V):- - parse_goal(A0, A, !V), - GoalExpr = promise_purity(make_implicit_promises, pure, A). + parse_goal(A0, A, !V), + GoalExpr = promise_purity(make_implicit_promises, pure, A). parse_goal_2("promise_semipure_implicit", [A0], GoalExpr, !V):- - parse_goal(A0, A, !V), - GoalExpr = promise_purity(make_implicit_promises, semipure, A). + parse_goal(A0, A, !V), + GoalExpr = promise_purity(make_implicit_promises, semipure, A). parse_goal_2("promise_impure_implicit", [A0], GoalExpr, !V):- - parse_goal(A0, A, !V), - GoalExpr = promise_purity(make_implicit_promises, impure, A). + parse_goal(A0, A, !V), + GoalExpr = promise_purity(make_implicit_promises, impure, A). - % The following is a temporary hack to handle `is' in - % the parser - we ought to handle it in the code generation - - % but then `is/2' itself is a bit of a hack - % + % The following is a temporary hack to handle `is' in the parser - + % we ought to handle it in the code generation - but then `is/2' itself + % is a bit of a hack. parse_goal_2("is", [A0, B0], unify(A, B, pure), !V) :- - term__coerce(A0, A), - term__coerce(B0, B). + term__coerce(A0, A), + term__coerce(B0, B). parse_goal_2("impure", [A0], A, !V) :- - parse_goal_with_purity(A0, (impure), A, !V). + parse_goal_with_purity(A0, (impure), A, !V). parse_goal_2("semipure", [A0], A, !V) :- - parse_goal_with_purity(A0, (semipure), A, !V). + parse_goal_with_purity(A0, (semipure), A, !V). :- pred parse_goal_with_purity(term::in, purity::in, goal_expr::out, - prog_varset::in, prog_varset::out) is det. + prog_varset::in, prog_varset::out) is det. parse_goal_with_purity(A0, Purity, A, !V) :- - parse_goal(A0, A1, !V), - ( A1 = call(Pred, Args, pure) - _ -> - A = call(Pred, Args, Purity) - ; A1 = unify(ProgTerm1, ProgTerm2, pure) - _ -> - A = unify(ProgTerm1, ProgTerm2, Purity) - ; - % Inappropriate placement of an impurity marker, so we treat - % it like a predicate call. typecheck.m prints out something - % descriptive for these errors. - purity_name(Purity, PurityString), - term__coerce(A0, A2), - A = call(unqualified(PurityString), [A2], pure) - ). + parse_goal(A0, A1, !V), + ( A1 = call(Pred, Args, pure) - _ -> + A = call(Pred, Args, Purity) + ; A1 = unify(ProgTerm1, ProgTerm2, pure) - _ -> + A = unify(ProgTerm1, ProgTerm2, Purity) + ; + % Inappropriate placement of an impurity marker, so we treat + % it like a predicate call. typecheck.m prints out something + % descriptive for these errors. + purity_name(Purity, PurityString), + term__coerce(A0, A2), + A = call(unqualified(PurityString), [A2], pure) + ). %-----------------------------------------------------------------------------% parse_some_vars_goal(A0, Vars, StateVars, A, !VarSet) :- - ( - A0 = term__functor(term__atom("some"), [QVars, A1], _Context), - parse_quantifier_vars(QVars, StateVars0, Vars0) - -> - list__map(term__coerce_var, StateVars0, StateVars), - list__map(term__coerce_var, Vars0, Vars), - parse_goal(A1, A, !VarSet) - ; - Vars = [], - StateVars = [], - parse_goal(A0, A, !VarSet) - ). + ( + A0 = term__functor(term__atom("some"), [QVars, A1], _Context), + parse_quantifier_vars(QVars, StateVars0, Vars0) + -> + list__map(term__coerce_var, StateVars0, StateVars), + list__map(term__coerce_var, Vars0, Vars), + parse_goal(A1, A, !VarSet) + ; + Vars = [], + StateVars = [], + parse_goal(A0, A, !VarSet) + ). %-----------------------------------------------------------------------------% :- pred parse_lambda_arg(term::in, prog_term::out, (mode)::out) is semidet. parse_lambda_arg(Term, ArgTerm, Mode) :- - Term = term__functor(term__atom("::"), [ArgTerm0, ModeTerm], _), - term__coerce(ArgTerm0, ArgTerm), - convert_mode(allow_constrained_inst_var, ModeTerm, Mode0), - constrain_inst_vars_in_mode(Mode0, Mode). + Term = term__functor(term__atom("::"), [ArgTerm0, ModeTerm], _), + term__coerce(ArgTerm0, ArgTerm), + convert_mode(allow_constrained_inst_var, ModeTerm, Mode0), + constrain_inst_vars_in_mode(Mode0, Mode). %-----------------------------------------------------------------------------% % @@ -337,118 +329,108 @@ parse_lambda_arg(Term, ArgTerm, Mode) :- % parse_pred_expression(PredTerm, EvalMethod, Args, Modes, Det) :- - PredTerm = term__functor(term__atom("is"), - [PredEvalArgsTerm, DetTerm], _), - DetTerm = term__functor(term__atom(DetString), [], _), - standard_det(DetString, Det), - parse_lambda_eval_method(PredEvalArgsTerm, EvalMethod, PredArgsTerm), - PredArgsTerm = term__functor(term__atom("pred"), PredArgsList, _), - parse_pred_expr_args(PredArgsList, Args, Modes), - inst_var_constraints_are_consistent_in_modes(Modes). + PredTerm = term__functor(term__atom("is"), [PredEvalArgsTerm, DetTerm], _), + DetTerm = term__functor(term__atom(DetString), [], _), + standard_det(DetString, Det), + parse_lambda_eval_method(PredEvalArgsTerm, EvalMethod, PredArgsTerm), + PredArgsTerm = term__functor(term__atom("pred"), PredArgsList, _), + parse_pred_expr_args(PredArgsList, Args, Modes), + inst_var_constraints_are_consistent_in_modes(Modes). parse_dcg_pred_expression(PredTerm, EvalMethod, Args, Modes, Det) :- - PredTerm = term__functor(term__atom("is"), - [PredEvalArgsTerm, DetTerm], _), - DetTerm = term__functor(term__atom(DetString), [], _), - standard_det(DetString, Det), - parse_lambda_eval_method(PredEvalArgsTerm, EvalMethod, PredArgsTerm), - PredArgsTerm = term__functor(term__atom("pred"), PredArgsList, _), - parse_dcg_pred_expr_args(PredArgsList, Args, Modes), - inst_var_constraints_are_consistent_in_modes(Modes). + PredTerm = term__functor(term__atom("is"), [PredEvalArgsTerm, DetTerm], _), + DetTerm = term__functor(term__atom(DetString), [], _), + standard_det(DetString, Det), + parse_lambda_eval_method(PredEvalArgsTerm, EvalMethod, PredArgsTerm), + PredArgsTerm = term__functor(term__atom("pred"), PredArgsList, _), + parse_dcg_pred_expr_args(PredArgsList, Args, Modes), + inst_var_constraints_are_consistent_in_modes(Modes). parse_func_expression(FuncTerm, EvalMethod, Args, Modes, Det) :- - % - % Parse a func expression with specified modes and determinism. - % - FuncTerm = term__functor(term__atom("is"), [EqTerm, DetTerm], _), - EqTerm = term__functor(term__atom("="), - [FuncEvalArgsTerm, RetTerm], _), - DetTerm = term__functor(term__atom(DetString), [], _), - standard_det(DetString, Det), - parse_lambda_eval_method(FuncEvalArgsTerm, EvalMethod, FuncArgsTerm), - FuncArgsTerm = term__functor(term__atom("func"), FuncArgsList, _), + % Parse a func expression with specified modes and determinism. + FuncTerm = term__functor(term__atom("is"), [EqTerm, DetTerm], _), + EqTerm = term__functor(term__atom("="), [FuncEvalArgsTerm, RetTerm], _), + DetTerm = term__functor(term__atom(DetString), [], _), + standard_det(DetString, Det), + parse_lambda_eval_method(FuncEvalArgsTerm, EvalMethod, FuncArgsTerm), + FuncArgsTerm = term__functor(term__atom("func"), FuncArgsList, _), - ( parse_pred_expr_args(FuncArgsList, Args0, Modes0) -> - parse_lambda_arg(RetTerm, RetArg, RetMode), - list__append(Args0, [RetArg], Args), - list__append(Modes0, [RetMode], Modes), - inst_var_constraints_are_consistent_in_modes(Modes) - ; - % - % The argument modes default to `in', - % the return mode defaults to `out'. - % - in_mode(InMode), - out_mode(OutMode), - list__length(FuncArgsList, NumArgs), - list__duplicate(NumArgs, InMode, Modes0), - RetMode = OutMode, - list__append(Modes0, [RetMode], Modes), - list__append(FuncArgsList, [RetTerm], Args1), - list__map(term__coerce, Args1, Args) - ). + ( parse_pred_expr_args(FuncArgsList, Args0, Modes0) -> + parse_lambda_arg(RetTerm, RetArg, RetMode), + list__append(Args0, [RetArg], Args), + list__append(Modes0, [RetMode], Modes), + inst_var_constraints_are_consistent_in_modes(Modes) + ; + % The argument modes default to `in', + % the return mode defaults to `out'. + in_mode(InMode), + out_mode(OutMode), + list__length(FuncArgsList, NumArgs), + list__duplicate(NumArgs, InMode, Modes0), + RetMode = OutMode, + list__append(Modes0, [RetMode], Modes), + list__append(FuncArgsList, [RetTerm], Args1), + list__map(term__coerce, Args1, Args) + ). parse_func_expression(FuncTerm, EvalMethod, Args, Modes, Det) :- - % - % parse a func expression with unspecified modes and determinism - % - FuncTerm = term__functor(term__atom("="), - [FuncEvalArgsTerm, RetTerm], _), - parse_lambda_eval_method(FuncEvalArgsTerm, EvalMethod, FuncArgsTerm), - FuncArgsTerm = term__functor(term__atom("func"), Args0, _), - % - % the argument modes default to `in', - % the return mode defaults to `out', - % and the determinism defaults to `det'. - % - in_mode(InMode), - out_mode(OutMode), - list__length(Args0, NumArgs), - list__duplicate(NumArgs, InMode, Modes0), - RetMode = OutMode, - Det = det, - list__append(Modes0, [RetMode], Modes), - inst_var_constraints_are_consistent_in_modes(Modes), - list__append(Args0, [RetTerm], Args1), - list__map(term__coerce, Args1, Args). + % Parse a func expression with unspecified modes and determinism. + FuncTerm = term__functor(term__atom("="), [FuncEvalArgsTerm, RetTerm], _), + parse_lambda_eval_method(FuncEvalArgsTerm, EvalMethod, FuncArgsTerm), + FuncArgsTerm = term__functor(term__atom("func"), Args0, _), + + % The argument modes default to `in', + % the return mode defaults to `out', + % and the determinism defaults to `det'. + in_mode(InMode), + out_mode(OutMode), + list__length(Args0, NumArgs), + list__duplicate(NumArgs, InMode, Modes0), + RetMode = OutMode, + Det = det, + list__append(Modes0, [RetMode], Modes), + inst_var_constraints_are_consistent_in_modes(Modes), + list__append(Args0, [RetTerm], Args1), + list__map(term__coerce, Args1, Args). parse_lambda_eval_method(Term0, EvalMethod, Term) :- - ( Term0 = term__functor(term__atom(MethodStr), [Term1], _) -> - ( MethodStr = "aditi_bottom_up" -> - EvalMethod = (aditi_bottom_up), - Term = Term1 - ; - EvalMethod = normal, - Term = Term0 - ) - ; - EvalMethod = normal, - Term = Term0 - ). + ( Term0 = term__functor(term__atom(MethodStr), [Term1], _) -> + ( MethodStr = "aditi_bottom_up" -> + EvalMethod = (aditi_bottom_up), + Term = Term1 + ; + EvalMethod = normal, + Term = Term0 + ) + ; + EvalMethod = normal, + Term = Term0 + ). :- pred parse_pred_expr_args(list(term)::in, list(prog_term)::out, - list(mode)::out) is semidet. + list(mode)::out) is semidet. parse_pred_expr_args([], [], []). parse_pred_expr_args([Term|Terms], [Arg|Args], [Mode|Modes]) :- - parse_lambda_arg(Term, Arg, Mode), - parse_pred_expr_args(Terms, Args, Modes). + parse_lambda_arg(Term, Arg, Mode), + parse_pred_expr_args(Terms, Args, Modes). - % parse_dcg_pred_expr_args is like parse_pred_expr_args except - % that the last two elements of the list are the modes of the - % two dcg arguments. + % parse_dcg_pred_expr_args is like parse_pred_expr_args except + % that the last two elements of the list are the modes of the + % two DCG arguments. + % :- pred parse_dcg_pred_expr_args(list(term)::in, list(prog_term)::out, - list(mode)::out) is semidet. + list(mode)::out) is semidet. parse_dcg_pred_expr_args([DCGModeTermA, DCGModeTermB], [], - [DCGModeA, DCGModeB]) :- - convert_mode(allow_constrained_inst_var, DCGModeTermA, DCGModeA0), - convert_mode(allow_constrained_inst_var, DCGModeTermB, DCGModeB0), - constrain_inst_vars_in_mode(DCGModeA0, DCGModeA), - constrain_inst_vars_in_mode(DCGModeB0, DCGModeB). + [DCGModeA, DCGModeB]) :- + convert_mode(allow_constrained_inst_var, DCGModeTermA, DCGModeA0), + convert_mode(allow_constrained_inst_var, DCGModeTermB, DCGModeB0), + constrain_inst_vars_in_mode(DCGModeA0, DCGModeA), + constrain_inst_vars_in_mode(DCGModeB0, DCGModeB). parse_dcg_pred_expr_args([Term|Terms], [Arg|Args], [Mode|Modes]) :- - Terms = [_, _|_], - parse_lambda_arg(Term, Arg, Mode), - parse_dcg_pred_expr_args(Terms, Args, Modes). + Terms = [_, _ | _], + parse_lambda_arg(Term, Arg, Mode), + parse_dcg_pred_expr_args(Terms, Args, Modes). %-----------------------------------------------------------------------------% diff --git a/compiler/prog_io_pragma.m b/compiler/prog_io_pragma.m index 9efdc88d6..fc06b440b 100644 --- a/compiler/prog_io_pragma.m +++ b/compiler/prog_io_pragma.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% vim:ts=4 sw=4 expandtab +% vim: ts=4 sw=4 expandtab %-----------------------------------------------------------------------------% % Copyright (C) 1996-2005 The University of Melbourne. % This file may only be copied under the terms of the GNU General diff --git a/compiler/prog_io_typeclass.m b/compiler/prog_io_typeclass.m index 2f7d25dba..365b0488c 100644 --- a/compiler/prog_io_typeclass.m +++ b/compiler/prog_io_typeclass.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 1997-2005 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. @@ -22,24 +24,28 @@ :- import_module term. :- import_module varset. - % parse a typeclass declaration. + % Parse a typeclass declaration. + % :- pred parse_typeclass(module_name::in, varset::in, list(term)::in, - maybe1(item)::out) is semidet. + maybe1(item)::out) is semidet. - % parse an instance declaration. + % Parse an instance declaration. + % :- pred parse_instance(module_name::in, varset::in, list(term)::in, - maybe1(item)::out) is semidet. + maybe1(item)::out) is semidet. - % parse a list of class constraints + % Parse a list of class constraints. + % :- pred parse_class_constraints(module_name::in, term::in, - maybe1(list(prog_constraint))::out) is det. + maybe1(list(prog_constraint))::out) is det. - % parse a list of class and inst constraints + % Parse a list of class and inst constraints. + % :- pred parse_class_and_inst_constraints(module_name::in, term::in, - maybe_class_and_inst_constraints::out) is det. + maybe_class_and_inst_constraints::out) is det. :- type maybe_class_and_inst_constraints == - maybe2(list(prog_constraint), inst_var_sub). + maybe2(list(prog_constraint), inst_var_sub). :- implementation. @@ -58,789 +64,712 @@ :- import_module varset. parse_typeclass(ModuleName, VarSet, TypeClassTerm, Result) :- - %XXX should return an error if we get more than one arg, - %XXX rather than failing. - TypeClassTerm = [Arg], - ( - Arg = term__functor(term__atom("where"), [Name, Methods], _) - -> - parse_non_empty_class(ModuleName, Name, Methods, VarSet, - Result) - ; - parse_class_head(ModuleName, Arg, VarSet, Result) - ). + % XXX We should return an error if we get more than one arg, instead of + % failing. + TypeClassTerm = [Arg], + ( Arg = term__functor(term__atom("where"), [Name, Methods], _) -> + parse_non_empty_class(ModuleName, Name, Methods, VarSet, Result) + ; + parse_class_head(ModuleName, Arg, VarSet, Result) + ). :- pred parse_non_empty_class(module_name::in, term::in, term::in, varset::in, - maybe1(item)::out) is det. + maybe1(item)::out) is det. parse_non_empty_class(ModuleName, Name, Methods, VarSet, Result) :- - varset__coerce(VarSet, TVarSet), - parse_class_methods(ModuleName, Methods, VarSet, ParsedMethods), - ( - ParsedMethods = ok(MethodList), - parse_class_head(ModuleName, Name, VarSet, ParsedNameAndVars), - ( - ParsedNameAndVars = error(String, Term) - -> - Result = error(String, Term) - ; - ParsedNameAndVars = ok(Item), - Item = typeclass(_, _, _, _, _, _) - -> - Result = ok((Item - ^ tc_class_methods := concrete(MethodList)) - ^ tc_varset := TVarSet) - ; - % if the item we get back isn't a typeclass, - % something has gone wrong... - error("prog_io_typeclass.m: item should be a typeclass") - ) - ; - ParsedMethods = error(String, Term), - Result = error(String, Term) - ). + varset__coerce(VarSet, TVarSet), + parse_class_methods(ModuleName, Methods, VarSet, ParsedMethods), + ( + ParsedMethods = ok(MethodList), + parse_class_head(ModuleName, Name, VarSet, ParsedNameAndVars), + ( + ParsedNameAndVars = error(String, Term) + -> + Result = error(String, Term) + ; + ParsedNameAndVars = ok(Item), + Item = typeclass(_, _, _, _, _, _) + -> + Result = ok((Item + ^ tc_class_methods := concrete(MethodList)) + ^ tc_varset := TVarSet) + ; + % If the item we get back isn't a typeclass, + % something has gone wrong... + error("prog_io_typeclass.m: item should be a typeclass") + ) + ; + ParsedMethods = error(String, Term), + Result = error(String, Term) + ). :- pred parse_class_head(module_name::in, term::in, varset::in, - maybe1(item)::out) is det. + maybe1(item)::out) is det. parse_class_head(ModuleName, Arg, VarSet, Result) :- - ( - Arg = term__functor(term__atom("<="), [Name, Constraints], _) - -> - parse_constrained_class(ModuleName, Name, Constraints, VarSet, - Result) - ; - varset__coerce(VarSet, TVarSet), - parse_unconstrained_class(ModuleName, Arg, TVarSet, Result) - ). + ( + Arg = term__functor(term__atom("<="), [Name, Constraints], _) + -> + parse_constrained_class(ModuleName, Name, Constraints, VarSet, Result) + ; + varset__coerce(VarSet, TVarSet), + parse_unconstrained_class(ModuleName, Arg, TVarSet, Result) + ). :- pred parse_constrained_class(module_name::in, term::in, term::in, - varset::in, maybe1(item)::out) is det. + varset::in, maybe1(item)::out) is det. parse_constrained_class(ModuleName, Decl, Constraints, VarSet, Result) :- - varset__coerce(VarSet, TVarSet), - parse_superclass_constraints(ModuleName, Constraints, - ParsedConstraints), - ( - ParsedConstraints = ok(ConstraintList, FunDeps), - parse_unconstrained_class(ModuleName, Decl, TVarSet, Result0), - ( - Result0 = error(_, _) - -> - Result = Result0 - ; - Result0 = ok(Item), - Item = typeclass(_, _, _, _, _, _) - -> - ( - % - % Check for type variables in the constraints - % which do not occur in the type class - % parameters. - % - prog_type__constraint_list_get_tvars( - ConstraintList, ConstrainedVars), - list__member(Var, ConstrainedVars), - \+ list__member(Var, Item ^ tc_class_params) - -> - Result = error("type variable in " ++ - "superclass constraint is not " ++ - "a parameter of this type class", - Constraints) - ; - % - % Check for type variables in the fundeps - % which do not occur in the type class - % parameters. - % - list__member(FunDep, FunDeps), - FunDep = fundep(Domain, Range), - ( - list__member(Var, Domain) - ; - list__member(Var, Range) - ), - \+ list__member(Var, Item ^ tc_class_params) - -> - Result = error("type variable in " ++ - "functional dependency is not " ++ - "a parameter of this type class", - Constraints) - ; - Result = ok((Item - ^ tc_constraints := ConstraintList) - ^ tc_fundeps := FunDeps) - ) - ; - % if the item we get back isn't a typeclass, - % something has gone wrong... - error("prog_io_typeclass.m: item should be a typeclass") - ) - ; - ParsedConstraints = error(String, Term), - Result = error(String, Term) - ). + varset__coerce(VarSet, TVarSet), + parse_superclass_constraints(ModuleName, Constraints, + ParsedConstraints), + ( + ParsedConstraints = ok(ConstraintList, FunDeps), + parse_unconstrained_class(ModuleName, Decl, TVarSet, Result0), + ( + Result0 = error(_, _) + -> + Result = Result0 + ; + Result0 = ok(Item), + Item = typeclass(_, _, _, _, _, _) + -> + ( + % Check for type variables in the constraints which do not + % occur in the type class parameters. + prog_type__constraint_list_get_tvars(ConstraintList, + ConstrainedVars), + list__member(Var, ConstrainedVars), + \+ list__member(Var, Item ^ tc_class_params) + -> + Result = error("type variable in superclass constraint " ++ + "is not a parameter of this type class", Constraints) + ; + % Check for type variables in the fundeps which do not occur + % in the type class parameters. + list__member(FunDep, FunDeps), + FunDep = fundep(Domain, Range), + ( + list__member(Var, Domain) + ; + list__member(Var, Range) + ), + \+ list__member(Var, Item ^ tc_class_params) + -> + Result = error("type variable in functional dependency " ++ + "is not a parameter of this type class", Constraints) + ; + Result = ok((Item + ^ tc_constraints := ConstraintList) + ^ tc_fundeps := FunDeps) + ) + ; + % If the item we get back isn't a typeclass, + % something has gone wrong... + error("prog_io_typeclass.m: item should be a typeclass") + ) + ; + ParsedConstraints = error(String, Term), + Result = error(String, Term) + ). :- pred parse_superclass_constraints(module_name::in, term::in, - maybe2(list(prog_constraint), list(prog_fundep))::out) is det. + maybe2(list(prog_constraint), list(prog_fundep))::out) is det. parse_superclass_constraints(_ModuleName, ConstraintsTerm, Result) :- - parse_arbitrary_constraints(ConstraintsTerm, Result0), - ( - Result0 = ok(ArbitraryConstraints), - ( - collect_simple_and_fundep_constraints( - ArbitraryConstraints, - Constraints, FunDeps) - -> - Result = ok(Constraints, FunDeps) - ; - ErrorMessage = "constraints on class declarations" ++ - " may only constrain type variables and" ++ - " ground types", - Result = error(ErrorMessage, ConstraintsTerm) - ) - ; - Result0 = error(String, Term), - Result = error(String, Term) - ). + parse_arbitrary_constraints(ConstraintsTerm, Result0), + ( + Result0 = ok(ArbitraryConstraints), + ( + collect_simple_and_fundep_constraints(ArbitraryConstraints, + Constraints, FunDeps) + -> + Result = ok(Constraints, FunDeps) + ; + ErrorMessage = "constraints on class declarations" ++ + " may only constrain type variables and ground types", + Result = error(ErrorMessage, ConstraintsTerm) + ) + ; + Result0 = error(String, Term), + Result = error(String, Term) + ). :- pred collect_simple_and_fundep_constraints(list(arbitrary_constraint)::in, - list(prog_constraint)::out, list(prog_fundep)::out) is semidet. + list(prog_constraint)::out, list(prog_fundep)::out) is semidet. collect_simple_and_fundep_constraints([], [], []). collect_simple_and_fundep_constraints([Constraint | Constraints], - SimpleConstraints, FunDeps) :- - collect_simple_and_fundep_constraints(Constraints, SimpleConstraints0, - FunDeps0), - ( - Constraint = simple(SimpleConstraint), - SimpleConstraints = [SimpleConstraint | SimpleConstraints0], - FunDeps = FunDeps0 - ; - Constraint = fundep(FunDep), - FunDeps = [FunDep | FunDeps0], - SimpleConstraints = SimpleConstraints0 - ). + SimpleConstraints, FunDeps) :- + collect_simple_and_fundep_constraints(Constraints, SimpleConstraints0, + FunDeps0), + ( + Constraint = simple(SimpleConstraint), + SimpleConstraints = [SimpleConstraint | SimpleConstraints0], + FunDeps = FunDeps0 + ; + Constraint = fundep(FunDep), + FunDeps = [FunDep | FunDeps0], + SimpleConstraints = SimpleConstraints0 + ). :- pred parse_unconstrained_class(module_name::in, term::in, tvarset::in, - maybe1(item)::out) is det. + maybe1(item)::out) is det. parse_unconstrained_class(ModuleName, Name, TVarSet, Result) :- - parse_implicitly_qualified_term(ModuleName, - Name, Name, "typeclass declaration", MaybeClassName), - ( - MaybeClassName = ok(ClassName, TermVars0), - list__map(term__coerce, TermVars0, TermVars), - ( - term__var_list_to_term_list(Vars, TermVars), - list__sort_and_remove_dups(TermVars, SortedTermVars), - list__length(SortedTermVars) = - list__length(TermVars) `with_type` int - -> - Result = ok(typeclass([], [], ClassName, Vars, - abstract, TVarSet)) - ; - Result = error("expected distinct variables " ++ - "as class parameters", Name) - ) - ; - MaybeClassName = error(String, Term), - Result = error(String, Term) - ). + parse_implicitly_qualified_term(ModuleName, + Name, Name, "typeclass declaration", MaybeClassName), + ( + MaybeClassName = ok(ClassName, TermVars0), + list__map(term__coerce, TermVars0, TermVars), + ( + term__var_list_to_term_list(Vars, TermVars), + list__sort_and_remove_dups(TermVars, SortedTermVars), + list__length(SortedTermVars) = list__length(TermVars) : int + -> + Result = ok(typeclass([], [], ClassName, Vars, abstract, TVarSet)) + ; + Result = error("expected distinct variables " ++ + "as class parameters", Name) + ) + ; + MaybeClassName = error(String, Term), + Result = error(String, Term) + ). :- pred parse_class_methods(module_name::in, term::in, varset::in, - maybe1(list(class_method))::out) is det. + maybe1(list(class_method))::out) is det. parse_class_methods(ModuleName, Methods, VarSet, Result) :- - ( - list_term_to_term_list(Methods, MethodList) - % Convert the list of terms into a list of - % maybe1(class_method)s. - -> - list__map((pred(MethodTerm::in, Method::out) is det :- - % Turn the term into an item - parse_decl(ModuleName, VarSet, MethodTerm, - Item), - % Turn the item into a class_method - item_to_class_method(Item, MethodTerm, Method) - ), MethodList, Interface), - find_errors(Interface, Result) - ; - Result = error("expected list of class methods", Methods) - ). + ( + % Convert the list of terms into a list of maybe1(class_method)s. + list_term_to_term_list(Methods, MethodList) + -> + list__map((pred(MethodTerm::in, Method::out) is det :- + % Turn the term into an item. + parse_decl(ModuleName, VarSet, MethodTerm, Item), + % Turn the item into a class_method. + item_to_class_method(Item, MethodTerm, Method) + ), MethodList, Interface), + find_errors(Interface, Result) + ; + Result = error("expected list of class methods", Methods) + ). :- pred item_to_class_method(maybe2(item, prog_context)::in, term::in, - maybe1(class_method)::out) is det. + maybe1(class_method)::out) is det. item_to_class_method(error(String, Term), _, error(String, Term)). item_to_class_method(ok(Item, Context), Term, Result) :- - ( - Item = pred_or_func(A, B, C, D, E, F, G, H, I, J, K, L) - -> - Result = ok(pred_or_func(A, B, C, D, E, F, G, H, I, J, K, L, - Context)) - ; - Item = pred_or_func_mode(A, B, C, D, E, F, G) - -> - Result = ok(pred_or_func_mode(A, B, C, D, E, F, G, Context)) - ; - Result = error("Only pred, func and mode declarations " ++ - "allowed in class interface", Term) - ). + ( + Item = pred_or_func(A, B, C, D, E, F, G, H, I, J, K, L) + -> + Result = ok(pred_or_func(A, B, C, D, E, F, G, H, I, J, K, L, Context)) + ; + Item = pred_or_func_mode(A, B, C, D, E, F, G) + -> + Result = ok(pred_or_func_mode(A, B, C, D, E, F, G, Context)) + ; + Result = error("Only pred, func and mode declarations " ++ + "allowed in class interface", Term) + ). - % from a list of maybe1s, search through until you find an error. - % If an error is found, return it. - % If no error is found, return ok(the original elements). + % From a list of maybe1s, search through until you find an error. + % If an error is found, return it. + % If no error is found, return ok(the original elements). + % :- pred find_errors(list(maybe1(T))::in, maybe1(list(T))::out) is det. find_errors([], ok([])). find_errors([X|Xs], Result) :- - ( - X = ok(Method), - find_errors(Xs, Result0), - ( - Result0 = ok(Methods), - Result = ok([Method|Methods]) - ; - Result0 = error(String, Term), - Result = error(String, Term) - ) - ; - X = error(String, Term), - Result = error(String, Term) - ). + ( + X = ok(Method), + find_errors(Xs, Result0), + ( + Result0 = ok(Methods), + Result = ok([Method|Methods]) + ; + Result0 = error(String, Term), + Result = error(String, Term) + ) + ; + X = error(String, Term), + Result = error(String, Term) + ). %-----------------------------------------------------------------------------% % % Predicates for parsing various kinds of constraints. % - % Parse constraints on a pred or func declaration, or on an - % existentially quantified type definition. Currently all such - % constraints must be simple. - % + % Parse constraints on a pred or func declaration, or on an existentially + % quantified type definition. Currently all such constraints must be + % simple. + % parse_class_constraints(ModuleName, ConstraintsTerm, Result) :- - ErrorMessage = "sorry, not implemented:" ++ - " constraints may only constrain type variables" ++ - " and ground types", - parse_simple_class_constraints(ModuleName, ConstraintsTerm, - ErrorMessage, Result). + ErrorMessage = "sorry, not implemented:" ++ + " constraints may only constrain type variables" ++ + " and ground types", + parse_simple_class_constraints(ModuleName, ConstraintsTerm, + ErrorMessage, Result). :- pred parse_simple_class_constraints(module_name::in, term::in, string::in, - maybe1(list(prog_constraint))::out) is det. + maybe1(list(prog_constraint))::out) is det. parse_simple_class_constraints(_ModuleName, ConstraintsTerm, ErrorMessage, - Result) :- - parse_arbitrary_constraints(ConstraintsTerm, Result0), - ( - Result0 = ok(ArbitraryConstraints), - ( - % Fail if any of the constraints aren't simple. - list.map(get_simple_constraint, ArbitraryConstraints, - Constraints) - -> - Result = ok(Constraints) - ; - Result = error(ErrorMessage, ConstraintsTerm) - ) - ; - Result0 = error(String, Term), - Result = error(String, Term) - ). + Result) :- + parse_arbitrary_constraints(ConstraintsTerm, Result0), + ( + Result0 = ok(ArbitraryConstraints), + ( + % Fail if any of the constraints aren't simple. + list.map(get_simple_constraint, ArbitraryConstraints, Constraints) + -> + Result = ok(Constraints) + ; + Result = error(ErrorMessage, ConstraintsTerm) + ) + ; + Result0 = error(String, Term), + Result = error(String, Term) + ). :- pred get_simple_constraint(arbitrary_constraint::in, prog_constraint::out) - is semidet. + is semidet. get_simple_constraint(simple(Constraint), Constraint). parse_class_and_inst_constraints(_ModuleName, ConstraintsTerm, Result) :- - parse_arbitrary_constraints(ConstraintsTerm, Result0), - ( - Result0 = ok(ArbitraryConstraints), - ( - collect_class_and_inst_constraints(ArbitraryConstraints, - ProgConstraints, InstVarSub) - -> - Result = ok(ProgConstraints, InstVarSub) - ; - ErrorMessage = "functional dependencies are only" ++ - " allowed in typeclass declarations", - Result = error(ErrorMessage, ConstraintsTerm) - ) - ; - Result0 = error(Msg, Term), - Result = error(Msg, Term) - ). + parse_arbitrary_constraints(ConstraintsTerm, Result0), + ( + Result0 = ok(ArbitraryConstraints), + ( + collect_class_and_inst_constraints(ArbitraryConstraints, + ProgConstraints, InstVarSub) + -> + Result = ok(ProgConstraints, InstVarSub) + ; + ErrorMessage = "functional dependencies are only" ++ + " allowed in typeclass declarations", + Result = error(ErrorMessage, ConstraintsTerm) + ) + ; + Result0 = error(Msg, Term), + Result = error(Msg, Term) + ). :- pred collect_class_and_inst_constraints(list(arbitrary_constraint)::in, - list(prog_constraint)::out, inst_var_sub::out) is semidet. + list(prog_constraint)::out, inst_var_sub::out) is semidet. collect_class_and_inst_constraints([], [], map.init). collect_class_and_inst_constraints([Constraint | Constraints], - ProgConstraints, InstVarSub) :- - collect_class_and_inst_constraints(Constraints, ProgConstraints0, - InstVarSub0), - ( - Constraint = simple(SimpleConstraint), - ProgConstraints = [SimpleConstraint | ProgConstraints0], - InstVarSub = InstVarSub0 - ; - Constraint = non_simple(ClassConstraint), - ProgConstraints = [ClassConstraint | ProgConstraints0], - InstVarSub = InstVarSub0 - ; - Constraint = inst_constraint(InstVar, Inst), - map.set(InstVarSub0, InstVar, Inst, InstVarSub), - ProgConstraints = ProgConstraints0 - ). + ProgConstraints, InstVarSub) :- + collect_class_and_inst_constraints(Constraints, ProgConstraints0, + InstVarSub0), + ( + Constraint = simple(SimpleConstraint), + ProgConstraints = [SimpleConstraint | ProgConstraints0], + InstVarSub = InstVarSub0 + ; + Constraint = non_simple(ClassConstraint), + ProgConstraints = [ClassConstraint | ProgConstraints0], + InstVarSub = InstVarSub0 + ; + Constraint = inst_constraint(InstVar, Inst), + map.set(InstVarSub0, InstVar, Inst, InstVarSub), + ProgConstraints = ProgConstraints0 + ). :- type arbitrary_constraint - ---> simple(prog_constraint) - % A class constraint whose arguments are either - % variables or ground terms. + ---> simple(prog_constraint) + % A class constraint whose arguments are either variables + % or ground terms. - ; non_simple(prog_constraint) - % An arbitrary class constraint not matching the - % description of "simple". + ; non_simple(prog_constraint) + % An arbitrary class constraint not matching the description + % of "simple". - ; inst_constraint(inst_var, inst) - % A constraint on an inst variable (that is, one - % whose head is '=<'/2). + ; inst_constraint(inst_var, inst) + % A constraint on an inst variable (that is, one whose head + % is '=<'/2). - ; fundep(prog_fundep). - % A functional dependency (that is, one whose head - % is '->'/2 and whose arguments are comma-separated - % variables. + ; fundep(prog_fundep). + % A functional dependency (that is, one whose head is '->'/2 + % and whose arguments are comma-separated variables. :- type arbitrary_constraints == list(arbitrary_constraint). :- pred parse_arbitrary_constraints(term::in, - maybe1(arbitrary_constraints)::out) is det. + maybe1(arbitrary_constraints)::out) is det. parse_arbitrary_constraints(ConstraintsTerm, Result) :- - conjunction_to_list(ConstraintsTerm, ConstraintList), - parse_arbitrary_constraint_list(ConstraintList, Result). + conjunction_to_list(ConstraintsTerm, ConstraintList), + parse_arbitrary_constraint_list(ConstraintList, Result). :- pred parse_arbitrary_constraint_list(list(term)::in, - maybe1(arbitrary_constraints)::out) is det. + maybe1(arbitrary_constraints)::out) is det. parse_arbitrary_constraint_list([], ok([])). parse_arbitrary_constraint_list([Term | Terms], Result) :- - parse_arbitrary_constraint(Term, Result0), - parse_arbitrary_constraint_list(Terms, Result1), - Result = combine_parse_results(Result0, Result1). + parse_arbitrary_constraint(Term, Result0), + parse_arbitrary_constraint_list(Terms, Result1), + Result = combine_parse_results(Result0, Result1). :- func combine_parse_results(maybe1(arbitrary_constraint), - maybe1(arbitrary_constraints)) = maybe1(arbitrary_constraints). + maybe1(arbitrary_constraints)) = maybe1(arbitrary_constraints). combine_parse_results(error(String, Term), _) = error(String, Term). combine_parse_results(ok(_), error(String, Term)) = error(String, Term). combine_parse_results(ok(Constraint), ok(Constraints)) = - ok([Constraint | Constraints]). + ok([Constraint | Constraints]). :- pred parse_arbitrary_constraint(term::in, maybe1(arbitrary_constraint)::out) - is det. + is det. parse_arbitrary_constraint(ConstraintTerm, Result) :- - ( - parse_inst_constraint(ConstraintTerm, InstVar, Inst) - -> - Result = ok(inst_constraint(InstVar, Inst)) - ; - parse_fundep(ConstraintTerm, Result0) - -> - Result = Result0 - ; - parse_qualified_term(ConstraintTerm, ConstraintTerm, - "class constraint", ok(ClassName, Args0)) - -> - parse_types(Args0, ArgsResult), - ( - ArgsResult = ok(Args), - Constraint = constraint(ClassName, Args), - ( - constraint_is_not_simple(Constraint) - -> - Result = ok(non_simple(Constraint)) - ; - Result = ok(simple(Constraint)) - ) - ; - ArgsResult = error(Msg, ErrorTerm), - Result = error(Msg, ErrorTerm) - ) - ; - Result = error("expected atom as class name or inst constraint", - ConstraintTerm) - ). + ( + parse_inst_constraint(ConstraintTerm, InstVar, Inst) + -> + Result = ok(inst_constraint(InstVar, Inst)) + ; + parse_fundep(ConstraintTerm, Result0) + -> + Result = Result0 + ; + parse_qualified_term(ConstraintTerm, ConstraintTerm, + "class constraint", ok(ClassName, Args0)) + -> + parse_types(Args0, ArgsResult), + ( + ArgsResult = ok(Args), + Constraint = constraint(ClassName, Args), + ( constraint_is_not_simple(Constraint) -> + Result = ok(non_simple(Constraint)) + ; + Result = ok(simple(Constraint)) + ) + ; + ArgsResult = error(Msg, ErrorTerm), + Result = error(Msg, ErrorTerm) + ) + ; + Result = error("expected atom as class name or inst constraint", + ConstraintTerm) + ). :- pred parse_inst_constraint(term::in, inst_var::out, (inst)::out) is semidet. parse_inst_constraint(Term, InstVar, Inst) :- - Term = term__functor(term__atom("=<"), [Arg1, Arg2], _), - Arg1 = term__variable(InstVar0), - term__coerce_var(InstVar0, InstVar), - convert_inst(no_allow_constrained_inst_var, Arg2, Inst). + Term = term__functor(term__atom("=<"), [Arg1, Arg2], _), + Arg1 = term__variable(InstVar0), + term__coerce_var(InstVar0, InstVar), + convert_inst(no_allow_constrained_inst_var, Arg2, Inst). :- pred parse_fundep(term::in, maybe1(arbitrary_constraint)::out) is semidet. parse_fundep(Term, Result) :- - Term = term__functor(term__atom("->"), [DomainTerm, RangeTerm], _), - ( - parse_fundep_2(DomainTerm, Domain), - parse_fundep_2(RangeTerm, Range) - -> - Result = ok(fundep(fundep(Domain, Range))) - ; - ErrorMessage = "domain and range of functional dependency" ++ - " must be comma-separated lists of variables", - Result = error(ErrorMessage, Term) - ). + Term = term__functor(term__atom("->"), [DomainTerm, RangeTerm], _), + ( + parse_fundep_2(DomainTerm, Domain), + parse_fundep_2(RangeTerm, Range) + -> + Result = ok(fundep(fundep(Domain, Range))) + ; + ErrorMessage = "domain and range of functional dependency " ++ + "must be comma-separated lists of variables", + Result = error(ErrorMessage, Term) + ). :- pred parse_fundep_2(term::in, list(tvar)::out) is semidet. parse_fundep_2(Term, TVars) :- - TypeTerm = term__coerce(Term), - conjunction_to_list(TypeTerm, List), - term__var_list_to_term_list(TVars, List). + TypeTerm = term__coerce(Term), + conjunction_to_list(TypeTerm, List), + term__var_list_to_term_list(TVars, List). :- pred constraint_is_not_simple(prog_constraint::in) is semidet. constraint_is_not_simple(constraint(_Name, Types)) :- - some [Type] ( - list__member(Type, Types), - type_is_nonvar(Type), - type_is_nonground(Type) - ). + some [Type] ( + list__member(Type, Types), + type_is_nonvar(Type), + type_is_nonground(Type) + ). %-----------------------------------------------------------------------------% parse_instance(ModuleName, VarSet, TypeClassTerm, Result) :- - %XXX should return an error if we get more than one arg, - %XXX rather than failing. - TypeClassTerm = [Arg], - varset__coerce(VarSet, TVarSet), - ( - Arg = term__functor(term__atom("where"), [Name, Methods], _) - -> - parse_non_empty_instance(ModuleName, Name, Methods, VarSet, - TVarSet, Result) - ; - parse_instance_name(ModuleName, Arg, TVarSet, Result) - ). + % XXX We should return an error if we get more than one arg, + % instead of failing. + TypeClassTerm = [Arg], + varset__coerce(VarSet, TVarSet), + ( Arg = term__functor(term__atom("where"), [Name, Methods], _) -> + parse_non_empty_instance(ModuleName, Name, Methods, VarSet, TVarSet, + Result) + ; + parse_instance_name(ModuleName, Arg, TVarSet, Result) + ). :- pred parse_instance_name(module_name::in, term::in, tvarset::in, - maybe1(item)::out) is det. + maybe1(item)::out) is det. parse_instance_name(ModuleName, Arg, TVarSet, Result) :- - ( - Arg = term__functor(term__atom("<="), [Name, Constraints], _) - -> - parse_derived_instance(ModuleName, Name, Constraints, - TVarSet, Result) - ; - parse_underived_instance(ModuleName, Arg, TVarSet, Result) - ). + ( Arg = term__functor(term__atom("<="), [Name, Constraints], _) -> + parse_derived_instance(ModuleName, Name, Constraints, TVarSet, Result) + ; + parse_underived_instance(ModuleName, Arg, TVarSet, Result) + ). :- pred parse_derived_instance(module_name::in, term::in, term::in, - tvarset::in, maybe1(item)::out) is det. + tvarset::in, maybe1(item)::out) is det. -parse_derived_instance(ModuleName, Decl, Constraints, TVarSet, - Result) :- - parse_instance_constraints(ModuleName, Constraints, ParsedConstraints), - ( - ParsedConstraints = ok(ConstraintList), - parse_underived_instance(ModuleName, Decl, TVarSet, - Result0), - ( - Result0 = error(_, _) - -> - Result = Result0 - ; - Result0 = ok(instance(_, Name, Types, Body, VarSet, - ModName)) - -> - Result = ok(instance(ConstraintList, Name, Types, Body, - VarSet, ModName)) - ; - % if the item we get back isn't an instance, - % something has gone wrong... - % maybe we should use cleverer inst decls to - % avoid this call to error - error("prog_io_typeclass.m: item should be an instance") - ) - ; - ParsedConstraints = error(String, Term), - Result = error(String, Term) - ). +parse_derived_instance(ModuleName, Decl, Constraints, TVarSet, Result) :- + parse_instance_constraints(ModuleName, Constraints, ParsedConstraints), + ( + ParsedConstraints = ok(ConstraintList), + parse_underived_instance(ModuleName, Decl, TVarSet, Result0), + ( + Result0 = error(_, _) + -> + Result = Result0 + ; + Result0 = ok(instance(_, Name, Types, Body, VarSet, ModName)) + -> + Result = ok(instance(ConstraintList, Name, Types, Body, VarSet, + ModName)) + ; + % If the item we get back isn't an instance, + % something has gone wrong... + % Maybe we should use cleverer inst decls to avoid + % this call to error. + error("prog_io_typeclass.m: item should be an instance") + ) + ; + ParsedConstraints = error(String, Term), + Result = error(String, Term) + ). :- pred parse_instance_constraints(module_name::in, term::in, - maybe1(list(prog_constraint))::out) is det. + maybe1(list(prog_constraint))::out) is det. parse_instance_constraints(ModuleName, Constraints, Result) :- - parse_simple_class_constraints(ModuleName, Constraints, - "constraints on instance declarations may only constrain" ++ - " type variables and ground types", - Result). + parse_simple_class_constraints(ModuleName, Constraints, + "constraints on instance declarations may only constrain " ++ + "type variables and ground types", Result). :- pred parse_underived_instance(module_name::in, term::in, tvarset::in, - maybe1(item)::out) is det. + maybe1(item)::out) is det. parse_underived_instance(ModuleName, Name, TVarSet, Result) :- - % We don't give a default module name here since the instance - % declaration could well be for a typeclass defined in another - % module. - parse_qualified_term(Name, Name, "instance declaration", - MaybeClassName), - ( - MaybeClassName = ok(ClassName, TermTypes), - parse_types(TermTypes, TypesResult), - parse_underived_instance_2(Name, ClassName, TypesResult, - TVarSet, ModuleName, Result) - ; - MaybeClassName = error(String, Term), - Result = error(String, Term) - ). + % We don't give a default module name here since the instance declaration + % could well be for a typeclass defined in another module. + parse_qualified_term(Name, Name, "instance declaration", MaybeClassName), + ( + MaybeClassName = ok(ClassName, TermTypes), + parse_types(TermTypes, TypesResult), + parse_underived_instance_2(Name, ClassName, TypesResult, TVarSet, + ModuleName, Result) + ; + MaybeClassName = error(String, Term), + Result = error(String, Term) + ). :- pred parse_underived_instance_2(term::in, class_name::in, - maybe1(list(type))::in, tvarset::in, module_name::in, - maybe1(item)::out) is det. + maybe1(list(type))::in, tvarset::in, module_name::in, + maybe1(item)::out) is det. parse_underived_instance_2(_, _, error(Msg, Term), _, _, error(Msg, Term)). parse_underived_instance_2(ErrorTerm, ClassName, ok(Types), TVarSet, - ModuleName, Result) :- - ( - % Check that each type in the arguments of the instance decl - % is a functor with vars as args. - % - some [Type] ( - list__member(Type, Types), - \+ type_is_functor_and_vars(Type) - ) - -> - Result = error("types in instance declarations must be" ++ - " functors with distinct variables as arguments", - ErrorTerm) - ; - Result = ok(instance([], ClassName, Types, abstract, TVarSet, - ModuleName)) - ). + ModuleName, Result) :- + ( + % Check that each type in the arguments of the instance decl + % is a functor with vars as args. + some [Type] ( + list__member(Type, Types), + \+ type_is_functor_and_vars(Type) + ) + -> + Result = error("types in instance declarations must be " ++ + "functors with distinct variables as arguments", ErrorTerm) + ; + Result = ok(instance([], ClassName, Types, abstract, TVarSet, + ModuleName)) + ). :- pred type_is_functor_and_vars((type)::in) is semidet. type_is_functor_and_vars(defined(_, Args, _)) :- - functor_args_are_variables(Args). + functor_args_are_variables(Args). type_is_functor_and_vars(builtin(_)). type_is_functor_and_vars(higher_order(Args, MaybeRet, Purity, EvalMethod)) :- - % XXX We currently allow pred types to be instance arguments, but not - % func types. Even then, the pred type must be pure and have a - % lambda_eval_method of normal. We keep this behaviour basically - % for backwards compatibility -- there is little point fixing this - % now without fixing the more general problem of having these - % restrictions in the first place. - MaybeRet = no, - Purity = (pure), - EvalMethod = normal, - functor_args_are_variables(Args). + % XXX We currently allow pred types to be instance arguments, but not + % func types. Even then, the pred type must be pure and have a + % lambda_eval_method of normal. We keep this behaviour basically + % for backwards compatibility -- there is little point fixing this + % now without fixing the more general problem of having these + % restrictions in the first place. + MaybeRet = no, + Purity = (pure), + EvalMethod = normal, + functor_args_are_variables(Args). type_is_functor_and_vars(tuple(Args, _)) :- - functor_args_are_variables(Args). + functor_args_are_variables(Args). type_is_functor_and_vars(kinded(Type, _)) :- - type_is_functor_and_vars(Type). + type_is_functor_and_vars(Type). :- pred functor_args_are_variables(list(type)::in) is semidet. functor_args_are_variables(Args) :- - all [Arg] ( - list__member(Arg, Args) - => type_is_var(Arg) - ). + all [Arg] ( + list__member(Arg, Args) + => type_is_var(Arg) + ). :- pred parse_non_empty_instance(module_name::in, term::in, term::in, - varset::in, tvarset::in, maybe1(item)::out) is det. + varset::in, tvarset::in, maybe1(item)::out) is det. parse_non_empty_instance(ModuleName, Name, Methods, VarSet, TVarSet, Result) :- - parse_instance_methods(ModuleName, Methods, VarSet, ParsedMethods), - ( - ParsedMethods = ok(MethodList), - parse_instance_name(ModuleName, Name, TVarSet, - ParsedNameAndTypes), - ( - ParsedNameAndTypes = error(String, Term) - -> - Result = error(String, Term) - ; - ParsedNameAndTypes = ok(instance(Constraints, - NameString, Types, _, _, ModName)) - -> - Result0 = ok(instance(Constraints, NameString, Types, - concrete(MethodList), TVarSet, ModName)), - check_tvars_in_instance_constraint(Result0, Name, - Result) - ; - % if the item we get back isn't a typeclass, - % something has gone wrong... - error("prog_io_typeclass.m: item should be an instance") - ) - ; - ParsedMethods = error(String, Term), - Result = error(String, Term) - ). + parse_instance_methods(ModuleName, Methods, VarSet, ParsedMethods), + ( + ParsedMethods = ok(MethodList), + parse_instance_name(ModuleName, Name, TVarSet, ParsedNameAndTypes), + ( + ParsedNameAndTypes = error(String, Term) + -> + Result = error(String, Term) + ; + ParsedNameAndTypes = ok(instance(Constraints, NameString, Types, + _, _, ModName)) + -> + Result0 = ok(instance(Constraints, NameString, Types, + concrete(MethodList), TVarSet, ModName)), + check_tvars_in_instance_constraint(Result0, Name, Result) + ; + % If the item we get back isn't a typeclass, + % something has gone wrong... + error("prog_io_typeclass.m: item should be an instance") + ) + ; + ParsedMethods = error(String, Term), + Result = error(String, Term) + ). :- pred check_tvars_in_instance_constraint(maybe1(item)::in, term::in, - maybe1(item)::out) is det. + maybe1(item)::out) is det. check_tvars_in_instance_constraint(error(M,E), _, error(M, E)). check_tvars_in_instance_constraint(ok(Item), InstanceTerm, Result) :- - ( - Item = instance(Constraints, _Name, Types, _Methods, _TVarSet, - _ModName) - -> - % - % check that all of the type variables in the constraints - % on the instance declaration also occur in the type class - % argument types in the instance declaration - % - ( - prog_type__constraint_list_get_tvars(Constraints, - TVars), - list__member(TVar, TVars), - \+ type_list_contains_var(Types, TVar) - -> - Result = error("unbound type variable(s) " ++ - "in constraints on instance declaration", - InstanceTerm) - ; - Result = ok(Item) - ) - ; - error("check_tvars_in_constraint: expecting instance item") - ). + ( + Item = instance(Constraints, _Name, Types, _Methods, _TVarSet, + _ModName) + -> + % Check that all of the type variables in the constraints + % on the instance declaration also occur in the type class + % argument types in the instance declaration. + ( + prog_type__constraint_list_get_tvars(Constraints, TVars), + list__member(TVar, TVars), + \+ type_list_contains_var(Types, TVar) + -> + Result = error("unbound type variable(s) " ++ + "in constraints on instance declaration", InstanceTerm) + ; + Result = ok(Item) + ) + ; + error("check_tvars_in_constraint: expecting instance item") + ). :- pred parse_instance_methods(module_name::in, term::in, varset::in, - maybe1(list(instance_method))::out) is det. + maybe1(list(instance_method))::out) is det. parse_instance_methods(ModuleName, Methods, VarSet, Result) :- - ( - list_term_to_term_list(Methods, MethodList) - -> - % Convert the list of terms into a list of - % maybe1(class_method)s. - list__map(term_to_instance_method(ModuleName, VarSet), - MethodList, Interface), - find_errors(Interface, Result) - ; - Result = error("expected list of instance methods", Methods) - ). + ( list_term_to_term_list(Methods, MethodList) -> + % Convert the list of terms into a list of maybe1(class_method)s. + list__map(term_to_instance_method(ModuleName, VarSet), MethodList, + Interface), + find_errors(Interface, Result) + ; + Result = error("expected list of instance methods", Methods) + ). - % Turn the term into a method instance + % Turn the term into a method instance. + % :- pred term_to_instance_method(module_name::in, varset::in, term::in, - maybe1(instance_method)::out) is det. + maybe1(instance_method)::out) is det. term_to_instance_method(_ModuleName, VarSet, MethodTerm, Result) :- - ( - MethodTerm = term__functor(term__atom("is"), [ClassMethodTerm, - InstanceMethod], TermContext) - -> - ( - ClassMethodTerm = term__functor(term__atom("pred"), - [term__functor( - term__atom("/"), - [ClassMethod, Arity], - _)], - _) - -> - ( - parse_qualified_term(ClassMethod, - ClassMethod, "instance method", - ok(ClassMethodName, [])), - Arity = term__functor(term__integer(ArityInt), - [], _), - parse_qualified_term(InstanceMethod, - InstanceMethod, "instance method", - ok(InstanceMethodName, [])) - -> - Result = ok(instance_method(predicate, - ClassMethodName, - name(InstanceMethodName), - ArityInt, TermContext)) - ; - Result = error( - "expected `pred( / ) " ++ - "is '", - MethodTerm) - ) - ; - ClassMethodTerm = term__functor(term__atom("func"), - [term__functor( - term__atom("/"), - [ClassMethod, Arity], - _)], - _) - -> - ( - parse_qualified_term(ClassMethod, - ClassMethod, "instance method", - ok(ClassMethodName, [])), - Arity = term__functor(term__integer(ArityInt), - [], _), - parse_qualified_term(InstanceMethod, - InstanceMethod, "instance method", - ok(InstanceMethodName, [])) - -> - Result = ok(instance_method(function, - ClassMethodName, - name(InstanceMethodName), - ArityInt, TermContext)) - ; - Result = error( - "expected `func( / ) " ++ - "is '", - MethodTerm) - ) - ; - Result = error( - "expected `pred( / ) " ++ - "is '", - MethodTerm) - ) - ; - % For the clauses in an instance declaration, - % the default module name for the clause heads - % is the module name of the class that this is an - % instance declaration for, but we don't necessarily - % know what module that is at this point, since the - % class name hasn't been fully qualified yet. - % So here we give the special module name "" - % as the default, which means that there is no default. - % (If the module qualifiers in the clauses don't match - % the module name of the class, we will pick that up later, - % in check_typeclass.m.) - DefaultModuleName = unqualified(""), - parse_item(DefaultModuleName, VarSet, MethodTerm, Result0), - ( - Result0 = ok(Item, Context), - Item = clause(_Origin, _VarNames, PredOrFunc, - ClassMethodName, HeadArgs, - _ClauseBody) - -> - adjust_func_arity(PredOrFunc, ArityInt, - list__length(HeadArgs)), - Result = ok(instance_method(PredOrFunc, - ClassMethodName, clauses([Item]), ArityInt, - Context)) - ; - Result0 = error(ErrorMsg, ErrorTerm) - -> - Result = error(ErrorMsg, ErrorTerm) - ; - % catch-all error message for a syntactically valid item - % which is not a clause - Result = error("expected clause or " ++ - "`pred( / ) is " ++ - "' or " ++ - "`func( / ) is ')", - MethodTerm) - ) - ). + ( + MethodTerm = term__functor(term__atom("is"), + [ClassMethodTerm, InstanceMethod], TermContext) + -> + ( + ClassMethodTerm = term__functor(term__atom("pred"), + [term__functor(term__atom("/"), [ClassMethod, Arity], _)], _) + -> + ( + parse_qualified_term(ClassMethod, ClassMethod, + "instance method", ok(ClassMethodName, [])), + Arity = term__functor(term__integer(ArityInt), [], _), + parse_qualified_term(InstanceMethod, InstanceMethod, + "instance method", ok(InstanceMethodName, [])) + -> + Result = ok(instance_method(predicate, ClassMethodName, + name(InstanceMethodName), ArityInt, TermContext)) + ; + Result = error("expected `pred( / ) " ++ + "is '", MethodTerm) + ) + ; + ClassMethodTerm = term__functor(term__atom("func"), + [term__functor(term__atom("/"), [ClassMethod, Arity], _)], _) + -> + ( + parse_qualified_term(ClassMethod, ClassMethod, + "instance method", ok(ClassMethodName, [])), + Arity = term__functor(term__integer(ArityInt), [], _), + parse_qualified_term(InstanceMethod, InstanceMethod, + "instance method", ok(InstanceMethodName, [])) + -> + Result = ok(instance_method(function, ClassMethodName, + name(InstanceMethodName), ArityInt, TermContext)) + ; + Result = error("expected `func( / ) " ++ + "is '", MethodTerm) + ) + ; + Result = error("expected `pred( / ) " ++ + "is '", MethodTerm) + ) + ; + % For the clauses in an instance declaration, the default module name + % for the clause heads is the module name of the class that this is an + % instance declaration for, but we don't necessarily know what module + % that is at this point, since the class name hasn't been fully + % qualified yet. So here we give the special module name "" as the + % default, which means that there is no default. (If the module + % qualifiers in the clauses don't match the module name of the class, + % we will pick that up later, in check_typeclass.m.) + DefaultModuleName = unqualified(""), + parse_item(DefaultModuleName, VarSet, MethodTerm, Result0), + ( + Result0 = ok(Item, Context), + Item = clause(_Origin, _VarNames, PredOrFunc, ClassMethodName, + HeadArgs, _ClauseBody) + -> + adjust_func_arity(PredOrFunc, ArityInt, list__length(HeadArgs)), + Result = ok(instance_method(PredOrFunc, ClassMethodName, + clauses([Item]), ArityInt, Context)) + ; + Result0 = error(ErrorMsg, ErrorTerm) + -> + Result = error(ErrorMsg, ErrorTerm) + ; + % Catch-all error message for a syntactically valid item + % which is not a clause. + Result = error("expected clause or " ++ + "`pred( / ) is ' or " ++ + "`func( / ) is ')", MethodTerm) + ) + ). diff --git a/compiler/prog_io_util.m b/compiler/prog_io_util.m index efff8746d..0c8ceb91a 100644 --- a/compiler/prog_io_util.m +++ b/compiler/prog_io_util.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 1996-2005 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. @@ -32,80 +34,79 @@ :- import_module term. :- type maybe2(T1, T2) - ---> error(string, term) - ; ok(T1, T2). + ---> error(string, term) + ; ok(T1, T2). :- type maybe3(T1, T2, T3) - ---> error(string, term) - ; ok(T1, T2, T3). + ---> error(string, term) + ; ok(T1, T2, T3). -:- type maybe1(T) == maybe1(T, generic). -:- type maybe1(T, U) ---> error(string, term(U)) - ; ok(T). +:- type maybe1(T) == maybe1(T, generic). +:- type maybe1(T, U) + ---> error(string, term(U)) + ; ok(T). -:- type maybe_functor == maybe_functor(generic). -:- type maybe_functor(T) == maybe2(sym_name, list(term(T))). +:- type maybe_functor == maybe_functor(generic). +:- type maybe_functor(T) == maybe2(sym_name, list(term(T))). - % ok(SymName, Args - MaybeFuncRetArg) ; error(Msg, Term). + % 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 maybe_item_and_context == maybe2(item, prog_context). -:- type var2tvar == map(var, tvar). +:- type var2tvar == map(var, tvar). -:- type var2pvar == map(var, prog_var). +:- 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. + 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, splitting it into - % state variables and ordinary logic variables, respectively. - % + % Parse a list of quantified variables, splitting it into + % state variables and ordinary logic variables, respectively. + % :- pred parse_quantifier_vars(term(T)::in, list(var(T))::out, - list(var(T))::out) is semidet. + list(var(T))::out) is semidet. - % Parse a list of quantified variables. - % + % Parse a list of quantified variables. + % :- pred parse_vars(term(T)::in, list(var(T))::out) is semidet. - % 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. - % + % 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, list(var(T))::out, - list(var(T))::out, list(var(T))::out) is semidet. + list(var(T))::out, list(var(T))::out) is semidet. :- pred parse_name_and_arity(module_name::in, term(_T)::in, - sym_name::out, arity::out) is semidet. + sym_name::out, arity::out) is semidet. :- pred parse_name_and_arity(term(_T)::in, sym_name::out, arity::out) - is semidet. + 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. + 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. + 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. + 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. + sym_name::out, list(term(_T))::out) is semidet. :- pred parse_type(term::in, maybe1(type)::out) is det. @@ -116,48 +117,48 @@ :- 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. + ---> allow_constrained_inst_var + ; no_allow_constrained_inst_var. :- pred convert_mode_list(allow_constrained_inst_var::in, list(term)::in, - list(mode)::out) is semidet. + list(mode)::out) is semidet. :- pred convert_mode(allow_constrained_inst_var::in, term::in, (mode)::out) - is semidet. + is semidet. :- pred convert_inst_list(allow_constrained_inst_var::in, list(term)::in, - list(inst)::out) is semidet. + list(inst)::out) is semidet. :- pred convert_inst(allow_constrained_inst_var::in, term::in, (inst)::out) - is semidet. + is semidet. :- pred standard_det(string::in, determinism::out) is semidet. - % convert a "disjunction" (bunch of terms separated by ';'s) to a list - + % 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 - + % 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) - + % 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 + 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. - + % 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. + is det. :- pred list_term_to_term_list(term::in, list(term)::out) is semidet. @@ -183,185 +184,175 @@ add_context(error(M, T), _, error(M, T)). add_context(ok(Item), Context, ok(Item, Context)). parse_name_and_arity(ModuleName, PredAndArityTerm, SymName, Arity) :- - PredAndArityTerm = term__functor(term__atom("/"), - [PredNameTerm, ArityTerm], _), - parse_implicitly_qualified_term(ModuleName, - PredNameTerm, PredNameTerm, "", ok(SymName, [])), - ArityTerm = term__functor(term__integer(Arity), [], _). + PredAndArityTerm = term__functor(term__atom("/"), + [PredNameTerm, ArityTerm], _), + parse_implicitly_qualified_term(ModuleName, + PredNameTerm, PredNameTerm, "", ok(SymName, [])), + ArityTerm = term__functor(term__integer(Arity), [], _). parse_name_and_arity(PredAndArityTerm, SymName, Arity) :- - parse_name_and_arity(unqualified(""), - 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 = predicate - ; PredOrFuncStr = "func", PredOrFunc = function - ), - Args = [Arg], - parse_name_and_arity(ModuleName, Arg, SymName, Arity). + PredOrFunc, SymName, Arity) :- + PorFPredAndArityTerm = term__functor(term__atom(PredOrFuncStr), Args, _), + ( PredOrFuncStr = "pred", PredOrFunc = predicate + ; PredOrFuncStr = "func", PredOrFunc = 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). + 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, "", - ok(SymName, ArgTerms0 - MaybeRetTerm)), - ( - MaybeRetTerm = yes(RetTerm), - PredOrFunc = function, - list__append(ArgTerms0, [RetTerm], ArgTerms) - ; - MaybeRetTerm = no, - PredOrFunc = predicate, - ArgTerms = ArgTerms0 - ). + parse_pred_or_func_and_args(no, Term, Term, "", + ok(SymName, ArgTerms0 - MaybeRetTerm)), + ( + MaybeRetTerm = yes(RetTerm), + PredOrFunc = function, + list__append(ArgTerms0, [RetTerm], ArgTerms) + ; + MaybeRetTerm = no, + PredOrFunc = 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 = ok(SymName, Args), - PredAndArgsResult = ok(SymName, Args - MaybeFuncResult) - ; - Result = error(ErrorMsg, Term), - PredAndArgsResult = error(ErrorMsg, Term) - ). + 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 = ok(SymName, Args), + PredAndArgsResult = ok(SymName, Args - MaybeFuncResult) + ; + Result = error(ErrorMsg, Term), + PredAndArgsResult = error(ErrorMsg, Term) + ). 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_list_of_vars(term__functor(term__atom("[|]"), [Head, Tail], _), + [V | Vs]) :- + Head = term__variable(V), + parse_list_of_vars(Tail, Vs). - % XXX kind inference: - % We currently give all types kind `star'. This will be different - % when we have a kind system. - % + % 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 = ok(variable(Var, star)) - ; - parse_builtin_type(Term, BuiltinType) - -> - Result = ok(builtin(BuiltinType)) - ; - parse_higher_order_type(Term, HOArgs, MaybeRet, Purity, - EvalMethod) - -> - Result = ok(higher_order(HOArgs, MaybeRet, Purity, EvalMethod)) - ; - Term = term__functor(term__atom("{}"), Args, _) - -> - parse_types(Args, ArgsResult), - ( - ArgsResult = ok(ArgTypes), - Result = ok(tuple(ArgTypes, star)) - ; - ArgsResult = error(Msg, ErrorTerm), - Result = error(Msg, ErrorTerm) - ) - ; - % - % We don't support apply/N types yet, so we just detect them - % and report an error message. - % - Term = term__functor(term__atom(""), _, _) - -> - Result = error("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 = ok(SymName, ArgTerms), - parse_types(ArgTerms, ArgsResult), - ( - ArgsResult = ok(ArgTypes), - Result = ok(defined(SymName, ArgTypes, star)) - ; - ArgsResult = error(Msg, ErrorTerm), - Result = error(Msg, ErrorTerm) - ) - ; - NameResult = error(Msg, ErrorTerm), - Result = error(Msg, ErrorTerm) - ) - ). + ( + Term = term__variable(Var0) + -> + term__coerce_var(Var0, Var), + Result = ok(variable(Var, star)) + ; + parse_builtin_type(Term, BuiltinType) + -> + Result = ok(builtin(BuiltinType)) + ; + parse_higher_order_type(Term, HOArgs, MaybeRet, Purity, EvalMethod) + -> + Result = ok(higher_order(HOArgs, MaybeRet, Purity, EvalMethod)) + ; + Term = term__functor(term__atom("{}"), Args, _) + -> + parse_types(Args, ArgsResult), + ( + ArgsResult = ok(ArgTypes), + Result = ok(tuple(ArgTypes, star)) + ; + ArgsResult = error(Msg, ErrorTerm), + Result = error(Msg, ErrorTerm) + ) + ; + % We don't support apply/N types yet, so we just detect them + % and report an error message. + Term = term__functor(term__atom(""), _, _) + -> + Result = error("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 = ok(SymName, ArgTerms), + parse_types(ArgTerms, ArgsResult), + ( + ArgsResult = ok(ArgTypes), + Result = ok(defined(SymName, ArgTypes, star)) + ; + ArgsResult = error(Msg, ErrorTerm), + Result = error(Msg, ErrorTerm) + ) + ; + NameResult = error(Msg, ErrorTerm), + Result = error(Msg, ErrorTerm) + ) + ). parse_types(Terms, Result) :- - parse_types_2(Terms, [], Result). + parse_types_2(Terms, [], Result). :- pred parse_types_2(list(term)::in, list(type)::in, maybe1(list(type))::out) - is det. + is det. parse_types_2([], RevTypes, ok(Types)) :- - list__reverse(RevTypes, Types). + list__reverse(RevTypes, Types). parse_types_2([Term | Terms], RevTypes, Result) :- - parse_type(Term, Result0), - ( - Result0 = ok(Type), - parse_types_2(Terms, [Type | RevTypes], Result) - ; - Result0 = error(Msg, ErrorTerm), - Result = error(Msg, ErrorTerm) - ). + parse_type(Term, Result0), + ( + Result0 = ok(Type), + parse_types_2(Terms, [Type | RevTypes], Result) + ; + Result0 = error(Msg, ErrorTerm), + Result = error(Msg, ErrorTerm) + ). :- 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). + 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. - % + % 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(type)::out, maybe(type)::out, - purity::out, lambda_eval_method::out) is semidet. + purity::out, lambda_eval_method::out) is semidet. parse_higher_order_type(Term0, ArgTypes, MaybeRet, Purity, EvalMethod) :- - parse_purity_annotation(Term0, Purity, Term1), - ( Term1 = term__functor(term__atom("="), [FuncAndArgs0, Ret], _) -> - parse_lambda_eval_method(FuncAndArgs0, EvalMethod, - FuncAndArgs), - FuncAndArgs = term__functor(term__atom("func"), Args, _), - parse_type(Ret, ok(RetType)), - MaybeRet = yes(RetType) - ; - parse_lambda_eval_method(Term1, EvalMethod, PredTerm), - PredTerm = term__functor(term__atom("pred"), Args, _), - MaybeRet = no - ), - parse_types(Args, ok(ArgTypes)). + parse_purity_annotation(Term0, Purity, Term1), + ( Term1 = term__functor(term__atom("="), [FuncAndArgs0, Ret], _) -> + parse_lambda_eval_method(FuncAndArgs0, EvalMethod, FuncAndArgs), + FuncAndArgs = term__functor(term__atom("func"), Args, _), + parse_type(Ret, ok(RetType)), + MaybeRet = yes(RetType) + ; + parse_lambda_eval_method(Term1, EvalMethod, PredTerm), + PredTerm = term__functor(term__atom("pred"), Args, _), + MaybeRet = no + ), + parse_types(Args, ok(ArgTypes)). parse_purity_annotation(Term0, Purity, Term) :- ( @@ -376,269 +367,256 @@ parse_purity_annotation(Term0, Purity, Term) :- ). unparse_type(variable(TVar, _), term__variable(Var)) :- - Var = term__coerce_var(TVar). + Var = term__coerce_var(TVar). unparse_type(defined(SymName, Args, _), Term) :- - unparse_type_list(Args, ArgTerms), - unparse_qualified_term(SymName, ArgTerms, Term). + unparse_type_list(Args, ArgTerms), + unparse_qualified_term(SymName, ArgTerms, Term). unparse_type(builtin(BuiltinType), Term) :- - Context = term__context_init, - builtin_type_to_string(BuiltinType, Name), - Term = term__functor(term__atom(Name), [], Context). + Context = term__context_init, + builtin_type_to_string(BuiltinType, Name), + Term = term__functor(term__atom(Name), [], Context). unparse_type(higher_order(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). + 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(Args, _), Term) :- - Context = term__context_init, - unparse_type_list(Args, ArgTerms), - Term = term__functor(term__atom("{}"), ArgTerms, Context). + Context = term__context_init, + unparse_type_list(Args, ArgTerms), + Term = term__functor(term__atom("{}"), ArgTerms, Context). unparse_type(apply_n(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) | ArgTerms], - Context). + Context = term__context_init, + Var = term__coerce_var(TVar), + unparse_type_list(Args, ArgTerms), + Term = term__functor(term__atom(""), [term__variable(Var) | ArgTerms], + Context). unparse_type(kinded(_, _), _) :- - unexpected(this_file, "prog_io_util: kind annotation"). + unexpected(this_file, "prog_io_util: kind annotation"). :- pred unparse_type_list(list(type)::in, list(term)::out) is det. unparse_type_list(Types, Terms) :- - list__map(unparse_type, 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). + 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). + 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. + term::out) is det. maybe_add_lambda_eval_method(normal, Term, Term). maybe_add_lambda_eval_method((aditi_bottom_up), Term0, Term) :- - Context = term__context_init, - Term = term__functor(term__atom("aditi_bottom_up"), [Term0], Context). + Context = term__context_init, + Term = term__functor(term__atom("aditi_bottom_up"), [Term0], Context). :- pred maybe_add_purity_annotation(purity::in, term::in, term::out) is det. maybe_add_purity_annotation(pure, Term, Term). maybe_add_purity_annotation((semipure), Term0, Term) :- - Context = term__context_init, - Term = term__functor(term__atom("semipure"), [Term0], Context). + Context = term__context_init, + Term = term__functor(term__atom("semipure"), [Term0], Context). maybe_add_purity_annotation((impure), Term0, Term) :- - Context = term__context_init, - Term = term__functor(term__atom("impure"), [Term0], Context). + 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, 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(, , ...) is - % is an abbreviation for the inst mapping - % ( pred(, , ...) is - % -> pred(, , ...) is - % ) + ( + 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(, , ...) is + % is an abbreviation for the inst mapping + % ( pred(, , ...) is + % -> pred(, , ...) is + % ) - 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(predicate, ArgModes, Detism), - Inst = ground(shared, higher_order(PredInstInfo)), - Mode = (Inst -> Inst) - ; - % Handle higher-order function modes: - % a mode of the form - % func(, , ...) = is - % is an abbreviation for the inst mapping - % ( func(, , ...) = is - % -> func(, , ...) = is - % ) + 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(predicate, ArgModes, Detism), + Inst = ground(shared, higher_order(PredInstInfo)), + Mode = (Inst -> Inst) + ; + % Handle higher-order function modes: + % a mode of the form + % func(, , ...) = is + % is an abbreviation for the inst mapping + % ( func(, , ...) = is + % -> func(, , ...) = is + % ) - 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(function, ArgModes, Detism), - Inst = ground(shared, higher_order(FuncInstInfo)), - Mode = (Inst -> Inst) - ; - parse_qualified_term(Term, Term, "mode definition", R), - R = ok(Name, Args), % should improve error reporting - convert_inst_list(AllowConstrainedInstVar, Args, ConvertedArgs), - Mode = user_defined_mode(Name, ConvertedArgs) - ). + 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(function, ArgModes, Detism), + Inst = ground(shared, higher_order(FuncInstInfo)), + Mode = (Inst -> Inst) + ; + parse_qualified_term(Term, Term, "mode definition", R), + R = ok(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(AllowConstrainedInstVar, H0, H), + convert_inst_list(AllowConstrainedInstVar, T0, T). convert_inst(_, term__variable(V0), inst_var(V)) :- - term__coerce_var(V0, 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(, , ...) is - % - % where , , ... are a list of modes, - % and is a determinism. + 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(, , ...) is + % + % where , , ... are a list of modes, + % and 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(predicate, ArgModes, Detism), - Result = ground(shared, higher_order(PredInst)) - ; + 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(predicate, ArgModes, Detism), + Result = ground(shared, higher_order(PredInst)) + ; + % The syntax for a higher-order func inst is + % + % func(, , ...) = is + % + % where , , ... are a list of modes, + % is a mode, and is a determinism. - % The syntax for a higher-order func inst is - % - % func(, , ...) = is - % - % where , , ... are a list of modes, - % is a mode, and 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(function, ArgModes, Detism), + Result = ground(shared, higher_order(FuncInst)) - 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(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", ok(QualifiedName, Args1)), + ( + mercury_public_builtin_module(BuiltinModule), + 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. + unqualify_name(QualifiedName, UnqualifiedName), + convert_simple_builtin_inst(UnqualifiedName, Args1, Result0), - % `bound' insts - ; Name = "bound", Args0 = [Disj] -> - parse_bound_inst_list(AllowConstrainedInstVar, Disj, shared, - Result) - % `bound_unique' is for backwards compatibility - % - use `unique' instead - ; Name = "bound_unique", Args0 = [Disj] -> - 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", - ok(QualifiedName, Args1)), - ( - mercury_public_builtin_module(BuiltinModule), - 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. - unqualify_name(QualifiedName, UnqualifiedName), - 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)) + ) + ). - % 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. + % A "simple" builtin inst is one that has no arguments and no special + % syntax. + % :- pred convert_simple_builtin_inst(string::in, list(term)::in, (inst)::out) - is semidet. + is semidet. convert_simple_builtin_inst(Name, [], Inst) :- - convert_simple_builtin_inst_2(Name, Inst). + convert_simple_builtin_inst_2(Name, Inst). :- pred convert_simple_builtin_inst_2(string::in, (inst)::out) is semidet. - % `free' insts + % `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)). + % `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)). + % `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)). + ground(mostly_clobbered, none)). - % `not_reached' inst + % `not_reached' inst convert_simple_builtin_inst_2("not_reached", not_reached). standard_det("det", det). @@ -652,95 +630,93 @@ standard_det("erroneous", erroneous). standard_det("failure", failure). :- pred parse_bound_inst_list(allow_constrained_inst_var::in, term::in, - uniqueness::in, (inst)::out) is semidet. + uniqueness::in, (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 = functor(ConsId, _), - F2 = functor(ConsId, _) - ). + 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 = functor(ConsId, _), + F2 = functor(ConsId, _) + ). :- pred convert_bound_inst_list(allow_constrained_inst_var::in, list(term)::in, - list(bound_inst)::out) is semidet. + 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). + 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. + bound_inst::out) is semidet. convert_bound_inst(AllowConstrainedInstVar, InstTerm, functor(ConsId, Args)) :- - InstTerm = term__functor(Functor, Args0, _), - ( Functor = term__atom(_) -> - parse_qualified_term(InstTerm, InstTerm, "inst", - ok(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). + InstTerm = term__functor(Functor, Args0, _), + ( Functor = term__atom(_) -> + parse_qualified_term(InstTerm, InstTerm, "inst", ok(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). + binop_term_to_list(";", Term, List). conjunction_to_list(Term, List) :- - binop_term_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). + 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). + binop_term_to_list("+", Term, List). - % general predicate to convert terms separated by any specified - % operator into a 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). + 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. + 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] - ). + ( 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). + conjunction_to_list(Term, List), + map_parser(Parser, List, Result). map_parser(_, [], ok([])). 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). + 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. + % 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. + maybe1(list(T))::out) is det. combine_list_results(error(Msg, Term), _, error(Msg, Term)). combine_list_results(ok(_), error(Msg, Term), error(Msg, Term)). @@ -750,50 +726,50 @@ combine_list_results(ok(X), ok(Xs), ok([X | Xs])). parse_quantifier_vars(functor(atom("[]"), [], _), [], []). parse_quantifier_vars(functor(atom("[|]"), [H, T], _), !:SVs, !:Vs) :- - parse_quantifier_vars(T, !:SVs, !:Vs), - ( - H = functor(atom("!"), [variable(SV)], _), - !:SVs = [SV | !.SVs] - ; - H = variable(V), - !:Vs = [V | !.Vs] - ). + parse_quantifier_vars(T, !:SVs, !:Vs), + ( + H = functor(atom("!"), [variable(SV)], _), + !:SVs = [SV | !.SVs] + ; + H = variable(V), + !:Vs = [V | !.Vs] + ). parse_vars(functor(atom("[]"), [], _), []). parse_vars(functor(atom("[|]"), [H, T], _), !:Vs) :- - parse_vars(T, !:Vs), - H = variable(V), - !:Vs = [V | !.Vs]. + parse_vars(T, !:Vs), + H = variable(V), + !:Vs = [V | !.Vs]. parse_vars_and_state_vars(functor(atom("[]"), [], _), [], [], []). parse_vars_and_state_vars(functor(atom("[|]"), [H, T], _), !:Os, !:Ds, !:Cs) :- - parse_vars_and_state_vars(T, !:Os, !:Ds, !:Cs), - ( - H = functor(atom("!"), [variable(V)], _), - !:Ds = [V | !.Ds], - !:Cs = [V | !.Cs] - ; - H = functor(atom("!."), [variable(V)], _), - !:Ds = [V | !.Ds] - ; - H = functor(atom("!:"), [variable(V)], _), - !:Cs = [V | !.Cs] - ; - H = variable(V), - !:Os = [V | !.Os] - ). + parse_vars_and_state_vars(T, !:Os, !:Ds, !:Cs), + ( + H = functor(atom("!"), [variable(V)], _), + !:Ds = [V | !.Ds], + !:Cs = [V | !.Cs] + ; + H = functor(atom("!."), [variable(V)], _), + !:Ds = [V | !.Ds] + ; + H = functor(atom("!:"), [variable(V)], _), + !:Cs = [V | !.Cs] + ; + H = variable(V), + !:Os = [V | !.Os] + ). %-----------------------------------------------------------------------------% 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 = [] - ). + ( + Methods = term__functor(term__atom("[|]"), [Head, Tail0], _), + list_term_to_term_list(Tail0, Tail), + MethodList = [Head|Tail] + ; + Methods = term__functor(term__atom("[]"), [], _), + MethodList = [] + ). %-----------------------------------------------------------------------------% diff --git a/compiler/prog_mode.m b/compiler/prog_mode.m index 727dd305b..3eb8add50 100644 --- a/compiler/prog_mode.m +++ b/compiler/prog_mode.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 2004-2005 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. @@ -17,9 +19,9 @@ :- import_module list. - % Construct a mode corresponding to the standard - % `in', `out', `uo' or `unused' mode. - % + % Construct a mode corresponding to the standard `in', `out', `uo' + % or `unused' mode. + % :- pred in_mode((mode)::out) is det. :- func in_mode = (mode). :- func in_mode(inst) = (mode). @@ -39,10 +41,10 @@ :- func free_inst = (inst). :- func any_inst = (inst). - % Construct the modes used for `aditi__state' arguments. - % XXX These should be unique, but are not yet because that - % would require alias tracking. - % + % Construct the modes used for `aditi__state' arguments. + % XXX These should be unique, but are not yet because that + % would require alias tracking. + % :- func aditi_mui_mode = (mode). :- func aditi_ui_mode = (mode). :- func aditi_di_mode = (mode). @@ -53,79 +55,77 @@ %-----------------------------------------------------------------------------% - % mode_substitute_arg_list(Mode0, Params, Args, Mode) is true - % iff Mode is the mode that results from substituting all - % occurrences of Params in Mode0 with the corresponding - % value in Args. - % + % mode_substitute_arg_list(Mode0, Params, Args, Mode) is true iff Mode is + % the mode that results from substituting all occurrences of Params + % in Mode0 with the corresponding value in Args. + % :- pred mode_substitute_arg_list((mode)::in, list(inst_var)::in, - list(inst)::in, (mode)::out) is det. + list(inst)::in, (mode)::out) is det. - % inst_lists_to_mode_list(InitialInsts, FinalInsts, Modes): - % - % Given two lists of corresponding initial and final insts, return - % a list of modes which maps from the initial insts to the final insts. - % + % inst_lists_to_mode_list(InitialInsts, FinalInsts, Modes): + % + % Given two lists of corresponding initial and final insts, return + % a list of modes which maps from the initial insts to the final insts. + % :- pred inst_lists_to_mode_list(list(inst)::in, list(inst)::in, - list(mode)::out) is det. + list(mode)::out) is det. :- pred insts_to_mode((inst)::in, (inst)::in, (mode)::out) is det. %-----------------------------------------------------------------------------% - % inst_substitute_arg_list(Inst0, Params, Args, Inst) is true - % iff Inst is the inst that results from substituting all - % occurrences of Params in Inst0 with the corresponding - % value in Args. - % -:- pred inst_substitute_arg_list((inst)::in, list(inst_var)::in, - list(inst)::in, (inst)::out) is det. + % inst_substitute_arg_list(Params, Args, Inst0, Inst) is true iff Inst + % is the inst that results from substituting all occurrences of Params + % in Inst0 with the corresponding value in Args. + % +:- pred inst_substitute_arg_list(list(inst_var)::in, list(inst)::in, + (inst)::in, (inst)::out) is det. - % inst_list_apply_substitution(Insts0, Subst, Insts) is true - % iff Inst is the inst that results from applying Subst to Insts0. - % -:- pred inst_list_apply_substitution(list(inst)::in, inst_var_sub::in, - list(inst)::out) is det. + % inst_list_apply_substitution(Subst, Insts0, Insts) is true + % iff Inst is the inst that results from applying Subst to Insts0. + % +:- pred inst_list_apply_substitution(inst_var_sub::in, + list(inst)::in, list(inst)::out) is det. - % mode_list_apply_substitution(Modes0, Subst, Modes) is true - % iff Mode is the mode that results from applying Subst to Modes0. - % -:- pred mode_list_apply_substitution(list(mode)::in, inst_var_sub::in, - list(mode)::out) is det. + % mode_list_apply_substitution(Subst, Modes0, Modes) is true + % iff Mode is the mode that results from applying Subst to Modes0. + % +:- pred mode_list_apply_substitution(inst_var_sub::in, + list(mode)::in, list(mode)::out) is det. :- pred rename_apart_inst_vars(inst_varset::in, inst_varset::in, - list(mode)::in, list(mode)::out) is det. + list(mode)::in, list(mode)::out) is det. - % inst_contains_unconstrained_var(Inst) iff Inst includes an - % unconstrained inst variable. - % + % inst_contains_unconstrained_var(Inst) iff Inst includes an + % unconstrained inst variable. + % :- pred inst_contains_unconstrained_var((inst)::in) is semidet. %-----------------------------------------------------------------------------% - % Given an expanded inst and a cons_id and its arity, return the - % insts of the arguments of the top level functor, failing if the - % inst could not be bound to the functor. - % + % Given an expanded inst and a cons_id and its arity, return the + % insts of the arguments of the top level functor, failing if the + % inst could not be bound to the functor. + % :- pred get_arg_insts((inst)::in, cons_id::in, arity::in, list(inst)::out) - is semidet. + is semidet. - % Given a list of bound_insts, get the corresponding list of cons_ids - % + % Given a list of bound_insts, get the corresponding list of cons_ids + % :- pred functors_to_cons_ids(list(bound_inst)::in, list(cons_id)::out) is det. :- pred mode_id_to_int(mode_id::in, int::out) is det. - % Predicates to make error messages more readable by stripping - % "builtin:" module qualifiers from modes. - % + % Predicates to make error messages more readable by stripping + % "builtin." module qualifiers from modes. + % :- pred strip_builtin_qualifier_from_cons_id(cons_id::in, cons_id::out) is det. :- pred strip_builtin_qualifiers_from_mode_list(list(mode)::in, - list(mode)::out) is det. + list(mode)::out) is det. :- pred strip_builtin_qualifiers_from_inst_list(list(inst)::in, - list(inst)::out) is det. + list(inst)::out) is det. :- pred strip_builtin_qualifiers_from_inst((inst)::in, (inst)::out) is det. @@ -171,496 +171,489 @@ any_inst = any(shared). make_std_mode(Name, Args, make_std_mode(Name, Args)). make_std_mode(Name, Args) = Mode :- - mercury_public_builtin_module(MercuryBuiltin), - QualifiedName = qualified(MercuryBuiltin, Name), - Mode = user_defined_mode(QualifiedName, Args). + mercury_public_builtin_module(MercuryBuiltin), + QualifiedName = qualified(MercuryBuiltin, Name), + Mode = user_defined_mode(QualifiedName, Args). %-----------------------------------------------------------------------------% -inst_lists_to_mode_list([], [_|_], _) :- - error("inst_lists_to_mode_list: length mis-match"). -inst_lists_to_mode_list([_|_], [], _) :- - error("inst_lists_to_mode_list: length mis-match"). +inst_lists_to_mode_list([], [_ | _], _) :- + error("inst_lists_to_mode_list: length mis-match"). +inst_lists_to_mode_list([_ | _], [], _) :- + error("inst_lists_to_mode_list: length mis-match"). inst_lists_to_mode_list([], [], []). -inst_lists_to_mode_list([Initial|Initials], [Final|Finals], [Mode|Modes]) :- - insts_to_mode(Initial, Final, Mode), - inst_lists_to_mode_list(Initials, Finals, Modes). +inst_lists_to_mode_list([Initial | Initials], [Final | Finals], + [Mode | Modes]) :- + insts_to_mode(Initial, Final, Mode), + inst_lists_to_mode_list(Initials, Finals, Modes). insts_to_mode(Initial, Final, Mode) :- - % - % Use some abbreviations. - % This is just to make error messages and inferred modes - % more readable. - % - ( Initial = free, Final = ground(shared, none) -> - make_std_mode("out", [], Mode) - ; Initial = free, Final = ground(unique, none) -> - make_std_mode("uo", [], Mode) - ; Initial = free, Final = ground(mostly_unique, none) -> - make_std_mode("muo", [], Mode) - ; Initial = ground(shared, none), Final = ground(shared, none) -> - make_std_mode("in", [], Mode) - ; Initial = ground(unique, none), Final = ground(clobbered, none) -> - make_std_mode("di", [], Mode) - ; Initial = ground(mostly_unique, none), - Final = ground(mostly_clobbered, none) -> - make_std_mode("mdi", [], Mode) - ; Initial = ground(unique, none), Final = ground(unique, none) -> - make_std_mode("ui", [], Mode) - ; Initial = ground(mostly_unique, none), - Final = ground(mostly_unique, none) -> - make_std_mode("mdi", [], Mode) - ; Initial = free -> - make_std_mode("out", [Final], Mode) - ; Final = ground(clobbered, none) -> - make_std_mode("di", [Initial], Mode) - ; Initial = Final -> - make_std_mode("in", [Initial], Mode) - ; - Mode = (Initial -> Final) - ). + % Use some abbreviations. + % This is just to make error messages and inferred modes more readable. + + ( Initial = free, Final = ground(shared, none) -> + make_std_mode("out", [], Mode) + ; Initial = free, Final = ground(unique, none) -> + make_std_mode("uo", [], Mode) + ; Initial = free, Final = ground(mostly_unique, none) -> + make_std_mode("muo", [], Mode) + ; Initial = ground(shared, none), Final = ground(shared, none) -> + make_std_mode("in", [], Mode) + ; Initial = ground(unique, none), Final = ground(clobbered, none) -> + make_std_mode("di", [], Mode) + ; Initial = ground(mostly_unique, none), + Final = ground(mostly_clobbered, none) -> + make_std_mode("mdi", [], Mode) + ; Initial = ground(unique, none), Final = ground(unique, none) -> + make_std_mode("ui", [], Mode) + ; Initial = ground(mostly_unique, none), + Final = ground(mostly_unique, none) -> + make_std_mode("mdi", [], Mode) + ; Initial = free -> + make_std_mode("out", [Final], Mode) + ; Final = ground(clobbered, none) -> + make_std_mode("di", [Initial], Mode) + ; Initial = Final -> + make_std_mode("in", [Initial], Mode) + ; + Mode = (Initial -> Final) + ). %-----------------------------------------------------------------------------% mode_substitute_arg_list(Mode0, Params, Args, Mode) :- - ( Params = [] -> - Mode = Mode0 % optimize common case - ; - map__from_corresponding_lists(Params, Args, Subst), - mode_apply_substitution(Mode0, Subst, Mode) - ). + ( + Params = [], + Mode = Mode0 % optimize common case + ; + Params = [_ | _], + map__from_corresponding_lists(Params, Args, Subst), + mode_apply_substitution(Subst, Mode0, Mode) + ). -inst_substitute_arg_list(Inst0, Params, Args, Inst) :- - ( Params = [] -> - Inst = Inst0 % optimize common case - ; - map__from_corresponding_lists(Params, Args, Subst), - inst_apply_substitution(Inst0, Subst, Inst) - ). +inst_substitute_arg_list(Params, Args, Inst0, Inst) :- + ( + Params = [], + Inst = Inst0 % optimize common case + ; + Params = [_ | _], + map__from_corresponding_lists(Params, Args, Subst), + inst_apply_substitution(Subst, Inst0, Inst) + ). - % mode_apply_substitution(Mode0, Subst, Mode) is true iff - % Mode is the mode that results from apply Subst to Mode0. + % mode_apply_substitution(Mode0, Subst, Mode) is true iff + % Mode is the mode that results from apply Subst to Mode0. + % +:- pred mode_apply_substitution(inst_var_sub::in, (mode)::in, (mode)::out) + is det. -:- pred mode_apply_substitution((mode)::in, inst_var_sub::in, (mode)::out) - is det. +mode_apply_substitution(Subst, (I0 -> F0), (I -> F)) :- + inst_apply_substitution(Subst, I0, I), + inst_apply_substitution(Subst, F0, F). +mode_apply_substitution(Subst, user_defined_mode(Name, Args0), + user_defined_mode(Name, Args)) :- + inst_list_apply_substitution_2(Subst, Args0, Args). -mode_apply_substitution((I0 -> F0), Subst, (I -> F)) :- - inst_apply_substitution(I0, Subst, I), - inst_apply_substitution(F0, Subst, F). -mode_apply_substitution(user_defined_mode(Name, Args0), Subst, - user_defined_mode(Name, Args)) :- - inst_list_apply_substitution_2(Args0, Subst, Args). +inst_list_apply_substitution(Subst, Insts0, Insts) :- + ( map__is_empty(Subst) -> + Insts = Insts0 + ; + inst_list_apply_substitution_2(Subst, Insts0, Insts) + ). -inst_list_apply_substitution(Insts0, Subst, Insts) :- - ( map__is_empty(Subst) -> - Insts = Insts0 - ; - inst_list_apply_substitution_2(Insts0, Subst, Insts) - ). +:- pred inst_list_apply_substitution_2(inst_var_sub::in, + list(inst)::in, list(inst)::out) is det. -:- pred inst_list_apply_substitution_2(list(inst)::in, inst_var_sub::in, - list(inst)::out) is det. +inst_list_apply_substitution_2(_, [], []). +inst_list_apply_substitution_2(Subst, [A0 | As0], [A | As]) :- + inst_apply_substitution(Subst, A0, A), + inst_list_apply_substitution_2(Subst, As0, As). -inst_list_apply_substitution_2([], _, []). -inst_list_apply_substitution_2([A0 | As0], Subst, [A | As]) :- - inst_apply_substitution(A0, Subst, A), - inst_list_apply_substitution_2(As0, Subst, As). + % inst_substitute_arg(Inst0, Subst, Inst) is true iff Inst is the inst that + % results from substituting all occurrences of Param in Inst0 with Arg. + % +:- pred inst_apply_substitution(inst_var_sub::in, (inst)::in, (inst)::out) + is det. - % inst_substitute_arg(Inst0, Subst, Inst) is true - % iff Inst is the inst that results from substituting all - % occurrences of Param in Inst0 with Arg. +inst_apply_substitution(_, any(Uniq), any(Uniq)). +inst_apply_substitution(_, free, free). +inst_apply_substitution(_, free(T), free(T)). +inst_apply_substitution(Subst, ground(Uniq, GroundInstInfo0), Inst) :- + ground_inst_info_apply_substitution(Subst, Uniq, GroundInstInfo0, Inst). +inst_apply_substitution(Subst, bound(Uniq, Alts0), bound(Uniq, Alts)) :- + alt_list_apply_substitution(Subst, Alts0, Alts). +inst_apply_substitution(_, not_reached, not_reached). +inst_apply_substitution(Subst, inst_var(Var), Result) :- + ( map__search(Subst, Var, Replacement) -> + Result = Replacement + ; + Result = inst_var(Var) + ). +inst_apply_substitution(Subst, constrained_inst_vars(Vars, Inst0), Result) :- + ( set__singleton_set(Vars, Var0) -> + Var = Var0 + ; + error("inst_apply_substitution: multiple inst_vars found") + ), + ( map__search(Subst, Var, Replacement) -> + Result = Replacement + % XXX Should probably have a sanity check here that + % Replacement =< Inst0 + ; + inst_apply_substitution(Subst, Inst0, Result0), + Result = constrained_inst_vars(Vars, Result0) + ). +inst_apply_substitution(Subst, defined_inst(InstName0), + defined_inst(InstName)) :- + ( inst_name_apply_substitution(Subst, InstName0, InstName1) -> + InstName = InstName1 + ; + InstName = InstName0 + ). +inst_apply_substitution(Subst, abstract_inst(Name, Args0), + abstract_inst(Name, Args)) :- + inst_list_apply_substitution_2(Subst, Args0, Args). -:- pred inst_apply_substitution((inst)::in, inst_var_sub::in, (inst)::out) - is det. + % This predicate fails if the inst_name is not one of user_inst, + % typed_inst or typed_ground. The other types of inst_names are just used + % as keys in the inst_table so it does not make sense to apply + % substitutions to them. + % +:- pred inst_name_apply_substitution(inst_var_sub::in, + inst_name::in, inst_name::out) is semidet. -inst_apply_substitution(any(Uniq), _, any(Uniq)). -inst_apply_substitution(free, _, free). -inst_apply_substitution(free(T), _, free(T)). -inst_apply_substitution(ground(Uniq, GroundInstInfo0), Subst, Inst) :- - ground_inst_info_apply_substitution(GroundInstInfo0, Subst, Uniq, Inst). -inst_apply_substitution(bound(Uniq, Alts0), Subst, bound(Uniq, Alts)) :- - alt_list_apply_substitution(Alts0, Subst, Alts). -inst_apply_substitution(not_reached, _, not_reached). -inst_apply_substitution(inst_var(Var), Subst, Result) :- - ( - map__search(Subst, Var, Replacement) - -> - Result = Replacement - ; - Result = inst_var(Var) - ). -inst_apply_substitution(constrained_inst_vars(Vars, Inst0), Subst, Result) :- - ( set__singleton_set(Vars, Var0) -> - Var = Var0 - ; - error("inst_apply_substitution: multiple inst_vars found") - ), - ( - map__search(Subst, Var, Replacement) - -> - Result = Replacement - % XXX Should probably have a sanity check here that - % Replacement =< Inst0 - ; - inst_apply_substitution(Inst0, Subst, Result0), - Result = constrained_inst_vars(Vars, Result0) - ). -inst_apply_substitution(defined_inst(InstName0), Subst, - defined_inst(InstName)) :- - ( inst_name_apply_substitution(InstName0, Subst, InstName1) -> - InstName = InstName1 - ; - InstName = InstName0 - ). -inst_apply_substitution(abstract_inst(Name, Args0), Subst, - abstract_inst(Name, Args)) :- - inst_list_apply_substitution_2(Args0, Subst, Args). +inst_name_apply_substitution(Subst, user_inst(Name, Args0), + user_inst(Name, Args)) :- + inst_list_apply_substitution_2(Subst, Args0, Args). +inst_name_apply_substitution(Subst, typed_inst(T, Inst0), + typed_inst(T, Inst)) :- + inst_name_apply_substitution(Subst, Inst0, Inst). +inst_name_apply_substitution(_, typed_ground(Uniq, T), typed_ground(Uniq, T)). - % This predicate fails if the inst_name is not one of user_inst, - % typed_inst or typed_ground. The other types of inst_names are just - % used as keys in the inst_table so it does not make sense to apply - % substitutions to them. -:- pred inst_name_apply_substitution(inst_name::in, inst_var_sub::in, - inst_name::out) is semidet. +:- pred alt_list_apply_substitution(inst_var_sub::in, + list(bound_inst)::in, list(bound_inst)::out) is det. -inst_name_apply_substitution(user_inst(Name, Args0), Subst, - user_inst(Name, Args)) :- - inst_list_apply_substitution_2(Args0, Subst, Args). -inst_name_apply_substitution(typed_inst(T, Inst0), Subst, - typed_inst(T, Inst)) :- - inst_name_apply_substitution(Inst0, Subst, Inst). -inst_name_apply_substitution(typed_ground(Uniq, T), _, typed_ground(Uniq, T)). +alt_list_apply_substitution(_, [], []). +alt_list_apply_substitution(Subst, [Alt0 | Alts0], [Alt | Alts]) :- + Alt0 = functor(Name, Args0), + inst_list_apply_substitution_2(Subst, Args0, Args), + Alt = functor(Name, Args), + alt_list_apply_substitution(Subst, Alts0, Alts). -:- pred alt_list_apply_substitution(list(bound_inst)::in, inst_var_sub::in, - list(bound_inst)::out) is det. +:- pred ground_inst_info_apply_substitution(inst_var_sub::in, uniqueness::in, + ground_inst_info::in, (inst)::out) is det. -alt_list_apply_substitution([], _, []). -alt_list_apply_substitution([Alt0|Alts0], Subst, [Alt|Alts]) :- - Alt0 = functor(Name, Args0), - inst_list_apply_substitution_2(Args0, Subst, Args), - Alt = functor(Name, Args), - alt_list_apply_substitution(Alts0, Subst, Alts). +ground_inst_info_apply_substitution(_, Uniq, none, ground(Uniq, none)). +ground_inst_info_apply_substitution(Subst, Uniq, GII0, ground(Uniq, GII)) :- + GII0 = higher_order(pred_inst_info(PredOrFunc, Modes0, Det)), + mode_list_apply_substitution(Subst, Modes0, Modes), + GII = higher_order(pred_inst_info(PredOrFunc, Modes, Det)). -:- pred ground_inst_info_apply_substitution(ground_inst_info::in, - inst_var_sub::in, uniqueness::in, (inst)::out) is det. +mode_list_apply_substitution(Subst, Modes0, Modes) :- + ( map__is_empty(Subst) -> + Modes = Modes0 + ; + mode_list_apply_substitution_2(Subst, Modes0, Modes) + ). -ground_inst_info_apply_substitution(none, _, Uniq, ground(Uniq, none)). -ground_inst_info_apply_substitution(GII0, Subst, Uniq, ground(Uniq, GII)) :- - GII0 = higher_order(pred_inst_info(PredOrFunc, Modes0, Det)), - mode_list_apply_substitution(Modes0, Subst, Modes), - GII = higher_order(pred_inst_info(PredOrFunc, Modes, Det)). +:- pred mode_list_apply_substitution_2(inst_var_sub::in, + list(mode)::in, list(mode)::out) is det. -mode_list_apply_substitution(Modes0, Subst, Modes) :- - ( map__is_empty(Subst) -> - Modes = Modes0 - ; - mode_list_apply_substitution_2(Modes0, Subst, Modes) - ). - -:- pred mode_list_apply_substitution_2(list(mode)::in, inst_var_sub::in, - list(mode)::out) is det. - -mode_list_apply_substitution_2([], _, []). -mode_list_apply_substitution_2([A0 | As0], Subst, [A | As]) :- - mode_apply_substitution(A0, Subst, A), - mode_list_apply_substitution_2(As0, Subst, As). +mode_list_apply_substitution_2(_, [], []). +mode_list_apply_substitution_2(Subst, [A0 | As0], [A | As]) :- + mode_apply_substitution(Subst, A0, A), + mode_list_apply_substitution_2(Subst, As0, As). %-----------------------------------------------------------------------------% rename_apart_inst_vars(VarSet, NewVarSet, Modes0, Modes) :- - varset__merge_subst(VarSet, NewVarSet, _, Sub), - list__map(rename_apart_inst_vars_in_mode(Sub), Modes0, Modes). + varset__merge_subst(VarSet, NewVarSet, _, Sub), + list__map(rename_apart_inst_vars_in_mode(Sub), Modes0, Modes). :- pred rename_apart_inst_vars_in_mode(substitution(inst_var_type)::in, - (mode)::in, (mode)::out) is det. + (mode)::in, (mode)::out) is det. rename_apart_inst_vars_in_mode(Sub, I0 -> F0, I -> F) :- - rename_apart_inst_vars_in_inst(Sub, I0, I), - rename_apart_inst_vars_in_inst(Sub, F0, F). + rename_apart_inst_vars_in_inst(Sub, I0, I), + rename_apart_inst_vars_in_inst(Sub, F0, F). rename_apart_inst_vars_in_mode(Sub, user_defined_mode(Name, Insts0), - user_defined_mode(Name, Insts)) :- - list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts). + user_defined_mode(Name, Insts)) :- + list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts). :- pred rename_apart_inst_vars_in_inst(substitution(inst_var_type)::in, - (inst)::in, (inst)::out) is det. + (inst)::in, (inst)::out) is det. rename_apart_inst_vars_in_inst(_, any(U), any(U)). rename_apart_inst_vars_in_inst(_, free, free). rename_apart_inst_vars_in_inst(_, free(T), free(T)). rename_apart_inst_vars_in_inst(Sub, bound(U, BIs0), bound(U, BIs)) :- - list__map((pred(functor(C, Is0)::in, functor(C, Is)::out) is det :- - list__map(rename_apart_inst_vars_in_inst(Sub), Is0, Is)), - BIs0, BIs). + list__map((pred(functor(C, Is0)::in, functor(C, Is)::out) is det :- + list__map(rename_apart_inst_vars_in_inst(Sub), Is0, Is)), + BIs0, BIs). rename_apart_inst_vars_in_inst(Sub, ground(U, GI0), ground(U, GI)) :- - ( - GI0 = higher_order(pred_inst_info(PoF, Modes0, Det)), - list__map(rename_apart_inst_vars_in_mode(Sub), Modes0, Modes), - GI = higher_order(pred_inst_info(PoF, Modes, Det)) - ; - GI0 = none, - GI = none - ). + ( + GI0 = higher_order(pred_inst_info(PoF, Modes0, Det)), + list__map(rename_apart_inst_vars_in_mode(Sub), Modes0, Modes), + GI = higher_order(pred_inst_info(PoF, Modes, Det)) + ; + GI0 = none, + GI = none + ). rename_apart_inst_vars_in_inst(_, not_reached, not_reached). rename_apart_inst_vars_in_inst(Sub, inst_var(Var0), inst_var(Var)) :- - ( map__search(Sub, Var0, term__variable(Var1)) -> - Var = Var1 - ; - Var = Var0 - ). + ( map__search(Sub, Var0, term__variable(Var1)) -> + Var = Var1 + ; + Var = Var0 + ). rename_apart_inst_vars_in_inst(Sub, constrained_inst_vars(Vars0, Inst0), - constrained_inst_vars(Vars, Inst)) :- - rename_apart_inst_vars_in_inst(Sub, Inst0, Inst), - Vars = set__map(func(Var0) = - ( map__search(Sub, Var0, term__variable(Var)) -> - Var - ; - Var0 - ), Vars0). + constrained_inst_vars(Vars, Inst)) :- + rename_apart_inst_vars_in_inst(Sub, Inst0, Inst), + Vars = set__map(func(Var0) = + ( map__search(Sub, Var0, term__variable(Var)) -> + Var + ; + Var0 + ), Vars0). rename_apart_inst_vars_in_inst(Sub, defined_inst(Name0), defined_inst(Name)) :- - ( rename_apart_inst_vars_in_inst_name(Sub, Name0, Name1) -> - Name = Name1 - ; - Name = Name0 - ). + ( rename_apart_inst_vars_in_inst_name(Sub, Name0, Name1) -> + Name = Name1 + ; + Name = Name0 + ). rename_apart_inst_vars_in_inst(Sub, abstract_inst(Sym, Insts0), - abstract_inst(Sym, Insts)) :- - list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts). + abstract_inst(Sym, Insts)) :- + list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts). :- pred rename_apart_inst_vars_in_inst_name(substitution(inst_var_type)::in, - inst_name::in, inst_name::out) is semidet. + inst_name::in, inst_name::out) is semidet. rename_apart_inst_vars_in_inst_name(Sub, user_inst(Sym, Insts0), - user_inst(Sym, Insts)) :- - list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts). + user_inst(Sym, Insts)) :- + list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts). rename_apart_inst_vars_in_inst_name(Sub, typed_inst(Type, Name0), - typed_inst(Type, Name)) :- - rename_apart_inst_vars_in_inst_name(Sub, Name0, Name). + typed_inst(Type, Name)) :- + rename_apart_inst_vars_in_inst_name(Sub, Name0, Name). rename_apart_inst_vars_in_inst_name(_, typed_ground(U, T), typed_ground(U, T)). %-----------------------------------------------------------------------------% inst_contains_unconstrained_var(bound(_Uniqueness, BoundInsts)) :- - list.member(BoundInst, BoundInsts), - BoundInst = functor(_ConsId, ArgInsts), - list.member(ArgInst, ArgInsts), - inst_contains_unconstrained_var(ArgInst). + list.member(BoundInst, BoundInsts), + BoundInst = functor(_ConsId, ArgInsts), + list.member(ArgInst, ArgInsts), + inst_contains_unconstrained_var(ArgInst). inst_contains_unconstrained_var(ground(_Uniqueness, GroundInstInfo)) :- - GroundInstInfo = higher_order(PredInstInfo), - PredInstInfo = pred_inst_info(_PredOrFunc, Modes, _Detism), - list.member(Mode, Modes), - ( - Mode = (Inst -> _) - ; - Mode = (_ -> Inst) - ; - Mode = user_defined_mode(_SymName, Insts), - list.member(Inst, Insts) - ), - inst_contains_unconstrained_var(Inst). + GroundInstInfo = higher_order(PredInstInfo), + PredInstInfo = pred_inst_info(_PredOrFunc, Modes, _Detism), + list.member(Mode, Modes), + ( + Mode = (Inst -> _) + ; + Mode = (_ -> Inst) + ; + Mode = user_defined_mode(_SymName, Insts), + list.member(Inst, Insts) + ), + inst_contains_unconstrained_var(Inst). inst_contains_unconstrained_var(inst_var(_InstVar)). inst_contains_unconstrained_var(defined_inst(InstName)) :- - ( - InstName = user_inst(_, Insts), - list.member(Inst, Insts), - inst_contains_unconstrained_var(Inst) - ; - InstName = merge_inst(Inst, _), - inst_contains_unconstrained_var(Inst) - ; - InstName = merge_inst(_, Inst), - inst_contains_unconstrained_var(Inst) - ; - InstName = unify_inst(_, Inst, _, _), - inst_contains_unconstrained_var(Inst) - ; - InstName = unify_inst(_, _, Inst, _), - inst_contains_unconstrained_var(Inst) - ; - InstName = ground_inst(InstName1, _, _, _), - inst_contains_unconstrained_var(defined_inst(InstName1)) - ; - InstName = any_inst(InstName1, _, _, _), - inst_contains_unconstrained_var(defined_inst(InstName1)) - ; - InstName = shared_inst(InstName1), - inst_contains_unconstrained_var(defined_inst(InstName1)) - ; - InstName = mostly_uniq_inst(InstName1), - inst_contains_unconstrained_var(defined_inst(InstName1)) - ; - InstName = typed_inst(_, InstName1), - inst_contains_unconstrained_var(defined_inst(InstName1)) - ). + ( + InstName = user_inst(_, Insts), + list.member(Inst, Insts), + inst_contains_unconstrained_var(Inst) + ; + InstName = merge_inst(Inst, _), + inst_contains_unconstrained_var(Inst) + ; + InstName = merge_inst(_, Inst), + inst_contains_unconstrained_var(Inst) + ; + InstName = unify_inst(_, Inst, _, _), + inst_contains_unconstrained_var(Inst) + ; + InstName = unify_inst(_, _, Inst, _), + inst_contains_unconstrained_var(Inst) + ; + InstName = ground_inst(InstName1, _, _, _), + inst_contains_unconstrained_var(defined_inst(InstName1)) + ; + InstName = any_inst(InstName1, _, _, _), + inst_contains_unconstrained_var(defined_inst(InstName1)) + ; + InstName = shared_inst(InstName1), + inst_contains_unconstrained_var(defined_inst(InstName1)) + ; + InstName = mostly_uniq_inst(InstName1), + inst_contains_unconstrained_var(defined_inst(InstName1)) + ; + InstName = typed_inst(_, InstName1), + inst_contains_unconstrained_var(defined_inst(InstName1)) + ). inst_contains_unconstrained_var(abstract_inst(_SymName, Insts)) :- - list.member(Inst, Insts), - inst_contains_unconstrained_var(Inst). + list.member(Inst, Insts), + inst_contains_unconstrained_var(Inst). %-----------------------------------------------------------------------------% functors_to_cons_ids([], []). functors_to_cons_ids([Functor | Functors], [ConsId | ConsIds]) :- - Functor = functor(ConsId, _ArgInsts), - functors_to_cons_ids(Functors, ConsIds). + Functor = functor(ConsId, _ArgInsts), + functors_to_cons_ids(Functors, ConsIds). %-----------------------------------------------------------------------------% get_arg_insts(not_reached, _ConsId, Arity, ArgInsts) :- - list__duplicate(Arity, not_reached, ArgInsts). + list__duplicate(Arity, not_reached, ArgInsts). get_arg_insts(ground(Uniq, _PredInst), _ConsId, Arity, ArgInsts) :- - list__duplicate(Arity, ground(Uniq, none), ArgInsts). + list__duplicate(Arity, ground(Uniq, none), ArgInsts). get_arg_insts(bound(_Uniq, List), ConsId, Arity, ArgInsts) :- - ( get_arg_insts_2(List, ConsId, ArgInsts0) -> - ArgInsts = ArgInsts0 - ; - % the code is unreachable - list__duplicate(Arity, not_reached, ArgInsts) - ). + ( get_arg_insts_2(List, ConsId, ArgInsts0) -> + ArgInsts = ArgInsts0 + ; + % The code is unreachable. + list__duplicate(Arity, not_reached, ArgInsts) + ). get_arg_insts(free, _ConsId, Arity, ArgInsts) :- - list__duplicate(Arity, free, ArgInsts). + list__duplicate(Arity, free, ArgInsts). get_arg_insts(free(_Type), _ConsId, Arity, ArgInsts) :- - list__duplicate(Arity, free, ArgInsts). + list__duplicate(Arity, free, ArgInsts). get_arg_insts(any(Uniq), _ConsId, Arity, ArgInsts) :- - list__duplicate(Arity, any(Uniq), ArgInsts). + list__duplicate(Arity, any(Uniq), ArgInsts). :- pred get_arg_insts_2(list(bound_inst)::in, cons_id::in, list(inst)::out) - is semidet. + is semidet. get_arg_insts_2([BoundInst | BoundInsts], ConsId, ArgInsts) :- - ( BoundInst = functor(ConsId, ArgInsts0) -> - ArgInsts = ArgInsts0 - ; - get_arg_insts_2(BoundInsts, ConsId, ArgInsts) - ). - - % In case we later decided to change the representation - % of mode_ids. + ( BoundInst = functor(ConsId, ArgInsts0) -> + ArgInsts = ArgInsts0 + ; + get_arg_insts_2(BoundInsts, ConsId, ArgInsts) + ). + % In case we later decided to change the representation of mode_ids. mode_id_to_int(_ - X, X). %-----------------------------------------------------------------------------% - % - % Predicates to make error messages more readable by stripping - % "builtin:" module qualifiers from modes and insts. - % The interesting part is strip_builtin_qualifier_from_sym_name; - % the rest is basically just recursive traversals. - % - + % The interesting part is strip_builtin_qualifier_from_sym_name; + % the rest is basically just recursive traversals. strip_builtin_qualifiers_from_mode_list(Modes0, Modes) :- - list__map(strip_builtin_qualifiers_from_mode, Modes0, Modes). + list__map(strip_builtin_qualifiers_from_mode, Modes0, Modes). :- pred strip_builtin_qualifiers_from_mode((mode)::in, (mode)::out) is det. strip_builtin_qualifiers_from_mode((Initial0 -> Final0), (Initial -> Final)) :- - strip_builtin_qualifiers_from_inst(Initial0, Initial), - strip_builtin_qualifiers_from_inst(Final0, Final). + strip_builtin_qualifiers_from_inst(Initial0, Initial), + strip_builtin_qualifiers_from_inst(Final0, Final). strip_builtin_qualifiers_from_mode(user_defined_mode(SymName0, Insts0), - user_defined_mode(SymName, Insts)) :- - strip_builtin_qualifiers_from_inst_list(Insts0, Insts), - strip_builtin_qualifier_from_sym_name(SymName0, SymName). + user_defined_mode(SymName, Insts)) :- + strip_builtin_qualifiers_from_inst_list(Insts0, Insts), + strip_builtin_qualifier_from_sym_name(SymName0, SymName). strip_builtin_qualifier_from_cons_id(ConsId0, ConsId) :- - ( ConsId0 = cons(Name0, Arity) -> - strip_builtin_qualifier_from_sym_name(Name0, Name), - ConsId = cons(Name, Arity) - ; - ConsId = ConsId0 - ). + ( ConsId0 = cons(Name0, Arity) -> + strip_builtin_qualifier_from_sym_name(Name0, Name), + ConsId = cons(Name, Arity) + ; + ConsId = ConsId0 + ). :- pred strip_builtin_qualifier_from_sym_name(sym_name::in, sym_name::out) - is det. + is det. strip_builtin_qualifier_from_sym_name(SymName0, SymName) :- - ( - SymName0 = qualified(Module, Name), - mercury_public_builtin_module(Module) - -> - SymName = unqualified(Name) - ; - SymName = SymName0 - ). + ( + SymName0 = qualified(Module, Name), + mercury_public_builtin_module(Module) + -> + SymName = unqualified(Name) + ; + SymName = SymName0 + ). strip_builtin_qualifiers_from_inst_list(Insts0, Insts) :- - list__map(strip_builtin_qualifiers_from_inst, Insts0, Insts). + list__map(strip_builtin_qualifiers_from_inst, Insts0, Insts). strip_builtin_qualifiers_from_inst(inst_var(V), inst_var(V)). strip_builtin_qualifiers_from_inst(constrained_inst_vars(Vars, Inst0), - constrained_inst_vars(Vars, Inst)) :- - strip_builtin_qualifiers_from_inst(Inst0, Inst). + constrained_inst_vars(Vars, Inst)) :- + strip_builtin_qualifiers_from_inst(Inst0, Inst). strip_builtin_qualifiers_from_inst(not_reached, not_reached). strip_builtin_qualifiers_from_inst(free, free). strip_builtin_qualifiers_from_inst(free(Type), free(Type)). strip_builtin_qualifiers_from_inst(any(Uniq), any(Uniq)). strip_builtin_qualifiers_from_inst(ground(Uniq, GII0), ground(Uniq, GII)) :- - strip_builtin_qualifiers_from_ground_inst_info(GII0, GII). + strip_builtin_qualifiers_from_ground_inst_info(GII0, GII). strip_builtin_qualifiers_from_inst(bound(Uniq, BoundInsts0), - bound(Uniq, BoundInsts)) :- - strip_builtin_qualifiers_from_bound_inst_list(BoundInsts0, BoundInsts). + bound(Uniq, BoundInsts)) :- + strip_builtin_qualifiers_from_bound_inst_list(BoundInsts0, BoundInsts). strip_builtin_qualifiers_from_inst(defined_inst(Name0), defined_inst(Name)) :- - strip_builtin_qualifiers_from_inst_name(Name0, Name). + strip_builtin_qualifiers_from_inst_name(Name0, Name). strip_builtin_qualifiers_from_inst(abstract_inst(Name0, Args0), - abstract_inst(Name, Args)) :- - strip_builtin_qualifier_from_sym_name(Name0, Name), - strip_builtin_qualifiers_from_inst_list(Args0, Args). + abstract_inst(Name, Args)) :- + strip_builtin_qualifier_from_sym_name(Name0, Name), + strip_builtin_qualifiers_from_inst_list(Args0, Args). :- pred strip_builtin_qualifiers_from_bound_inst_list(list(bound_inst)::in, - list(bound_inst)::out) is det. + list(bound_inst)::out) is det. strip_builtin_qualifiers_from_bound_inst_list(Insts0, Insts) :- - list__map(strip_builtin_qualifiers_from_bound_inst, Insts0, Insts). + list__map(strip_builtin_qualifiers_from_bound_inst, Insts0, Insts). :- pred strip_builtin_qualifiers_from_bound_inst(bound_inst::in, - bound_inst::out) is det. + bound_inst::out) is det. + strip_builtin_qualifiers_from_bound_inst(BoundInst0, BoundInst) :- - BoundInst0 = functor(ConsId0, Insts0), - strip_builtin_qualifier_from_cons_id(ConsId0, ConsId), - BoundInst = functor(ConsId, Insts), - list__map(strip_builtin_qualifiers_from_inst, Insts0, Insts). + BoundInst0 = functor(ConsId0, Insts0), + strip_builtin_qualifier_from_cons_id(ConsId0, ConsId), + BoundInst = functor(ConsId, Insts), + list__map(strip_builtin_qualifiers_from_inst, Insts0, Insts). :- pred strip_builtin_qualifiers_from_inst_name(inst_name::in, inst_name::out) - is det. + is det. strip_builtin_qualifiers_from_inst_name(user_inst(SymName0, Insts0), - user_inst(SymName, Insts)) :- - strip_builtin_qualifier_from_sym_name(SymName0, SymName), - strip_builtin_qualifiers_from_inst_list(Insts0, Insts). + user_inst(SymName, Insts)) :- + strip_builtin_qualifier_from_sym_name(SymName0, SymName), + strip_builtin_qualifiers_from_inst_list(Insts0, Insts). strip_builtin_qualifiers_from_inst_name(merge_inst(InstA0, InstB0), - merge_inst(InstA, InstB)) :- - strip_builtin_qualifiers_from_inst(InstA0, InstA), - strip_builtin_qualifiers_from_inst(InstB0, InstB). + merge_inst(InstA, InstB)) :- + strip_builtin_qualifiers_from_inst(InstA0, InstA), + strip_builtin_qualifiers_from_inst(InstB0, InstB). strip_builtin_qualifiers_from_inst_name(unify_inst(Live, InstA0, InstB0, Real), - unify_inst(Live, InstA, InstB, Real)) :- - strip_builtin_qualifiers_from_inst(InstA0, InstA), - strip_builtin_qualifiers_from_inst(InstB0, InstB). + unify_inst(Live, InstA, InstB, Real)) :- + strip_builtin_qualifiers_from_inst(InstA0, InstA), + strip_builtin_qualifiers_from_inst(InstB0, InstB). strip_builtin_qualifiers_from_inst_name( - ground_inst(InstName0, Live, Uniq, Real), - ground_inst(InstName, Live, Uniq, Real)) :- - strip_builtin_qualifiers_from_inst_name(InstName0, InstName). + ground_inst(InstName0, Live, Uniq, Real), + ground_inst(InstName, Live, Uniq, Real)) :- + strip_builtin_qualifiers_from_inst_name(InstName0, InstName). strip_builtin_qualifiers_from_inst_name( - any_inst(InstName0, Live, Uniq, Real), - any_inst(InstName, Live, Uniq, Real)) :- - strip_builtin_qualifiers_from_inst_name(InstName0, InstName). + any_inst(InstName0, Live, Uniq, Real), + any_inst(InstName, Live, Uniq, Real)) :- + strip_builtin_qualifiers_from_inst_name(InstName0, InstName). strip_builtin_qualifiers_from_inst_name(shared_inst(InstName0), - shared_inst(InstName)) :- - strip_builtin_qualifiers_from_inst_name(InstName0, InstName). + shared_inst(InstName)) :- + strip_builtin_qualifiers_from_inst_name(InstName0, InstName). strip_builtin_qualifiers_from_inst_name(mostly_uniq_inst(InstName0), - mostly_uniq_inst(InstName)) :- - strip_builtin_qualifiers_from_inst_name(InstName0, InstName). + mostly_uniq_inst(InstName)) :- + strip_builtin_qualifiers_from_inst_name(InstName0, InstName). strip_builtin_qualifiers_from_inst_name(typed_ground(Uniq, Type), - typed_ground(Uniq, Type)). + typed_ground(Uniq, Type)). strip_builtin_qualifiers_from_inst_name(typed_inst(Type, InstName0), - typed_inst(Type, InstName)) :- - strip_builtin_qualifiers_from_inst_name(InstName0, InstName). + typed_inst(Type, InstName)) :- + strip_builtin_qualifiers_from_inst_name(InstName0, InstName). :- pred strip_builtin_qualifiers_from_ground_inst_info(ground_inst_info::in, - ground_inst_info::out) is det. + ground_inst_info::out) is det. strip_builtin_qualifiers_from_ground_inst_info(none, none). strip_builtin_qualifiers_from_ground_inst_info(higher_order(Pred0), - higher_order(Pred)) :- - Pred0 = pred_inst_info(PorF, Modes0, Det), - Pred = pred_inst_info(PorF, Modes, Det), - strip_builtin_qualifiers_from_mode_list(Modes0, Modes). + higher_order(Pred)) :- + Pred0 = pred_inst_info(PorF, Modes0, Det), + Pred = pred_inst_info(PorF, Modes, Det), + strip_builtin_qualifiers_from_mode_list(Modes0, Modes). %-----------------------------------------------------------------------------% diff --git a/compiler/prog_mutable.m b/compiler/prog_mutable.m index c3e548261..1939dd41d 100644 --- a/compiler/prog_mutable.m +++ b/compiler/prog_mutable.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 2005 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. @@ -20,40 +22,39 @@ %-----------------------------------------------------------------------------% - % Create a predmode declaration for a non-pure mutable get predicate. - % (This is the default get predicate.) - % + % Create a predmode declaration for a non-pure mutable get predicate. + % (This is the default get predicate.) + % :- func nonpure_get_pred_decl(module_name, string, (type), (inst)) = item. - % Create a predmode declaration for a non-pure mutable set predicate. - % (This is the default set predicate.) - % + % Create a predmode declaration for a non-pure mutable set predicate. + % (This is the default set predicate.) + % :- func nonpure_set_pred_decl(module_name, string, (type), (inst)) = item. - % Create a predmode declaration for a pure mutable get predicate. - % (This is only created if the `pure' mutable attribute is given.) - % + % Create a predmode declaration for a pure mutable get predicate. + % (This is only created if the `pure' mutable attribute is given.) + % :- func pure_get_pred_decl(module_name, string, (type), (inst)) = item. - % Create a predmode declaration for a pure mutable set predicate. - % (This is only create the `pure' mutable attribute is give.) - % + % Create a predmode declaration for a pure mutable set predicate. + % (This is only create the `pure' mutable attribute is give.) + % :- func pure_set_pred_decl(module_name, string, (type), (inst)) = item. - - % Create a predmode declaration for the mutable initialisation - % predicate. - % + + % Create a predmode declaration for the mutable initialisation + % predicate. + % :- func init_pred_decl(module_name, string) = item. - % Create the foreign_decl for the mutable. - % + % Create the foreign_decl for the mutable. + % :- func get_global_foreign_decl(string) = item. - % Create the foreign_code that defines the mutable. - % + % Create the foreign_code that defines the mutable. + % :- func get_global_foreign_defn(string) = item. - :- func mutable_get_pred_sym_name(sym_name, string) = sym_name. :- func mutable_set_pred_sym_name(sym_name, string) = sym_name. @@ -77,100 +78,96 @@ %-----------------------------------------------------------------------------% nonpure_get_pred_decl(ModuleName, Name, Type, Inst) = GetPredDecl :- - VarSet = varset__init, - InstVarSet = varset__init, - ExistQVars = [], - Constraints = constraints([], []), - GetPredDecl = pred_or_func(VarSet, InstVarSet, ExistQVars, predicate, - mutable_get_pred_sym_name(ModuleName, Name), - [type_and_mode(Type, out_mode(Inst))], - no /* with_type */, no /* with_inst */, yes(det), - true /* condition */, (semipure), Constraints). - + VarSet = varset__init, + InstVarSet = varset__init, + ExistQVars = [], + Constraints = constraints([], []), + GetPredDecl = pred_or_func(VarSet, InstVarSet, ExistQVars, predicate, + mutable_get_pred_sym_name(ModuleName, Name), + [type_and_mode(Type, out_mode(Inst))], + no /* with_type */, no /* with_inst */, yes(det), + true /* condition */, (semipure), Constraints). + nonpure_set_pred_decl(ModuleName, Name, Type, Inst) = SetPredDecl :- - VarSet = varset__init, - InstVarSet = varset__init, - ExistQVars = [], - Constraints = constraints([], []), - SetPredDecl = pred_or_func(VarSet, InstVarSet, ExistQVars, predicate, - mutable_set_pred_sym_name(ModuleName, Name), - [type_and_mode(Type, in_mode(Inst))], - no /* with_type */, no /* with_inst */, yes(det), - true /* condition */, (impure), Constraints). + VarSet = varset__init, + InstVarSet = varset__init, + ExistQVars = [], + Constraints = constraints([], []), + SetPredDecl = pred_or_func(VarSet, InstVarSet, ExistQVars, predicate, + mutable_set_pred_sym_name(ModuleName, Name), + [type_and_mode(Type, in_mode(Inst))], + no /* with_type */, no /* with_inst */, yes(det), + true /* condition */, (impure), Constraints). pure_get_pred_decl(ModuleName, Name, Type, Inst) = GetPredDecl :- - VarSet = varset__init, - InstVarSet = varset__init, - ExistQVars = [], - Constraints = constraints([], []), - GetPredDecl = pred_or_func(VarSet, InstVarSet, ExistQVars, predicate, - mutable_get_pred_sym_name(ModuleName, Name), - [ - type_and_mode(Type, out_mode(Inst)), - type_and_mode(io_state_type, di_mode), - type_and_mode(io_state_type, uo_mode) - ], - no /* with_type */, no /* with_inst */, yes(det), - true /* condition */, pure, Constraints). + VarSet = varset__init, + InstVarSet = varset__init, + ExistQVars = [], + Constraints = constraints([], []), + GetPredDecl = pred_or_func(VarSet, InstVarSet, ExistQVars, predicate, + mutable_get_pred_sym_name(ModuleName, Name), + [type_and_mode(Type, out_mode(Inst)), + type_and_mode(io_state_type, di_mode), + type_and_mode(io_state_type, uo_mode)], + no /* with_type */, no /* with_inst */, yes(det), + true /* condition */, pure, Constraints). pure_set_pred_decl(ModuleName, Name, Type, Inst) = SetPredDecl :- - VarSet = varset__init, - InstVarSet = varset__init, - ExistQVars = [], - Constraints = constraints([], []), - SetPredDecl = pred_or_func(VarSet, InstVarSet, ExistQVars, predicate, - mutable_set_pred_sym_name(ModuleName, Name), - [ - type_and_mode(Type, in_mode(Inst)), - type_and_mode(io_state_type, di_mode), - type_and_mode(io_state_type, uo_mode) - ], - no /* with_type */, no /* with_inst */, yes(det), - true /* condition */, pure, Constraints). + VarSet = varset__init, + InstVarSet = varset__init, + ExistQVars = [], + Constraints = constraints([], []), + SetPredDecl = pred_or_func(VarSet, InstVarSet, ExistQVars, predicate, + mutable_set_pred_sym_name(ModuleName, Name), + [type_and_mode(Type, in_mode(Inst)), + type_and_mode(io_state_type, di_mode), + type_and_mode(io_state_type, uo_mode)], + no /* with_type */, no /* with_inst */, yes(det), + true /* condition */, pure, Constraints). - % Return the type io.state. - % XXX Perhaps this should be in prog_type? - % + % Return the type io.state. + % XXX Perhaps this should be in prog_type? + % :- func io_state_type = (type). io_state_type = defined(qualified(unqualified("io"), "state"), [], star). init_pred_decl(ModuleName, Name) = InitPredDecl :- - VarSet = varset__init, - InstVarSet = varset__init, - ExistQVars = [], - Constraints = constraints([], []), - InitPredDecl = pred_or_func(VarSet, InstVarSet, ExistQVars, - predicate, mutable_init_pred_sym_name(ModuleName, Name), - [], no /* with_type */, no /* with_inst */, yes(det), - true /* condition */, (impure), Constraints). + VarSet = varset__init, + InstVarSet = varset__init, + ExistQVars = [], + Constraints = constraints([], []), + InitPredDecl = pred_or_func(VarSet, InstVarSet, ExistQVars, + predicate, mutable_init_pred_sym_name(ModuleName, Name), + [], no /* with_type */, no /* with_inst */, yes(det), + true /* condition */, (impure), Constraints). %-----------------------------------------------------------------------------% -get_global_foreign_decl(TargetMutableName) = - pragma(compiler(mutable_decl), - foreign_decl(c, foreign_decl_is_exported, - "extern MR_Word " ++ TargetMutableName ++ ";")). +get_global_foreign_decl(TargetMutableName) = + pragma(compiler(mutable_decl), + foreign_decl(c, foreign_decl_is_exported, + "extern MR_Word " ++ TargetMutableName ++ ";")). -get_global_foreign_defn(TargetMutableName) = - pragma(compiler(mutable_decl), - foreign_code(c, "MR_Word " ++ TargetMutableName ++ ";")). +get_global_foreign_defn(TargetMutableName) = + pragma(compiler(mutable_decl), + foreign_code(c, "MR_Word " ++ TargetMutableName ++ ";")). %-----------------------------------------------------------------------------% -mutable_get_pred_sym_name(ModuleName, Name) = +mutable_get_pred_sym_name(ModuleName, Name) = qualified(ModuleName, "get_" ++ Name). -mutable_set_pred_sym_name(ModuleName, Name) = +mutable_set_pred_sym_name(ModuleName, Name) = qualified(ModuleName, "set_" ++ Name). mutable_init_pred_sym_name(ModuleName, Name) = qualified(ModuleName, "initialise_mutable_" ++ Name). mutable_c_var_name(ModuleName, Name) = MangledCVarName :- - RawCVarName = "mutable_variable_" ++ Name, - QualifiedCVarName = qualified(ModuleName, RawCVarName), - MangledCVarName = sym_name_mangle(QualifiedCVarName). + RawCVarName = "mutable_variable_" ++ Name, + QualifiedCVarName = qualified(ModuleName, RawCVarName), + MangledCVarName = sym_name_mangle(QualifiedCVarName). %-----------------------------------------------------------------------------% :- end_module prog_mutable. diff --git a/compiler/prog_rep.m b/compiler/prog_rep.m index 2f4530d8d..2dd9fab1b 100644 --- a/compiler/prog_rep.m +++ b/compiler/prog_rep.m @@ -1,4 +1,6 @@ %---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% % Copyright (C) 2000-2005 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. @@ -29,21 +31,20 @@ :- import_module map. :- import_module std_util. -% A var_num_map maps each variable that occurs in any of a procedure's layout -% structures to a number that uniquely identifies that variable, and to its -% name. -% -% The integer returned by term__var_to_int are a dense set when we consider -% all the original variables of a procedure. However, it can become less dense -% when an optimization removes all references to a variable, and becomes less -% dense still when we consider only variables that occur in a layout structure. -% This is why we allocate our own id numbers. + % A var_num_map maps each variable that occurs in any of a procedure's + % layout structures to a number that uniquely identifies that variable, + % and to its name. + % + % The integer returned by term__var_to_int are a dense set when we consider + % all the original variables of a procedure. However, it can become less + % dense when an optimization removes all references to a variable, and + % becomes less dense still when we consider only variables that occur + % in a layout structure. This is why we allocate our own id numbers. +:- type var_num_map == map(prog_var, pair(int, string)). -:- type var_num_map == map(prog_var, pair(int, string)). - -:- pred prog_rep__represent_proc(list(prog_var)::in, hlds_goal::in, - instmap::in, vartypes::in, var_num_map::in, module_info::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. +:- pred represent_proc(list(prog_var)::in, hlds_goal::in, + instmap::in, vartypes::in, var_num_map::in, module_info::in, + stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. :- implementation. @@ -67,312 +68,307 @@ :- import_module string. :- import_module term. -:- type prog_rep__info - ---> info( - filename :: string, - vartypes :: vartypes, - var_num_map :: var_num_map, - var_num_rep :: var_num_rep, - module_info :: module_info - ). +:- type prog_rep_info + ---> info( + filename :: string, + vartypes :: vartypes, + var_num_map :: var_num_map, + var_num_rep :: var_num_rep, + module_info :: module_info + ). -prog_rep__represent_proc(HeadVars, Goal, InstMap0, VarTypes, VarNumMap, - ModuleInfo, !StackInfo, ProcRepBytes) :- - Goal = _ - GoalInfo, - goal_info_get_context(GoalInfo, Context), - term__context_file(Context, FileName), - MaxVarNum = map.foldl(max_var_num, VarNumMap, 0), - ( - MaxVarNum =< 255 - -> - VarNumRep = byte - ; - VarNumRep = short - ), - Info = info(FileName, VarTypes, VarNumMap, VarNumRep, ModuleInfo), - var_num_rep_byte(VarNumRep, VarNumRepByte), +represent_proc(HeadVars, Goal, InstMap0, VarTypes, VarNumMap, + ModuleInfo, !StackInfo, ProcRepBytes) :- + Goal = _ - GoalInfo, + goal_info_get_context(GoalInfo, Context), + term__context_file(Context, FileName), + MaxVarNum = map.foldl(max_var_num, VarNumMap, 0), + ( MaxVarNum =< 255 -> + VarNumRep = byte + ; + VarNumRep = short + ), + Info = info(FileName, VarTypes, VarNumMap, VarNumRep, ModuleInfo), + var_num_rep_byte(VarNumRep, VarNumRepByte), - string_to_byte_list(FileName, !StackInfo, FileNameBytes), - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), - ProcRepBytes0 = [VarNumRepByte] ++ FileNameBytes ++ - vars_to_byte_list(Info, HeadVars) ++ - GoalBytes, - int32_to_byte_list(list__length(ProcRepBytes0) + 4, LimitBytes), - ProcRepBytes = LimitBytes ++ ProcRepBytes0. + string_to_byte_list(FileName, !StackInfo, FileNameBytes), + goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), + ProcRepBytes0 = [VarNumRepByte] ++ FileNameBytes ++ + vars_to_byte_list(Info, HeadVars) ++ GoalBytes, + int32_to_byte_list(list__length(ProcRepBytes0) + 4, LimitBytes), + ProcRepBytes = LimitBytes ++ ProcRepBytes0. %---------------------------------------------------------------------------% :- func max_var_num(prog_var, pair(int, string), int) = int. max_var_num(_, VarNum1 - _, VarNum2) = Max :- - ( - VarNum1 > VarNum2 - -> - Max = VarNum1 - ; - Max = VarNum2 - ). + ( VarNum1 > VarNum2 -> + Max = VarNum1 + ; + Max = VarNum2 + ). %---------------------------------------------------------------------------% -:- pred goal_to_byte_list(hlds_goal::in, instmap::in, prog_rep__info::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. +:- pred goal_to_byte_list(hlds_goal::in, instmap::in, prog_rep_info::in, + stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. goal_to_byte_list(GoalExpr - GoalInfo, InstMap0, Info, !StackInfo, Bytes) :- - goal_expr_to_byte_list(GoalExpr, GoalInfo, InstMap0, Info, !StackInfo, - Bytes). + goal_expr_to_byte_list(GoalExpr, GoalInfo, InstMap0, Info, !StackInfo, + Bytes). :- pred goal_expr_to_byte_list(hlds_goal_expr::in, hlds_goal_info::in, - instmap::in, prog_rep__info::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. + instmap::in, prog_rep_info::in, + stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. goal_expr_to_byte_list(conj(Goals), _, InstMap0, Info, !StackInfo, Bytes) :- - conj_to_byte_list(Goals, InstMap0, Info, !StackInfo, ConjBytes), - Bytes = [goal_type_to_byte(goal_conj)] ++ - length_to_byte_list(Goals) ++ ConjBytes. + conj_to_byte_list(Goals, InstMap0, Info, !StackInfo, ConjBytes), + Bytes = [goal_type_to_byte(goal_conj)] ++ + length_to_byte_list(Goals) ++ ConjBytes. goal_expr_to_byte_list(par_conj(_), _, _, _, !StackInfo, _) :- - sorry("prog_rep", "parallel conjunctions and declarative debugging"). + sorry("prog_rep", "parallel conjunctions and declarative debugging"). goal_expr_to_byte_list(disj(Goals), _, InstMap0, Info, !StackInfo, Bytes) :- - disj_to_byte_list(Goals, InstMap0, Info, !StackInfo, DisjBytes), - Bytes = [goal_type_to_byte(goal_disj)] ++ - length_to_byte_list(Goals) ++ DisjBytes. + disj_to_byte_list(Goals, InstMap0, Info, !StackInfo, DisjBytes), + Bytes = [goal_type_to_byte(goal_disj)] ++ + length_to_byte_list(Goals) ++ DisjBytes. goal_expr_to_byte_list(not(Goal), _GoalInfo, InstMap0, Info, !StackInfo, Bytes) - :- - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), - Bytes = [goal_type_to_byte(goal_neg)] ++ GoalBytes. + :- + goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), + Bytes = [goal_type_to_byte(goal_neg)] ++ GoalBytes. goal_expr_to_byte_list(if_then_else(_, Cond, Then, Else), _, InstMap0, Info, - !StackInfo, Bytes) :- - Cond = _ - CondGoalInfo, - goal_info_get_instmap_delta(CondGoalInfo, InstMapDelta), - instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap1), - goal_to_byte_list(Cond, InstMap0, Info, !StackInfo, CondBytes), - goal_to_byte_list(Then, InstMap1, Info, !StackInfo, ThenBytes), - goal_to_byte_list(Else, InstMap0, Info, !StackInfo, ElseBytes), - Bytes = [goal_type_to_byte(goal_ite)] ++ - CondBytes ++ ThenBytes ++ ElseBytes. + !StackInfo, Bytes) :- + Cond = _ - CondGoalInfo, + goal_info_get_instmap_delta(CondGoalInfo, InstMapDelta), + instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap1), + goal_to_byte_list(Cond, InstMap0, Info, !StackInfo, CondBytes), + goal_to_byte_list(Then, InstMap1, Info, !StackInfo, ThenBytes), + goal_to_byte_list(Else, InstMap0, Info, !StackInfo, ElseBytes), + Bytes = [goal_type_to_byte(goal_ite)] ++ + CondBytes ++ ThenBytes ++ ElseBytes. goal_expr_to_byte_list(unify(_, _, _, Uni, _), GoalInfo, InstMap0, Info, - !StackInfo, Bytes) :- - atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, - AtomicBytes, BoundVars), - ( - Uni = assign(Target, Source), - Bytes = [goal_type_to_byte(goal_assign)] ++ - var_to_byte_list(Info, Target) ++ - var_to_byte_list(Info, Source) ++ - AtomicBytes - ; - Uni = construct(Var, ConsId, Args, ArgModes, _, _, _), - cons_id_to_byte_list(ConsId, !StackInfo, ConsIdBytes), - ( list.all_true(lhs_final_is_ground(Info), ArgModes) -> - Bytes = [goal_type_to_byte(goal_construct)] ++ - var_to_byte_list(Info, Var) ++ - ConsIdBytes ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes - ; - filter_input_args(Info, ArgModes, Args, MaybeArgs), - Bytes = [goal_type_to_byte(goal_partial_construct)] ++ - var_to_byte_list(Info, Var) ++ - ConsIdBytes ++ - maybe_vars_to_byte_list(Info, MaybeArgs) ++ - AtomicBytes - ) - ; - Uni = deconstruct(Var, ConsId, Args, ArgModes, _, _), - cons_id_to_byte_list(ConsId, !StackInfo, ConsIdBytes), - ( list.member(Var, BoundVars) -> - filter_input_args(Info, ArgModes, Args, MaybeArgs), - Bytes = [goal_type_to_byte(goal_partial_deconstruct)]++ - var_to_byte_list(Info, Var) ++ - ConsIdBytes ++ - maybe_vars_to_byte_list(Info, MaybeArgs) ++ - AtomicBytes - ; - Bytes = [goal_type_to_byte(goal_deconstruct)] ++ - var_to_byte_list(Info, Var) ++ - ConsIdBytes ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes - ) - ; - Uni = simple_test(Var1, Var2), - Bytes = [goal_type_to_byte(goal_simple_test)] ++ - var_to_byte_list(Info, Var1) ++ - var_to_byte_list(Info, Var2) ++ - AtomicBytes - ; - Uni = complicated_unify(_, _, _), - error("goal_expr_to_byte_list: complicated_unify") - ). + !StackInfo, Bytes) :- + atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, + AtomicBytes, BoundVars), + ( + Uni = assign(Target, Source), + Bytes = [goal_type_to_byte(goal_assign)] ++ + var_to_byte_list(Info, Target) ++ + var_to_byte_list(Info, Source) ++ + AtomicBytes + ; + Uni = construct(Var, ConsId, Args, ArgModes, _, _, _), + cons_id_to_byte_list(ConsId, !StackInfo, ConsIdBytes), + ( list.all_true(lhs_final_is_ground(Info), ArgModes) -> + Bytes = [goal_type_to_byte(goal_construct)] ++ + var_to_byte_list(Info, Var) ++ + ConsIdBytes ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ; + filter_input_args(Info, ArgModes, Args, MaybeArgs), + Bytes = [goal_type_to_byte(goal_partial_construct)] ++ + var_to_byte_list(Info, Var) ++ + ConsIdBytes ++ + maybe_vars_to_byte_list(Info, MaybeArgs) ++ + AtomicBytes + ) + ; + Uni = deconstruct(Var, ConsId, Args, ArgModes, _, _), + cons_id_to_byte_list(ConsId, !StackInfo, ConsIdBytes), + ( list.member(Var, BoundVars) -> + filter_input_args(Info, ArgModes, Args, MaybeArgs), + Bytes = [goal_type_to_byte(goal_partial_deconstruct)]++ + var_to_byte_list(Info, Var) ++ + ConsIdBytes ++ + maybe_vars_to_byte_list(Info, MaybeArgs) ++ + AtomicBytes + ; + Bytes = [goal_type_to_byte(goal_deconstruct)] ++ + var_to_byte_list(Info, Var) ++ + ConsIdBytes ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ) + ; + Uni = simple_test(Var1, Var2), + Bytes = [goal_type_to_byte(goal_simple_test)] ++ + var_to_byte_list(Info, Var1) ++ + var_to_byte_list(Info, Var2) ++ + AtomicBytes + ; + Uni = complicated_unify(_, _, _), + error("goal_expr_to_byte_list: complicated_unify") + ). goal_expr_to_byte_list(switch(_, _, Cases), _, InstMap0, Info, !StackInfo, - Bytes) :- - cases_to_byte_list(Cases, InstMap0, Info, !StackInfo, CasesBytes), - Bytes = [goal_type_to_byte(goal_switch)] ++ - length_to_byte_list(Cases) ++ CasesBytes. + Bytes) :- + cases_to_byte_list(Cases, InstMap0, Info, !StackInfo, CasesBytes), + Bytes = [goal_type_to_byte(goal_switch)] ++ + length_to_byte_list(Cases) ++ CasesBytes. goal_expr_to_byte_list(scope(_, Goal), GoalInfo, InstMap0, Info, !StackInfo, - Bytes) :- - Goal = _ - InnerGoalInfo, - goal_info_get_determinism(GoalInfo, OuterDetism), - goal_info_get_determinism(InnerGoalInfo, InnerDetism), - ( InnerDetism = OuterDetism -> - MaybeCut = 0 - ; - MaybeCut = 1 - ), - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), - Bytes = [goal_type_to_byte(goal_scope)] ++ - [MaybeCut] ++ GoalBytes. + Bytes) :- + Goal = _ - InnerGoalInfo, + goal_info_get_determinism(GoalInfo, OuterDetism), + goal_info_get_determinism(InnerGoalInfo, InnerDetism), + ( InnerDetism = OuterDetism -> + MaybeCut = 0 + ; + MaybeCut = 1 + ), + goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), + Bytes = [goal_type_to_byte(goal_scope)] ++ + [MaybeCut] ++ GoalBytes. goal_expr_to_byte_list(generic_call(GenericCall, Args, _, _), - GoalInfo, InstMap0, Info, !StackInfo, Bytes) :- - atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, - AtomicBytes, _), - ( - GenericCall = higher_order(PredVar, _, _, _), - Bytes = [goal_type_to_byte(goal_ho_call)] ++ - var_to_byte_list(Info, PredVar) ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes - ; - GenericCall = class_method(Var, MethodNum, _, _), - Bytes = [goal_type_to_byte(goal_method_call)] ++ - var_to_byte_list(Info, Var) ++ - method_num_to_byte_list(MethodNum) ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes - ; - GenericCall = cast(_), - ( Args = [InputArg, OutputArg] -> - Bytes = [goal_type_to_byte(goal_cast)] ++ - var_to_byte_list(Info, OutputArg) ++ - var_to_byte_list(Info, InputArg) ++ - AtomicBytes - ; - error("goal_expr_to_byte_list: cast arity != 2") - ) - ; - GenericCall = aditi_builtin(_, _), - error("Sorry, not yet implemented\n\ - Aditi and declarative debugging") - ). + GoalInfo, InstMap0, Info, !StackInfo, Bytes) :- + atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, + AtomicBytes, _), + ( + GenericCall = higher_order(PredVar, _, _, _), + Bytes = [goal_type_to_byte(goal_ho_call)] ++ + var_to_byte_list(Info, PredVar) ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ; + GenericCall = class_method(Var, MethodNum, _, _), + Bytes = [goal_type_to_byte(goal_method_call)] ++ + var_to_byte_list(Info, Var) ++ + method_num_to_byte_list(MethodNum) ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ; + GenericCall = cast(_), + ( Args = [InputArg, OutputArg] -> + Bytes = [goal_type_to_byte(goal_cast)] ++ + var_to_byte_list(Info, OutputArg) ++ + var_to_byte_list(Info, InputArg) ++ + AtomicBytes + ; + error("goal_expr_to_byte_list: cast arity != 2") + ) + ; + GenericCall = aditi_builtin(_, _), + error("Sorry, not yet implemented\n\ + Aditi and declarative debugging") + ). goal_expr_to_byte_list(call(PredId, _, Args, Builtin, _, _), - GoalInfo, InstMap0, Info, !StackInfo, Bytes) :- - atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, - AtomicBytes, _), - module_info_pred_info(Info ^ module_info, PredId, PredInfo), - ModuleSymName = pred_info_module(PredInfo), - mdbcomp__prim_data__sym_name_to_string(ModuleSymName, ModuleName), - PredName = pred_info_name(PredInfo), - string_to_byte_list(ModuleName, !StackInfo, ModuleNameBytes), - string_to_byte_list(PredName, !StackInfo, PredNameBytes), - ( Builtin = not_builtin -> - Bytes = [goal_type_to_byte(goal_plain_call)] ++ - ModuleNameBytes ++ - PredNameBytes ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes - ; - Bytes = [goal_type_to_byte(goal_builtin_call)] ++ - ModuleNameBytes ++ - PredNameBytes ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes - ). + GoalInfo, InstMap0, Info, !StackInfo, Bytes) :- + atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, + AtomicBytes, _), + module_info_pred_info(Info ^ module_info, PredId, PredInfo), + ModuleSymName = pred_info_module(PredInfo), + mdbcomp__prim_data__sym_name_to_string(ModuleSymName, ModuleName), + PredName = pred_info_name(PredInfo), + string_to_byte_list(ModuleName, !StackInfo, ModuleNameBytes), + string_to_byte_list(PredName, !StackInfo, PredNameBytes), + ( Builtin = not_builtin -> + Bytes = [goal_type_to_byte(goal_plain_call)] ++ + ModuleNameBytes ++ + PredNameBytes ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ; + Bytes = [goal_type_to_byte(goal_builtin_call)] ++ + ModuleNameBytes ++ + PredNameBytes ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ). goal_expr_to_byte_list(foreign_proc(_, _PredId, _, Args, _, _), - GoalInfo, InstMap0, Info, !StackInfo, Bytes) :- - ArgVars = list__map(foreign_arg_var, Args), - atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, - AtomicBytes, _), - Bytes = [goal_type_to_byte(goal_foreign)] ++ - vars_to_byte_list(Info, ArgVars) ++ AtomicBytes. + GoalInfo, InstMap0, Info, !StackInfo, Bytes) :- + ArgVars = list__map(foreign_arg_var, Args), + atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, + AtomicBytes, _), + Bytes = [goal_type_to_byte(goal_foreign)] ++ + vars_to_byte_list(Info, ArgVars) ++ AtomicBytes. goal_expr_to_byte_list(shorthand(_), _, _, _, !StackInfo, _) :- - % these should have been expanded out by now - error("goal_expr_to_byte_list: unexpected shorthand"). + % these should have been expanded out by now + error("goal_expr_to_byte_list: unexpected shorthand"). -:- pred lhs_final_is_ground(prog_rep__info::in, uni_mode::in) is semidet. +:- pred lhs_final_is_ground(prog_rep_info::in, uni_mode::in) is semidet. lhs_final_is_ground(Info, (_ - _) -> (LHSFinalInst - _)) :- - inst_is_ground(Info ^ module_info, LHSFinalInst). + inst_is_ground(Info ^ module_info, LHSFinalInst). -:- pred rhs_is_input(prog_rep__info::in, uni_mode::in) is semidet. +:- pred rhs_is_input(prog_rep_info::in, uni_mode::in) is semidet. rhs_is_input(Info, (_ - RHSInitialInst) -> (_ - RHSFinalInst)) :- - mode_is_input(Info ^ module_info, RHSInitialInst -> RHSFinalInst). + mode_is_input(Info ^ module_info, RHSInitialInst -> RHSFinalInst). -:- pred filter_input_args(prog_rep__info::in, list(uni_mode)::in, - list(prog_var)::in, list(maybe(prog_var))::out) is det. +:- pred filter_input_args(prog_rep_info::in, list(uni_mode)::in, + list(prog_var)::in, list(maybe(prog_var))::out) is det. filter_input_args(_, [], [], []). -filter_input_args(Info, [Mode | Modes], [Var | Vars], [MaybeVar | MaybeVars]) - :- - ( rhs_is_input(Info, Mode) -> - MaybeVar = yes(Var) - ; - MaybeVar = no - ), - filter_input_args(Info, Modes, Vars, MaybeVars). +filter_input_args(Info, [Mode | Modes], [Var | Vars], + [MaybeVar | MaybeVars]) :- + ( rhs_is_input(Info, Mode) -> + MaybeVar = yes(Var) + ; + MaybeVar = no + ), + filter_input_args(Info, Modes, Vars, MaybeVars). filter_input_args(_, [], [_ | _], _) :- - error("filter_input_args: more vars than modes"). + error("filter_input_args: more vars than modes"). filter_input_args(_, [_ | _], [], _) :- - error("filter_input_args: more modes than vars"). + error("filter_input_args: more modes than vars"). %---------------------------------------------------------------------------% :- pred atomic_goal_info_to_byte_list(hlds_goal_info::in, instmap::in, - prog_rep__info::in, stack_layout_info::in, stack_layout_info::out, - list(int)::out, list(prog_var)::out) is det. + prog_rep_info::in, stack_layout_info::in, stack_layout_info::out, + list(int)::out, list(prog_var)::out) is det. atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, Bytes, - BoundVars) :- - goal_info_get_determinism(GoalInfo, Detism), - goal_info_get_context(GoalInfo, Context), - term__context_file(Context, FileName0), - ( FileName0 = Info ^ filename -> - FileName = "" - ; - FileName = FileName0 - ), - term__context_line(Context, LineNo), - goal_info_get_instmap_delta(GoalInfo, InstMapDelta), - instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap), - instmap_changed_vars(InstMap0, InstMap, Info ^ vartypes, - Info ^ module_info, ChangedVars), - set__to_sorted_list(ChangedVars, BoundVars), - string_to_byte_list(FileName, !StackInfo, FileNameBytes), - Bytes = [represent_determinism(Detism)] ++ - FileNameBytes ++ - lineno_to_byte_list(LineNo) ++ - vars_to_byte_list(Info, BoundVars). + BoundVars) :- + goal_info_get_determinism(GoalInfo, Detism), + goal_info_get_context(GoalInfo, Context), + term__context_file(Context, FileName0), + ( FileName0 = Info ^ filename -> + FileName = "" + ; + FileName = FileName0 + ), + term__context_line(Context, LineNo), + goal_info_get_instmap_delta(GoalInfo, InstMapDelta), + instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap), + instmap_changed_vars(InstMap0, InstMap, Info ^ vartypes, + Info ^ module_info, ChangedVars), + set__to_sorted_list(ChangedVars, BoundVars), + string_to_byte_list(FileName, !StackInfo, FileNameBytes), + Bytes = [represent_determinism(Detism)] ++ + FileNameBytes ++ + lineno_to_byte_list(LineNo) ++ + vars_to_byte_list(Info, BoundVars). :- pred cons_id_to_byte_list(cons_id::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. + stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. cons_id_to_byte_list(SymName, !StackInfo, Bytes) :- - string_to_byte_list(cons_id_to_string(SymName), !StackInfo, Bytes). + string_to_byte_list(cons_id_to_string(SymName), !StackInfo, Bytes). :- func cons_id_to_string(cons_id) = string. cons_id_to_string(cons(SymName, _)) = - prog_rep__sym_base_name_to_string(SymName). + prog_rep__sym_base_name_to_string(SymName). cons_id_to_string(int_const(Int)) = - string__int_to_string(Int). + string__int_to_string(Int). cons_id_to_string(float_const(Float)) = - string__float_to_string(Float). + string__float_to_string(Float). cons_id_to_string(string_const(String)) = - string__append_list(["""", String, """"]). + string__append_list(["""", String, """"]). cons_id_to_string(pred_const(_, _)) = "$pred_const". cons_id_to_string(type_ctor_info_const(_, _, _)) = - "$type_ctor_info_const". + "$type_ctor_info_const". cons_id_to_string(base_typeclass_info_const(_, _, _, _)) = - "$base_typeclass_info_const". + "$base_typeclass_info_const". cons_id_to_string(type_info_cell_constructor(_)) = - "$type_info_cell_constructor". + "$type_info_cell_constructor". cons_id_to_string(typeclass_info_cell_constructor) = - "$typeclass_info_cell_constructor". + "$typeclass_info_cell_constructor". cons_id_to_string(tabling_pointer_const(_)) = - "$tabling_pointer_const". + "$tabling_pointer_const". cons_id_to_string(deep_profiling_proc_layout(_)) = - "$deep_profiling_procedure_data". + "$deep_profiling_procedure_data". cons_id_to_string(table_io_decl(_)) = - "$table_io_decl". + "$table_io_decl". :- func sym_base_name_to_string(sym_name) = string. @@ -381,43 +377,43 @@ sym_base_name_to_string(qualified(_, String)) = String. %---------------------------------------------------------------------------% -:- pred conj_to_byte_list(hlds_goals::in, instmap::in, prog_rep__info::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. +:- pred conj_to_byte_list(hlds_goals::in, instmap::in, prog_rep_info::in, + stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. conj_to_byte_list([], _, _, !StackInfo, []). conj_to_byte_list([Goal | Goals], InstMap0, Info, !StackInfo, Bytes) :- - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), - Goal = _ - GoalInfo, - goal_info_get_instmap_delta(GoalInfo, InstMapDelta), - instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap1), - conj_to_byte_list(Goals, InstMap1, Info, !StackInfo, GoalsBytes), - Bytes = GoalBytes ++ GoalsBytes. + goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), + Goal = _ - GoalInfo, + goal_info_get_instmap_delta(GoalInfo, InstMapDelta), + instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap1), + conj_to_byte_list(Goals, InstMap1, Info, !StackInfo, GoalsBytes), + Bytes = GoalBytes ++ GoalsBytes. %---------------------------------------------------------------------------% -:- pred disj_to_byte_list(hlds_goals::in, instmap::in, prog_rep__info::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. +:- pred disj_to_byte_list(hlds_goals::in, instmap::in, prog_rep_info::in, + stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. disj_to_byte_list([], _, _, !StackInfo, []). disj_to_byte_list([Goal | Goals], InstMap0, Info, !StackInfo, Bytes) :- - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), - disj_to_byte_list(Goals, InstMap0, Info, !StackInfo, GoalsBytes), - Bytes = GoalBytes ++ GoalsBytes. + goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), + disj_to_byte_list(Goals, InstMap0, Info, !StackInfo, GoalsBytes), + Bytes = GoalBytes ++ GoalsBytes. %---------------------------------------------------------------------------% -:- pred cases_to_byte_list(list(case)::in, instmap::in, prog_rep__info::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. +:- pred cases_to_byte_list(list(case)::in, instmap::in, prog_rep_info::in, + stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. cases_to_byte_list([], _, _, !StackInfo, []). cases_to_byte_list([case(_ConsId, Goal) | Cases], InstMap0, Info, !StackInfo, - Bytes) :- - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), - cases_to_byte_list(Cases, InstMap0, Info, !StackInfo, GoalsBytes), - % XXX - % Bytes = cons_id_and_arity_to_byte_list(ConsId) - % ++ GoalBytes ++ GoalsBytes. - Bytes = GoalBytes ++ GoalsBytes. + Bytes) :- + goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), + cases_to_byte_list(Cases, InstMap0, Info, !StackInfo, GoalsBytes), + % XXX + % Bytes = cons_id_and_arity_to_byte_list(ConsId) + % ++ GoalBytes ++ GoalsBytes. + Bytes = GoalBytes ++ GoalsBytes. %---------------------------------------------------------------------------% @@ -433,66 +429,63 @@ cases_to_byte_list([case(_ConsId, Goal) | Cases], InstMap0, Info, !StackInfo, % halves their range. :- pred string_to_byte_list(string::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. + stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. string_to_byte_list(String, !StackInfo, Bytes) :- - stack_layout__lookup_string_in_table(String, Index, !StackInfo), - int32_to_byte_list(Index, Bytes). + stack_layout__lookup_string_in_table(String, Index, !StackInfo), + int32_to_byte_list(Index, Bytes). -:- func vars_to_byte_list(prog_rep__info, list(prog_var)) = list(int). +:- func vars_to_byte_list(prog_rep_info, list(prog_var)) = list(int). vars_to_byte_list(Info, Vars) = - length_to_byte_list(Vars) ++ - list__condense(list__map(var_to_byte_list(Info), Vars)). + length_to_byte_list(Vars) ++ + list__condense(list__map(var_to_byte_list(Info), Vars)). -:- func maybe_vars_to_byte_list(prog_rep__info, list(maybe(prog_var))) = - list(int). +:- func maybe_vars_to_byte_list(prog_rep_info, list(maybe(prog_var))) = + list(int). maybe_vars_to_byte_list(Info, Vars) = - length_to_byte_list(Vars) ++ - list__condense(list__map(maybe_var_to_byte_list(Info), Vars)). + length_to_byte_list(Vars) ++ + list__condense(list__map(maybe_var_to_byte_list(Info), Vars)). -:- func var_to_byte_list(prog_rep__info, prog_var) = list(int). +:- func var_to_byte_list(prog_rep_info, prog_var) = list(int). var_to_byte_list(Info, Var) = Bytes :- - map__lookup(Info ^ var_num_map, Var, VarNum - _), - ( - Info ^ var_num_rep = byte, - Bytes = [VarNum] - ; - Info ^ var_num_rep = short, - short_to_byte_list(VarNum, Bytes) - ). + map__lookup(Info ^ var_num_map, Var, VarNum - _), + ( + Info ^ var_num_rep = byte, + Bytes = [VarNum] + ; + Info ^ var_num_rep = short, + short_to_byte_list(VarNum, Bytes) + ). -:- func maybe_var_to_byte_list(prog_rep__info, maybe(prog_var)) = list(int). +:- func maybe_var_to_byte_list(prog_rep_info, maybe(prog_var)) = list(int). maybe_var_to_byte_list(Info, MaybeVar) = Bytes :- - % - % This is not the most efficient representation, however - % maybe(prog_var)'s are only used for partial unifications - % which are rare. - % - ( - MaybeVar = yes(Var), - Bytes = [1 | var_to_byte_list(Info, Var)] - ; - MaybeVar = no, - Bytes = [0] - ). + % This is not the most efficient representation, however maybe(prog_var)s + % are only used for partial unifications which are rare. + ( + MaybeVar = yes(Var), + Bytes = [1 | var_to_byte_list(Info, Var)] + ; + MaybeVar = no, + Bytes = [0] + ). :- func length_to_byte_list(list(T)) = list(int). length_to_byte_list(List) = Bytes :- - short_to_byte_list(list__length(List), Bytes). + short_to_byte_list(list__length(List), Bytes). :- func lineno_to_byte_list(int) = list(int). lineno_to_byte_list(VarNum) = Bytes :- - short_to_byte_list(VarNum, Bytes). + short_to_byte_list(VarNum, Bytes). :- func method_num_to_byte_list(int) = list(int). method_num_to_byte_list(VarNum) = Bytes :- - short_to_byte_list(VarNum, Bytes). + short_to_byte_list(VarNum, Bytes). %---------------------------------------------------------------------------% diff --git a/compiler/prog_type.m b/compiler/prog_type.m index 9aa505739..cd8dec450 100644 --- a/compiler/prog_type.m +++ b/compiler/prog_type.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 2005 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. @@ -31,135 +33,135 @@ % detection. % - % Succeeds iff the given type is a variable. - % + % Succeeds iff the given type is a variable. + % :- pred type_is_var((type)::in) is semidet. - % Succeeds iff the given type is not a variable. - % + % Succeeds iff the given type is not a variable. + % :- pred type_is_nonvar((type)::in) is semidet. - % Succeeds iff the given type is a higher-order predicate or function - % type. - % + % Succeeds iff the given type is a higher-order predicate or function + % type. + % :- pred type_is_higher_order((type)::in) is semidet. - % type_is_higher_order(Type, Purity, PredOrFunc, ArgTypes, EvalMeth): - % succeeds iff Type is a higher-order predicate or function type with - % the specified argument types (for functions, the return type is - % appended to the end of the argument types), purity, and - % evaluation method. - % + % type_is_higher_order(Type, Purity, PredOrFunc, ArgTypes, EvalMeth): + % succeeds iff Type is a higher-order predicate or function type with + % the specified argument types (for functions, the return type is + % appended to the end of the argument types), purity, and + % evaluation method. + % :- pred type_is_higher_order((type)::in, purity::out, pred_or_func::out, - lambda_eval_method::out, list(type)::out) is semidet. + lambda_eval_method::out, list(type)::out) is semidet. - % Succeed if the given type is a tuple type, returning - % the argument types. - % + % Succeed if the given type is a tuple type, returning + % the argument types. + % :- pred type_is_tuple((type)::in, list(type)::out) is semidet. - % Remove the kind annotation at the top-level if there is one, - % otherwise return the type unchanged. - % + % Remove the kind annotation at the top-level if there is one, + % otherwise return the type unchanged. + % :- func strip_kind_annotation(type) = (type). - + %-----------------------------------------------------------------------------% - % Succeeds iff the given type is ground (that is, contains no type - % variables). - % + % Succeeds iff the given type is ground (that is, contains no type + % variables). + % :- pred type_is_ground((type)::in) is semidet. - % Succeeds iff the given type is not ground. - % + % Succeeds iff the given type is not ground. + % :- pred type_is_nonground((type)::in) is semidet. - % Succeeds iff the given type with the substitution applied is ground. - % + % Succeeds iff the given type with the substitution applied is ground. + % :- pred type_is_ground((type)::in, tsubst::in) is semidet. - % Succeeds iff the given type with the substitution applied is not - % ground. - % + % Succeeds iff the given type with the substitution applied is not + % ground. + % :- pred type_is_nonground((type)::in, tsubst::in) is semidet. - % type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs) - % Check if the principal type constructor of Type is of variable arity. - % If yes, return the type constructor as TypeCtor and its args as - % TypeArgs. If not, fail. - % + % type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs) + % Check if the principal type constructor of Type is of variable arity. + % If yes, return the type constructor as TypeCtor and its args as + % TypeArgs. If not, fail. + % :- pred type_has_variable_arity_ctor((type)::in, type_ctor::out, - list(type)::out) is semidet. + list(type)::out) is semidet. - % Given a non-variable type, return its type-id and argument types. - % + % Given a non-variable type, return its type-id and argument types. + % :- pred type_to_ctor_and_args((type)::in, type_ctor::out, list(type)::out) - is semidet. - - % type_ctor_is_higher_order(TypeCtor, PredOrFunc) succeeds iff - % TypeCtor is a higher-order predicate or function type. - % + is semidet. + + % type_ctor_is_higher_order(TypeCtor, PredOrFunc) succeeds iff + % TypeCtor is a higher-order predicate or function type. + % :- pred type_ctor_is_higher_order(type_ctor::in, purity::out, pred_or_func::out, - lambda_eval_method::out) is semidet. + lambda_eval_method::out) is semidet. - % type_ctor_is_tuple(TypeCtor) succeeds iff TypeCtor is a tuple type. - % + % type_ctor_is_tuple(TypeCtor) succeeds iff TypeCtor is a tuple type. + % :- pred type_ctor_is_tuple(type_ctor::in) is semidet. - % type_ctor_is_variable(TypeCtor) succeeds iff TypeCtor is a variable. - % + % type_ctor_is_variable(TypeCtor) succeeds iff TypeCtor is a variable. + % :- pred type_ctor_is_variable(type_ctor::in) is semidet. - % Convert a list of types to a list of vars. Fail if any of them are - % not variables. - % + % Convert a list of types to a list of vars. Fail if any of them are + % not variables. + % :- pred prog_type.type_list_to_var_list(list(type)::in, list(tvar)::out) - is semidet. + is semidet. - % Convert a list of vars into a list of variable types. - % + % Convert a list of vars into a list of variable types. + % :- pred prog_type.var_list_to_type_list(tvar_kind_map::in, list(tvar)::in, - list(type)::out) is det. + list(type)::out) is det. - % Return a list of the type variables of a type, in order of their - % first occurrence in a depth-first, left-right traversal. - % + % Return a list of the type variables of a type, in order of their + % first occurrence in a depth-first, left-right traversal. + % :- pred prog_type.vars((type)::in, list(tvar)::out) is det. - % Return a list of the type variables of a list of types, in order - % of their first occurrence in a depth-first, left-right traversal. - % + % Return a list of the type variables of a list of types, in order + % of their first occurrence in a depth-first, left-right traversal. + % :- pred prog_type.vars_list(list(type)::in, list(tvar)::out) is det. - % Nondeterministically return the variables in a type. - % + % Nondeterministically return the variables in a type. + % :- pred type_contains_var((type)::in, tvar::out) is nondet. - % Nondeterministically return the variables in a list of types. - % + % Nondeterministically return the variables in a list of types. + % :- pred type_list_contains_var(list(type)::in, tvar::out) is nondet. - % Given a type_ctor and a list of argument types, - % construct a type. - % + % Given a type_ctor and a list of argument types, + % construct a type. + % :- pred construct_type(type_ctor::in, list(type)::in, (type)::out) is det. :- pred construct_higher_order_type(purity::in, pred_or_func::in, - lambda_eval_method::in, list(type)::in, (type)::out) is det. + lambda_eval_method::in, list(type)::in, (type)::out) is det. :- pred construct_higher_order_pred_type(purity::in, lambda_eval_method::in, - list(type)::in, (type)::out) is det. + list(type)::in, (type)::out) is det. :- pred construct_higher_order_func_type(purity::in, lambda_eval_method::in, - list(type)::in, (type)::in, (type)::out) is det. - - % Make error messages more readable by removing "builtin." - % qualifiers. - % + list(type)::in, (type)::in, (type)::out) is det. + + % Make error messages more readable by removing "builtin." + % qualifiers. + % :- pred strip_builtin_qualifiers_from_type((type)::in, (type)::out) is det. :- pred strip_builtin_qualifiers_from_type_list(list(type)::in, - list(type)::out) is det. + list(type)::out) is det. %-----------------------------------------------------------------------------% % @@ -169,39 +171,39 @@ :- pred apply_rec_subst_to_type(tsubst::in, (type)::in, (type)::out) is det. :- pred apply_rec_subst_to_type_list(tsubst::in, list(type)::in, - list(type)::out) is det. + list(type)::out) is det. :- pred apply_rec_subst_to_tvar(tvar_kind_map::in, tsubst::in, - tvar::in, (type)::out) is det. + tvar::in, (type)::out) is det. :- pred apply_rec_subst_to_tvar_list(tvar_kind_map::in, tsubst::in, - list(tvar)::in, list(type)::out) is det. + list(tvar)::in, list(type)::out) is det. :- pred apply_subst_to_type(tsubst::in, (type)::in, (type)::out) is det. :- pred apply_subst_to_type_list(tsubst::in, list(type)::in, list(type)::out) - is det. + is det. :- pred apply_subst_to_tvar(tvar_kind_map::in, tsubst::in, - tvar::in, (type)::out) is det. + tvar::in, (type)::out) is det. :- pred apply_subst_to_tvar_list(tvar_kind_map::in, tsubst::in, - list(tvar)::in, list(type)::out) is det. + list(tvar)::in, list(type)::out) is det. :- pred apply_variable_renaming_to_type(tvar_renaming::in, (type)::in, - (type)::out) is det. + (type)::out) is det. :- pred apply_variable_renaming_to_type_list(tvar_renaming::in, list(type)::in, - list(type)::out) is det. + list(type)::out) is det. :- pred apply_variable_renaming_to_tvar(tvar_renaming::in, tvar::in, tvar::out) - is det. + is det. :- pred apply_variable_renaming_to_tvar_list(tvar_renaming::in, list(tvar)::in, - list(tvar)::out) is det. + list(tvar)::out) is det. :- pred apply_variable_renaming_to_tvar_kind_map(tvar_renaming::in, - tvar_kind_map::in, tvar_kind_map::out) is det. + tvar_kind_map::in, tvar_kind_map::out) is det. %-----------------------------------------------------------------------------% % @@ -209,46 +211,46 @@ % :- pred apply_rec_subst_to_prog_constraints(tsubst::in, prog_constraints::in, - prog_constraints::out) is det. + prog_constraints::out) is det. :- pred apply_rec_subst_to_prog_constraint_list(tsubst::in, - list(prog_constraint)::in, list(prog_constraint)::out) is det. + list(prog_constraint)::in, list(prog_constraint)::out) is det. :- pred apply_rec_subst_to_prog_constraint(tsubst::in, prog_constraint::in, - prog_constraint::out) is det. + prog_constraint::out) is det. :- pred apply_subst_to_prog_constraints(tsubst::in, prog_constraints::in, - prog_constraints::out) is det. + prog_constraints::out) is det. :- pred apply_subst_to_prog_constraint_list(tsubst::in, - list(prog_constraint)::in, list(prog_constraint)::out) is det. + list(prog_constraint)::in, list(prog_constraint)::out) is det. :- pred apply_subst_to_prog_constraint(tsubst::in, prog_constraint::in, - prog_constraint::out) is det. + prog_constraint::out) is det. :- pred apply_variable_renaming_to_prog_constraints(tvar_renaming::in, - prog_constraints::in, prog_constraints::out) is det. + prog_constraints::in, prog_constraints::out) is det. :- pred apply_variable_renaming_to_prog_constraint_list(tvar_renaming::in, - list(prog_constraint)::in, list(prog_constraint)::out) is det. + list(prog_constraint)::in, list(prog_constraint)::out) is det. :- pred apply_variable_renaming_to_prog_constraint(tvar_renaming::in, - prog_constraint::in, prog_constraint::out) is det. + prog_constraint::in, prog_constraint::out) is det. - % constraint_list_get_tvars(Constraints, TVars): - % return the list of type variables contained in a - % list of constraints - % + % constraint_list_get_tvars(Constraints, TVars): + % return the list of type variables contained in a + % list of constraints + % :- pred constraint_list_get_tvars(list(prog_constraint)::in, list(tvar)::out) - is det. - - % constraint_get_tvars(Constraint, TVars): - % return the list of type variables contained in a constraint. - % + is det. + + % constraint_get_tvars(Constraint, TVars): + % return the list of type variables contained in a constraint. + % :- pred constraint_get_tvars(prog_constraint::in, list(tvar)::out) is det. :- pred get_unconstrained_tvars(list(tvar)::in, list(prog_constraint)::in, - list(tvar)::out) is det. + list(tvar)::out) is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -267,150 +269,150 @@ %-----------------------------------------------------------------------------% type_is_var(Type) :- - strip_kind_annotation(Type) = variable(_, _). + strip_kind_annotation(Type) = variable(_, _). type_is_nonvar(Type) :- - \+ type_is_var(Type). + \+ type_is_var(Type). type_is_higher_order(Type) :- - strip_kind_annotation(Type) = higher_order(_, _, _, _). + strip_kind_annotation(Type) = higher_order(_, _, _, _). type_is_higher_order(Type0, Purity, PredOrFunc, EvalMethod, PredArgTypes) :- - Type = strip_kind_annotation(Type0), - Type = higher_order(ArgTypes, MaybeRetType, Purity, EvalMethod), - ( - MaybeRetType = yes(RetType), - PredOrFunc = function, - PredArgTypes = list.append(ArgTypes, [RetType]) - ; - MaybeRetType = no, - PredOrFunc = predicate, - PredArgTypes = ArgTypes - ). + Type = strip_kind_annotation(Type0), + Type = higher_order(ArgTypes, MaybeRetType, Purity, EvalMethod), + ( + MaybeRetType = yes(RetType), + PredOrFunc = function, + PredArgTypes = list.append(ArgTypes, [RetType]) + ; + MaybeRetType = no, + PredOrFunc = predicate, + PredArgTypes = ArgTypes + ). type_is_tuple(Type, ArgTypes) :- - strip_kind_annotation(Type) = tuple(ArgTypes, _). + strip_kind_annotation(Type) = tuple(ArgTypes, _). strip_kind_annotation(Type0) = Type :- - ( Type0 = kinded(Type1, _) -> - Type = strip_kind_annotation(Type1) - ; - Type = Type0 - ). + ( Type0 = kinded(Type1, _) -> + Type = strip_kind_annotation(Type1) + ; + Type = Type0 + ). %-----------------------------------------------------------------------------% type_is_ground(Type) :- - \+ type_contains_var(Type, _). + \+ type_contains_var(Type, _). type_is_nonground(Type) :- - type_contains_var(Type, _). + type_contains_var(Type, _). type_is_ground(Type, TSubst) :- - \+ type_is_nonground(Type, TSubst). + \+ type_is_nonground(Type, TSubst). type_is_nonground(Type, TSubst) :- - type_contains_var(Type, TVar), - ( map.search(TSubst, TVar, Binding) -> - type_is_nonground(Binding, TSubst) - ; - true - ). + type_contains_var(Type, TVar), + ( map.search(TSubst, TVar, Binding) -> + type_is_nonground(Binding, TSubst) + ; + true + ). type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs) :- - ( - type_is_higher_order(Type, _Purity, PredOrFunc, _, - TypeArgs0) - -> - TypeArgs = TypeArgs0, - PredOrFuncStr = prog_out.pred_or_func_to_str(PredOrFunc), - TypeCtor = unqualified(PredOrFuncStr) - 0 - ; - type_is_tuple(Type, TypeArgs1) - -> - TypeArgs = TypeArgs1, - % XXX why tuple/0 and not {}/N ? - TypeCtor = unqualified("tuple") - 0 - ; - fail - ). + ( + type_is_higher_order(Type, _Purity, PredOrFunc, _, + TypeArgs0) + -> + TypeArgs = TypeArgs0, + PredOrFuncStr = prog_out.pred_or_func_to_str(PredOrFunc), + TypeCtor = unqualified(PredOrFuncStr) - 0 + ; + type_is_tuple(Type, TypeArgs1) + -> + TypeArgs = TypeArgs1, + % XXX why tuple/0 and not {}/N ? + TypeCtor = unqualified("tuple") - 0 + ; + fail + ). type_to_ctor_and_args(defined(SymName, Args, _), SymName - Arity, Args) :- - Arity = list.length(Args). + Arity = list.length(Args). type_to_ctor_and_args(builtin(BuiltinType), SymName - 0, []) :- - builtin_type_to_string(BuiltinType, Name), - SymName = unqualified(Name). + builtin_type_to_string(BuiltinType, Name), + SymName = unqualified(Name). type_to_ctor_and_args(higher_order(Args0, MaybeRet, Purity, EvalMethod), - SymName - Arity, Args) :- - Arity = list.length(Args0), - ( - MaybeRet = yes(Ret), - PorFStr = "func", - Args = list.append(Args0, [Ret]) - ; - MaybeRet = no, - PorFStr = "pred", - Args = Args0 - ), - SymName0 = unqualified(PorFStr), - ( - EvalMethod = (aditi_bottom_up), - insert_module_qualifier("aditi_bottom_up", SymName0, SymName1) - ; - EvalMethod = normal, - SymName1 = SymName0 - ), - ( - Purity = (pure), - SymName = SymName1 - ; - Purity = (semipure), - insert_module_qualifier("semipure", SymName1, SymName) - ; - Purity = (impure), - insert_module_qualifier("impure", SymName1, SymName) - ). + SymName - Arity, Args) :- + Arity = list.length(Args0), + ( + MaybeRet = yes(Ret), + PorFStr = "func", + Args = list.append(Args0, [Ret]) + ; + MaybeRet = no, + PorFStr = "pred", + Args = Args0 + ), + SymName0 = unqualified(PorFStr), + ( + EvalMethod = (aditi_bottom_up), + insert_module_qualifier("aditi_bottom_up", SymName0, SymName1) + ; + EvalMethod = normal, + SymName1 = SymName0 + ), + ( + Purity = (pure), + SymName = SymName1 + ; + Purity = (semipure), + insert_module_qualifier("semipure", SymName1, SymName) + ; + Purity = (impure), + insert_module_qualifier("impure", SymName1, SymName) + ). type_to_ctor_and_args(tuple(Args, _), unqualified("{}") - Arity, Args) :- - Arity = list.length(Args). + Arity = list.length(Args). type_to_ctor_and_args(apply_n(_, _, _), _, _) :- - sorry(this_file, "apply/N types"). + sorry(this_file, "apply/N types"). type_to_ctor_and_args(kinded(Type, _), TypeCtor, Args) :- - type_to_ctor_and_args(Type, TypeCtor, Args). + type_to_ctor_and_args(Type, TypeCtor, Args). type_ctor_is_higher_order(SymName - _Arity, Purity, PredOrFunc, EvalMethod) :- - get_purity_and_eval_method(SymName, Purity, EvalMethod, PorFStr), - ( - PorFStr = "pred", - PredOrFunc = predicate - ; - PorFStr = "func", - PredOrFunc = function - ). + get_purity_and_eval_method(SymName, Purity, EvalMethod, PorFStr), + ( + PorFStr = "pred", + PredOrFunc = predicate + ; + PorFStr = "func", + PredOrFunc = function + ). :- pred get_purity_and_eval_method(sym_name::in, purity::out, - lambda_eval_method::out, string::out) is semidet. + lambda_eval_method::out, string::out) is semidet. get_purity_and_eval_method(SymName, Purity, EvalMethod, PorFStr) :- - ( - SymName = qualified(unqualified(Qualifier), PorFStr), - ( - Qualifier = "aditi_bottom_up", - EvalMethod = (aditi_bottom_up), - Purity = (pure) - ; - Qualifier = "impure", - Purity = (impure), - EvalMethod = normal - ; - Qualifier = "semipure", - Purity = (semipure), - EvalMethod = normal - ) - ; - SymName = unqualified(PorFStr), - EvalMethod = normal, - Purity = (pure) - ). + ( + SymName = qualified(unqualified(Qualifier), PorFStr), + ( + Qualifier = "aditi_bottom_up", + EvalMethod = (aditi_bottom_up), + Purity = (pure) + ; + Qualifier = "impure", + Purity = (impure), + EvalMethod = normal + ; + Qualifier = "semipure", + Purity = (semipure), + EvalMethod = normal + ) + ; + SymName = unqualified(PorFStr), + EvalMethod = normal, + Purity = (pure) + ). type_ctor_is_tuple(unqualified("{}") - _). @@ -418,416 +420,411 @@ type_ctor_is_variable(unqualified("") - _). prog_type.type_list_to_var_list([], []). prog_type.type_list_to_var_list([Type | Types], [Var | Vars]) :- - Type = variable(Var, _), - prog_type.type_list_to_var_list(Types, Vars). + Type = variable(Var, _), + prog_type.type_list_to_var_list(Types, Vars). prog_type.var_list_to_type_list(_, [], []). prog_type.var_list_to_type_list(KindMap, [Var | Vars], [Type | Types]) :- - get_tvar_kind(KindMap, Var, Kind), - Type = variable(Var, Kind), - prog_type.var_list_to_type_list(KindMap, Vars, Types). + get_tvar_kind(KindMap, Var, Kind), + Type = variable(Var, Kind), + prog_type.var_list_to_type_list(KindMap, Vars, Types). prog_type.vars(Type, TVars) :- - prog_type.vars_2(Type, [], RevTVars), - list.reverse(RevTVars, TVarsDups), - list.remove_dups(TVarsDups, TVars). + prog_type.vars_2(Type, [], RevTVars), + list.reverse(RevTVars, TVarsDups), + list.remove_dups(TVarsDups, TVars). :- pred prog_type.vars_2((type)::in, list(tvar)::in, list(tvar)::out) is det. prog_type.vars_2(variable(Var, _), Vs, [Var | Vs]). prog_type.vars_2(defined(_, Args, _), !V) :- - prog_type.vars_list_2(Args, !V). + prog_type.vars_list_2(Args, !V). prog_type.vars_2(builtin(_), !V). prog_type.vars_2(higher_order(Args, MaybeRet, _, _), !V) :- - prog_type.vars_list_2(Args, !V), - ( - MaybeRet = yes(Ret), - prog_type.vars_2(Ret, !V) - ; - MaybeRet = no - ). + prog_type.vars_list_2(Args, !V), + ( + MaybeRet = yes(Ret), + prog_type.vars_2(Ret, !V) + ; + MaybeRet = no + ). prog_type.vars_2(tuple(Args, _), !V) :- - prog_type.vars_list_2(Args, !V). + prog_type.vars_list_2(Args, !V). prog_type.vars_2(apply_n(Var, Args, _), !V) :- - !:V = [Var | !.V], - prog_type.vars_list_2(Args, !V). + !:V = [Var | !.V], + prog_type.vars_list_2(Args, !V). prog_type.vars_2(kinded(Type, _), !V) :- - prog_type.vars_2(Type, !V). + prog_type.vars_2(Type, !V). prog_type.vars_list(Types, TVars) :- - prog_type.vars_list_2(Types, [], RevTVars), - list.reverse(RevTVars, TVarsDups), - list.remove_dups(TVarsDups, TVars). + prog_type.vars_list_2(Types, [], RevTVars), + list.reverse(RevTVars, TVarsDups), + list.remove_dups(TVarsDups, TVars). :- pred prog_type.vars_list_2(list(type)::in, list(tvar)::in, list(tvar)::out) - is det. + is det. prog_type.vars_list_2([], !V). prog_type.vars_list_2([Type | Types], !V) :- - prog_type.vars_2(Type, !V), - prog_type.vars_list_2(Types, !V). + prog_type.vars_2(Type, !V), + prog_type.vars_list_2(Types, !V). type_contains_var(variable(Var, _), Var). type_contains_var(defined(_, Args, _), Var) :- - type_list_contains_var(Args, Var). + type_list_contains_var(Args, Var). type_contains_var(higher_order(Args, _, _, _), Var) :- - type_list_contains_var(Args, Var). + type_list_contains_var(Args, Var). type_contains_var(higher_order(_, yes(Ret), _, _), Var) :- - type_contains_var(Ret, Var). + type_contains_var(Ret, Var). type_contains_var(tuple(Args, _), Var) :- - type_list_contains_var(Args, Var). + type_list_contains_var(Args, Var). type_contains_var(apply_n(Var, _, _), Var). type_contains_var(apply_n(_, Args, _), Var) :- - type_list_contains_var(Args, Var). + type_list_contains_var(Args, Var). type_contains_var(kinded(Type, _), Var) :- - type_contains_var(Type, Var). + type_contains_var(Type, Var). type_list_contains_var([Type | _], Var) :- - type_contains_var(Type, Var). + type_contains_var(Type, Var). type_list_contains_var([_ | Types], Var) :- - type_list_contains_var(Types, Var). + type_list_contains_var(Types, Var). construct_type(TypeCtor, Args, Type) :- - ( - TypeCtor = unqualified(Name) - 0, - builtin_type_to_string(BuiltinType, Name) - -> - Type = builtin(BuiltinType) - ; - type_ctor_is_higher_order(TypeCtor, Purity, PredOrFunc, - EvalMethod) - -> - construct_higher_order_type(Purity, PredOrFunc, EvalMethod, - Args, Type) - ; - type_ctor_is_tuple(TypeCtor) - -> - % XXX kind inference: - % we assume the kind is star. - Type = tuple(Args, star) - ; - TypeCtor = SymName - _, - % XXX kind inference: - % we assume the kind is star. - Type = defined(SymName, Args, star) - ). + ( + TypeCtor = unqualified(Name) - 0, + builtin_type_to_string(BuiltinType, Name) + -> + Type = builtin(BuiltinType) + ; + type_ctor_is_higher_order(TypeCtor, Purity, PredOrFunc, EvalMethod) + -> + construct_higher_order_type(Purity, PredOrFunc, EvalMethod, Args, Type) + ; + type_ctor_is_tuple(TypeCtor) + -> + % XXX kind inference: we assume the kind is star. + Type = tuple(Args, star) + ; + TypeCtor = SymName - _, + % XXX kind inference: we assume the kind is star. + Type = defined(SymName, Args, star) + ). construct_higher_order_type(Purity, PredOrFunc, EvalMethod, ArgTypes, Type) :- - ( - PredOrFunc = predicate, - construct_higher_order_pred_type(Purity, EvalMethod, ArgTypes, - Type) - ; - PredOrFunc = function, - pred_args_to_func_args(ArgTypes, FuncArgTypes, FuncRetType), - construct_higher_order_func_type(Purity, EvalMethod, - FuncArgTypes, FuncRetType, Type) - ). + ( + PredOrFunc = predicate, + construct_higher_order_pred_type(Purity, EvalMethod, ArgTypes, Type) + ; + PredOrFunc = function, + pred_args_to_func_args(ArgTypes, FuncArgTypes, FuncRetType), + construct_higher_order_func_type(Purity, EvalMethod, FuncArgTypes, + FuncRetType, Type) + ). construct_higher_order_pred_type(Purity, EvalMethod, ArgTypes, Type) :- - Type = higher_order(ArgTypes, no, Purity, EvalMethod). + Type = higher_order(ArgTypes, no, Purity, EvalMethod). construct_higher_order_func_type(Purity, EvalMethod, ArgTypes, RetType, Type) :- - Type = higher_order(ArgTypes, yes(RetType), Purity, EvalMethod). + Type = higher_order(ArgTypes, yes(RetType), Purity, EvalMethod). strip_builtin_qualifiers_from_type(variable(Var, Kind), variable(Var, Kind)). strip_builtin_qualifiers_from_type(defined(Name0, Args0, Kind), - defined(Name, Args, Kind)) :- - ( - Name0 = qualified(Module, Name1), - mercury_public_builtin_module(Module) - -> - Name = unqualified(Name1) - ; - Name = Name0 - ), - strip_builtin_qualifiers_from_type_list(Args0, Args). + defined(Name, Args, Kind)) :- + ( + Name0 = qualified(Module, Name1), + mercury_public_builtin_module(Module) + -> + Name = unqualified(Name1) + ; + Name = Name0 + ), + strip_builtin_qualifiers_from_type_list(Args0, Args). strip_builtin_qualifiers_from_type(builtin(BuiltinType), builtin(BuiltinType)). strip_builtin_qualifiers_from_type( - higher_order(Args0, MaybeRet0, Purity, EvalMethod), - higher_order(Args, MaybeRet, Purity, EvalMethod)) :- - strip_builtin_qualifiers_from_type_list(Args0, Args), - ( - MaybeRet0 = yes(Ret0), - strip_builtin_qualifiers_from_type(Ret0, Ret), - MaybeRet = yes(Ret) - ; - MaybeRet0 = no, - MaybeRet = no - ). + higher_order(Args0, MaybeRet0, Purity, EvalMethod), + higher_order(Args, MaybeRet, Purity, EvalMethod)) :- + strip_builtin_qualifiers_from_type_list(Args0, Args), + ( + MaybeRet0 = yes(Ret0), + strip_builtin_qualifiers_from_type(Ret0, Ret), + MaybeRet = yes(Ret) + ; + MaybeRet0 = no, + MaybeRet = no + ). strip_builtin_qualifiers_from_type(tuple(Args0, Kind), tuple(Args, Kind)) :- - strip_builtin_qualifiers_from_type_list(Args0, Args). + strip_builtin_qualifiers_from_type_list(Args0, Args). strip_builtin_qualifiers_from_type(apply_n(Var, Args0, Kind), - apply_n(Var, Args, Kind)) :- - strip_builtin_qualifiers_from_type_list(Args0, Args). + apply_n(Var, Args, Kind)) :- + strip_builtin_qualifiers_from_type_list(Args0, Args). strip_builtin_qualifiers_from_type(kinded(Type0, Kind), kinded(Type, Kind)) :- - strip_builtin_qualifiers_from_type(Type0, Type). + strip_builtin_qualifiers_from_type(Type0, Type). strip_builtin_qualifiers_from_type_list(Types0, Types) :- - list__map(strip_builtin_qualifiers_from_type, Types0, Types). + list__map(strip_builtin_qualifiers_from_type, Types0, Types). %-----------------------------------------------------------------------------% apply_rec_subst_to_type(Subst, Type0 @ variable(TVar, Kind), Type) :- - ( map__search(Subst, TVar, Type1) -> - ensure_type_has_kind(Kind, Type1, Type2), - apply_rec_subst_to_type(Subst, Type2, Type) - ; - Type = Type0 - ). + ( map__search(Subst, TVar, Type1) -> + ensure_type_has_kind(Kind, Type1, Type2), + apply_rec_subst_to_type(Subst, Type2, Type) + ; + Type = Type0 + ). apply_rec_subst_to_type(Subst, defined(Name, Args0, Kind), - defined(Name, Args, Kind)) :- - apply_rec_subst_to_type_list(Subst, Args0, Args). + defined(Name, Args, Kind)) :- + apply_rec_subst_to_type_list(Subst, Args0, Args). apply_rec_subst_to_type(_Subst, Type @ builtin(_), Type). apply_rec_subst_to_type(Subst, - higher_order(Args0, MaybeReturn0, Purity, EvalMethod), - higher_order(Args, MaybeReturn, Purity, EvalMethod)) :- - apply_rec_subst_to_type_list(Subst, Args0, Args), - ( - MaybeReturn0 = yes(Return0), - apply_rec_subst_to_type(Subst, Return0, Return), - MaybeReturn = yes(Return) - ; - MaybeReturn0 = no, - MaybeReturn = no - ). + higher_order(Args0, MaybeReturn0, Purity, EvalMethod), + higher_order(Args, MaybeReturn, Purity, EvalMethod)) :- + apply_rec_subst_to_type_list(Subst, Args0, Args), + ( + MaybeReturn0 = yes(Return0), + apply_rec_subst_to_type(Subst, Return0, Return), + MaybeReturn = yes(Return) + ; + MaybeReturn0 = no, + MaybeReturn = no + ). apply_rec_subst_to_type(Subst, tuple(Args0, Kind), tuple(Args, Kind)) :- - apply_rec_subst_to_type_list(Subst, Args0, Args). + apply_rec_subst_to_type_list(Subst, Args0, Args). apply_rec_subst_to_type(Subst, apply_n(TVar, Args0, Kind), Type) :- - apply_rec_subst_to_type_list(Subst, Args0, Args), - ( map__search(Subst, TVar, AppliedType0) -> - apply_rec_subst_to_type(Subst, AppliedType0, AppliedType), - apply_type_args(AppliedType, Args, Type) - ; - Type = apply_n(TVar, Args, Kind) - ). + apply_rec_subst_to_type_list(Subst, Args0, Args), + ( map__search(Subst, TVar, AppliedType0) -> + apply_rec_subst_to_type(Subst, AppliedType0, AppliedType), + apply_type_args(AppliedType, Args, Type) + ; + Type = apply_n(TVar, Args, Kind) + ). apply_rec_subst_to_type(Subst, kinded(Type0, Kind), kinded(Type, Kind)) :- - apply_rec_subst_to_type(Subst, Type0, Type). + apply_rec_subst_to_type(Subst, Type0, Type). apply_rec_subst_to_type_list(Subst, Types0, Types) :- - list__map(apply_rec_subst_to_type(Subst), Types0, Types). + list__map(apply_rec_subst_to_type(Subst), Types0, Types). apply_rec_subst_to_tvar(KindMap, Subst, TVar, Type) :- - ( map__search(Subst, TVar, Type0) -> - apply_rec_subst_to_type(Subst, Type0, Type) - ; - get_tvar_kind(KindMap, TVar, Kind), - Type = variable(TVar, Kind) - ). + ( map__search(Subst, TVar, Type0) -> + apply_rec_subst_to_type(Subst, Type0, Type) + ; + get_tvar_kind(KindMap, TVar, Kind), + Type = variable(TVar, Kind) + ). apply_rec_subst_to_tvar_list(KindMap, Subst, TVars, Types) :- - list__map(apply_rec_subst_to_tvar(KindMap, Subst), TVars, Types). + list__map(apply_rec_subst_to_tvar(KindMap, Subst), TVars, Types). apply_subst_to_type(Subst, Type0 @ variable(TVar, Kind), Type) :- - ( map__search(Subst, TVar, Type1) -> - ensure_type_has_kind(Kind, Type1, Type) - ; - Type = Type0 - ). + ( map__search(Subst, TVar, Type1) -> + ensure_type_has_kind(Kind, Type1, Type) + ; + Type = Type0 + ). apply_subst_to_type(Subst, defined(Name, Args0, Kind), - defined(Name, Args, Kind)) :- - apply_subst_to_type_list(Subst, Args0, Args). + defined(Name, Args, Kind)) :- + apply_subst_to_type_list(Subst, Args0, Args). apply_subst_to_type(_Subst, Type @ builtin(_), Type). apply_subst_to_type(Subst, - higher_order(Args0, MaybeReturn0, Purity, EvalMethod), - higher_order(Args, MaybeReturn, Purity, EvalMethod)) :- - apply_subst_to_type_list(Subst, Args0, Args), - ( - MaybeReturn0 = yes(Return0), - apply_subst_to_type(Subst, Return0, Return), - MaybeReturn = yes(Return) - ; - MaybeReturn0 = no, - MaybeReturn = no - ). + higher_order(Args0, MaybeReturn0, Purity, EvalMethod), + higher_order(Args, MaybeReturn, Purity, EvalMethod)) :- + apply_subst_to_type_list(Subst, Args0, Args), + ( + MaybeReturn0 = yes(Return0), + apply_subst_to_type(Subst, Return0, Return), + MaybeReturn = yes(Return) + ; + MaybeReturn0 = no, + MaybeReturn = no + ). apply_subst_to_type(Subst, tuple(Args0, Kind), tuple(Args, Kind)) :- - apply_subst_to_type_list(Subst, Args0, Args). + apply_subst_to_type_list(Subst, Args0, Args). apply_subst_to_type(Subst, apply_n(TVar, Args0, Kind), Type) :- - apply_subst_to_type_list(Subst, Args0, Args), - ( map__search(Subst, TVar, AppliedType) -> - apply_type_args(AppliedType, Args, Type) - ; - Type = apply_n(TVar, Args, Kind) - ). + apply_subst_to_type_list(Subst, Args0, Args), + ( map__search(Subst, TVar, AppliedType) -> + apply_type_args(AppliedType, Args, Type) + ; + Type = apply_n(TVar, Args, Kind) + ). apply_subst_to_type(Subst, kinded(Type0, Kind), kinded(Type, Kind)) :- - apply_subst_to_type(Subst, Type0, Type). + apply_subst_to_type(Subst, Type0, Type). apply_subst_to_type_list(Subst, Types0, Types) :- - list__map(apply_subst_to_type(Subst), Types0, Types). + list__map(apply_subst_to_type(Subst), Types0, Types). apply_subst_to_tvar(KindMap, Subst, TVar, Type) :- - ( map__search(Subst, TVar, Type0) -> - apply_subst_to_type(Subst, Type0, Type) - ; - get_tvar_kind(KindMap, TVar, Kind), - Type = variable(TVar, Kind) - ). + ( map__search(Subst, TVar, Type0) -> + apply_subst_to_type(Subst, Type0, Type) + ; + get_tvar_kind(KindMap, TVar, Kind), + Type = variable(TVar, Kind) + ). apply_subst_to_tvar_list(KindMap, Subst, TVars, Types) :- - list__map(apply_subst_to_tvar(KindMap, Subst), TVars, Types). + list__map(apply_subst_to_tvar(KindMap, Subst), TVars, Types). apply_variable_renaming_to_type(Renaming, variable(TVar0, Kind), - variable(TVar, Kind)) :- - apply_variable_renaming_to_tvar(Renaming, TVar0, TVar). + variable(TVar, Kind)) :- + apply_variable_renaming_to_tvar(Renaming, TVar0, TVar). apply_variable_renaming_to_type(Renaming, defined(Name, Args0, Kind), - defined(Name, Args, Kind)) :- - apply_variable_renaming_to_type_list(Renaming, Args0, Args). + defined(Name, Args, Kind)) :- + apply_variable_renaming_to_type_list(Renaming, Args0, Args). apply_variable_renaming_to_type(_Renaming, Type @ builtin(_), Type). apply_variable_renaming_to_type(Renaming, - higher_order(Args0, MaybeReturn0, Purity, EvalMethod), - higher_order(Args, MaybeReturn, Purity, EvalMethod)) :- - apply_variable_renaming_to_type_list(Renaming, Args0, Args), - ( - MaybeReturn0 = yes(Return0), - apply_variable_renaming_to_type(Renaming, Return0, Return), - MaybeReturn = yes(Return) - ; - MaybeReturn0 = no, - MaybeReturn = no - ). + higher_order(Args0, MaybeReturn0, Purity, EvalMethod), + higher_order(Args, MaybeReturn, Purity, EvalMethod)) :- + apply_variable_renaming_to_type_list(Renaming, Args0, Args), + ( + MaybeReturn0 = yes(Return0), + apply_variable_renaming_to_type(Renaming, Return0, Return), + MaybeReturn = yes(Return) + ; + MaybeReturn0 = no, + MaybeReturn = no + ). apply_variable_renaming_to_type(Renaming, tuple(Args0, Kind), - tuple(Args, Kind)) :- - apply_variable_renaming_to_type_list(Renaming, Args0, Args). + tuple(Args, Kind)) :- + apply_variable_renaming_to_type_list(Renaming, Args0, Args). apply_variable_renaming_to_type(Renaming, apply_n(TVar0, Args0, Kind), - apply_n(TVar, Args, Kind)) :- - apply_variable_renaming_to_type_list(Renaming, Args0, Args), - apply_variable_renaming_to_tvar(Renaming, TVar0, TVar). + apply_n(TVar, Args, Kind)) :- + apply_variable_renaming_to_type_list(Renaming, Args0, Args), + apply_variable_renaming_to_tvar(Renaming, TVar0, TVar). apply_variable_renaming_to_type(Renaming, kinded(Type0, Kind), - kinded(Type, Kind)) :- - apply_variable_renaming_to_type(Renaming, Type0, Type). + kinded(Type, Kind)) :- + apply_variable_renaming_to_type(Renaming, Type0, Type). apply_variable_renaming_to_type_list(Renaming, Types0, Types) :- - list__map(apply_variable_renaming_to_type(Renaming), Types0, Types). + list__map(apply_variable_renaming_to_type(Renaming), Types0, Types). apply_variable_renaming_to_tvar(Renaming, TVar0, TVar) :- - ( map__search(Renaming, TVar0, TVar1) -> - TVar = TVar1 - ; - TVar = TVar0 - ). + ( map__search(Renaming, TVar0, TVar1) -> + TVar = TVar1 + ; + TVar = TVar0 + ). apply_variable_renaming_to_tvar_list(Renaming, TVars0, TVars) :- - list__map(apply_variable_renaming_to_tvar(Renaming), TVars0, TVars). + list__map(apply_variable_renaming_to_tvar(Renaming), TVars0, TVars). apply_variable_renaming_to_tvar_kind_map(Renaming, KindMap0, KindMap) :- - map__foldl(apply_variable_renaming_to_tvar_kind_map_2(Renaming), - KindMap0, map__init, KindMap). + map__foldl(apply_variable_renaming_to_tvar_kind_map_2(Renaming), + KindMap0, map__init, KindMap). :- pred apply_variable_renaming_to_tvar_kind_map_2(tvar_renaming::in, tvar::in, - kind::in, tvar_kind_map::in, tvar_kind_map::out) is det. + kind::in, tvar_kind_map::in, tvar_kind_map::out) is det. apply_variable_renaming_to_tvar_kind_map_2(Renaming, TVar0, Kind, !KindMap) :- - apply_variable_renaming_to_tvar(Renaming, TVar0, TVar), - svmap__det_insert(TVar, Kind, !KindMap). + apply_variable_renaming_to_tvar(Renaming, TVar0, TVar), + svmap__det_insert(TVar, Kind, !KindMap). :- pred apply_type_args((type)::in, list(type)::in, (type)::out) is det. apply_type_args(variable(TVar, Kind0), Args, apply_n(TVar, Args, Kind)) :- - apply_type_args_to_kind(Kind0, Args, Kind). + apply_type_args_to_kind(Kind0, Args, Kind). apply_type_args(defined(Name, Args0, Kind0), Args, - defined(Name, Args0 ++ Args, Kind)) :- - apply_type_args_to_kind(Kind0, Args, Kind). + defined(Name, Args0 ++ Args, Kind)) :- + apply_type_args_to_kind(Kind0, Args, Kind). apply_type_args(Type @ builtin(_), [], Type). apply_type_args(builtin(_), [_ | _], _) :- - unexpected(this_file, "applied type args to builtin"). + unexpected(this_file, "applied type args to builtin"). apply_type_args(Type @ higher_order(_, _, _, _), [], Type). apply_type_args(higher_order(_, _, _, _), [_ | _], _) :- - unexpected(this_file, "applied type args to higher_order"). + unexpected(this_file, "applied type args to higher_order"). apply_type_args(tuple(Args0, Kind0), Args, tuple(Args0 ++ Args, Kind)) :- - apply_type_args_to_kind(Kind0, Args, Kind). + apply_type_args_to_kind(Kind0, Args, Kind). apply_type_args(apply_n(TVar, Args0, Kind0), Args, - apply_n(TVar, Args0 ++ Args, Kind)) :- - apply_type_args_to_kind(Kind0, Args, Kind). + apply_n(TVar, Args0 ++ Args, Kind)) :- + apply_type_args_to_kind(Kind0, Args, Kind). apply_type_args(kinded(Type0, _), Args, Type) :- - % We drop the explicit kind annotation, since: - % - it will already have been used by kind inference, and - % - it no longer corresponds to any explicit annotation given. - apply_type_args(Type0, Args, Type). + % We drop the explicit kind annotation, since: + % - it will already have been used by kind inference, and + % - it no longer corresponds to any explicit annotation given. + apply_type_args(Type0, Args, Type). :- pred apply_type_args_to_kind(kind::in, list(type)::in, kind::out) is det. apply_type_args_to_kind(Kind, [], Kind). apply_type_args_to_kind(star, [_ | _], _) :- - unexpected(this_file, "too many args in apply_n"). + unexpected(this_file, "too many args in apply_n"). apply_type_args_to_kind(arrow(Kind0, Kind1), [ArgType | ArgTypes], Kind) :- - ( get_type_kind(ArgType) = Kind0 -> - apply_type_args_to_kind(Kind1, ArgTypes, Kind) - ; - unexpected(this_file, "kind error in apply_n") - ). + ( get_type_kind(ArgType) = Kind0 -> + apply_type_args_to_kind(Kind1, ArgTypes, Kind) + ; + unexpected(this_file, "kind error in apply_n") + ). apply_type_args_to_kind(variable(_), [_ | _], _) :- - unexpected(this_file, "unbound kind variable"). + unexpected(this_file, "unbound kind variable"). :- pred ensure_type_has_kind(kind::in, (type)::in, (type)::out) is det. ensure_type_has_kind(Kind, Type0, Type) :- - ( get_type_kind(Type0) = Kind -> - Type = Type0 - ; - unexpected(this_file, "substitution not kind preserving") - ). + ( get_type_kind(Type0) = Kind -> + Type = Type0 + ; + unexpected(this_file, "substitution not kind preserving") + ). %-----------------------------------------------------------------------------% apply_rec_subst_to_prog_constraints(Subst, Constraints0, Constraints) :- - Constraints0 = constraints(UnivCs0, ExistCs0), - apply_rec_subst_to_prog_constraint_list(Subst, UnivCs0, UnivCs), - apply_rec_subst_to_prog_constraint_list(Subst, ExistCs0, ExistCs), - Constraints = constraints(UnivCs, ExistCs). + Constraints0 = constraints(UnivCs0, ExistCs0), + apply_rec_subst_to_prog_constraint_list(Subst, UnivCs0, UnivCs), + apply_rec_subst_to_prog_constraint_list(Subst, ExistCs0, ExistCs), + Constraints = constraints(UnivCs, ExistCs). apply_rec_subst_to_prog_constraint_list(Subst, !Constraints) :- - list__map(apply_rec_subst_to_prog_constraint(Subst), !Constraints). + list__map(apply_rec_subst_to_prog_constraint(Subst), !Constraints). apply_rec_subst_to_prog_constraint(Subst, Constraint0, Constraint) :- - Constraint0 = constraint(ClassName, Types0), - apply_rec_subst_to_type_list(Subst, Types0, Types), - Constraint = constraint(ClassName, Types). + Constraint0 = constraint(ClassName, Types0), + apply_rec_subst_to_type_list(Subst, Types0, Types), + Constraint = constraint(ClassName, Types). apply_subst_to_prog_constraints(Subst, - constraints(UniversalCs0, ExistentialCs0), - constraints(UniversalCs, ExistentialCs)) :- - apply_subst_to_prog_constraint_list(Subst, UniversalCs0, UniversalCs), - apply_subst_to_prog_constraint_list(Subst, ExistentialCs0, - ExistentialCs). + constraints(UniversalCs0, ExistentialCs0), + constraints(UniversalCs, ExistentialCs)) :- + apply_subst_to_prog_constraint_list(Subst, UniversalCs0, UniversalCs), + apply_subst_to_prog_constraint_list(Subst, ExistentialCs0, + ExistentialCs). apply_subst_to_prog_constraint_list(Subst, !Constraints) :- - list__map(apply_subst_to_prog_constraint(Subst), !Constraints). + list__map(apply_subst_to_prog_constraint(Subst), !Constraints). apply_subst_to_prog_constraint(Subst, Constraint0, Constraint) :- - Constraint0 = constraint(ClassName, Types0), - apply_subst_to_type_list(Subst, Types0, Types), - Constraint = constraint(ClassName, Types). + Constraint0 = constraint(ClassName, Types0), + apply_subst_to_type_list(Subst, Types0, Types), + Constraint = constraint(ClassName, Types). apply_variable_renaming_to_prog_constraints(Renaming, Constraints0, - Constraints) :- - Constraints0 = constraints(UnivConstraints0, ExistConstraints0), - apply_variable_renaming_to_prog_constraint_list(Renaming, - UnivConstraints0, UnivConstraints), - apply_variable_renaming_to_prog_constraint_list(Renaming, - ExistConstraints0, ExistConstraints), - Constraints = constraints(UnivConstraints, ExistConstraints). + Constraints) :- + Constraints0 = constraints(UnivConstraints0, ExistConstraints0), + apply_variable_renaming_to_prog_constraint_list(Renaming, + UnivConstraints0, UnivConstraints), + apply_variable_renaming_to_prog_constraint_list(Renaming, + ExistConstraints0, ExistConstraints), + Constraints = constraints(UnivConstraints, ExistConstraints). apply_variable_renaming_to_prog_constraint_list(Renaming, !Constraints) :- - list.map(apply_variable_renaming_to_prog_constraint(Renaming), - !Constraints). + list.map(apply_variable_renaming_to_prog_constraint(Renaming), + !Constraints). apply_variable_renaming_to_prog_constraint(Renaming, !Constraint) :- - !.Constraint = constraint(ClassName, ClassArgTypes0), - apply_variable_renaming_to_type_list(Renaming, ClassArgTypes0, - ClassArgTypes), - !:Constraint = constraint(ClassName, ClassArgTypes). + !.Constraint = constraint(ClassName, ClassArgTypes0), + apply_variable_renaming_to_type_list(Renaming, + ClassArgTypes0, ClassArgTypes), + !:Constraint = constraint(ClassName, ClassArgTypes). constraint_list_get_tvars(Constraints, TVars) :- - list.map(constraint_get_tvars, Constraints, TVarsList), - list.condense(TVarsList, TVars). + list.map(constraint_get_tvars, Constraints, TVarsList), + list.condense(TVarsList, TVars). constraint_get_tvars(constraint(_Name, Args), TVars) :- - prog_type.vars_list(Args, TVars). + prog_type.vars_list(Args, TVars). get_unconstrained_tvars(Tvars, Constraints, Unconstrained) :- - constraint_list_get_tvars(Constraints, ConstrainedTvars), - list.delete_elems(Tvars, ConstrainedTvars, Unconstrained0), - list.remove_dups(Unconstrained0, Unconstrained). + constraint_list_get_tvars(Constraints, ConstrainedTvars), + list.delete_elems(Tvars, ConstrainedTvars, Unconstrained0), + list.remove_dups(Unconstrained0, Unconstrained). %-----------------------------------------------------------------------------% diff --git a/compiler/rat.m b/compiler/rat.m index 76848051b..fa4dff8a4 100644 --- a/compiler/rat.m +++ b/compiler/rat.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 1997-1998, 2003, 2005 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. @@ -12,12 +14,12 @@ % lp_rational module. % % NOTE: if you actually want a general purpose rational number type then use -% the rational module in the standard library. The stuff in this -% module is pretty heavily geared towards a few specific tasks that -% are part of the termination analysis. +% the rational module in the standard library. The stuff in this module +% is pretty heavily geared towards a few specific tasks that are part of +% the termination analysis. % % TODO: -% - overflow checking would be nice +% - overflow checking would be nice % %-----------------------------------------------------------------------------% @@ -67,12 +69,12 @@ :- func rat.zero = rat. - % Convert a rational to a string of the form: "(/)". - % + % Convert a rational to a string of the form: "(/)". + % :- func rat.to_string(rat) = string. - % Write a rat in the form: r(, ). - % + % Write a rat in the form: r(, ). + % :- pred rat.write_rat(rat::in, io::di, io::uo) is det. %-----------------------------------------------------------------------------% @@ -82,23 +84,24 @@ :- import_module exception. - % The normal form of a rat number has the following - % properties: - % - numerator and denominator have no common factors. - % - denominator is positive. - % - denominator is not zero. - % - if numerator is zero, then denominator is one. - % - % These invariants must be preserved by any rat number - % constructed using this module since the equality predicate - % on rats is simply Mercury's default unification - % predicate =/2. If the invariants were not maintained, - % we would have pathologies like r(-1,2) \= r(1,-2). - % - % The rat_norm/2 function generates rationals in this - % normal form. - % -:- type rat ---> r(int, int). + % The normal form of a rat number has the following + % properties: + % - numerator and denominator have no common factors. + % - denominator is positive. + % - denominator is not zero. + % - if numerator is zero, then denominator is one. + % + % These invariants must be preserved by any rat number + % constructed using this module since the equality predicate + % on rats is simply Mercury's default unification + % predicate =/2. If the invariants were not maintained, + % we would have pathologies like r(-1,2) \= r(1,-2). + % + % The rat_norm/2 function generates rationals in this + % normal form. + % +:- type rat + ---> r(int, int). '<'(X, Y) :- cmp(X, Y) = (<). @@ -121,29 +124,30 @@ rat.zero = r(0, 1). '-'(r(Num, Den)) = r(-Num, Den). r(An, Ad) + r(Bn, Bd) = rat_norm(Numer, M) :- - M = lcm(Ad, Bd), - CA = M // Ad, - CB = M // Bd, - Numer = An * CA + Bn * CB. + M = lcm(Ad, Bd), + CA = M // Ad, + CB = M // Bd, + Numer = An * CA + Bn * CB. X - Y = X + (-Y). - % XXX: need we call rat_norm here? + % XXX: need we call rat_norm here? r(An, Ad) * r(Bn, Bd) = rat_norm(Numer, Denom) :- - G1 = gcd(An, Bd), - G2 = gcd(Ad, Bn), - Numer = (An // G1) * (Bn // G2), - Denom = (Ad // G2) * (Bd // G1). + G1 = gcd(An, Bd), + G2 = gcd(Ad, Bn), + Numer = (An // G1) * (Bn // G2), + Denom = (Ad // G2) * (Bd // G1). X / Y = X * rat.reciprocal(Y). :- func rat.reciprocal(rat) = rat. reciprocal(r(Num, Den)) = - ( if Num = 0 - then throw("rat.reciprocal/1: division by zero") - else r(signum(Num) * Den, int.abs(Num)) - ). + ( Num = 0 -> + throw("rat.reciprocal/1: division by zero") + ; + r(signum(Num) * Den, int.abs(Num)) + ). rat.numer(r(Num, _)) = Num. @@ -154,14 +158,16 @@ rat.abs(r(Num, Den)) = r(int.abs(Num), Den). :- func rat_norm(int, int) = rat. rat_norm(Num, Den) = Rat :- - ( Den = 0 -> throw("rat.rat_norm: division by zero") - ; Num = 0 -> Rat = r(0, 1) - ; - G = gcd(Num, Den), - Num2 = Num * signum(Den), - Den2 = int.abs(Den), - Rat = r(Num2 // G, Den2 // G) - ). + ( Den = 0 -> + throw("rat.rat_norm: division by zero") + ; Num = 0 -> + Rat = r(0, 1) + ; + G = gcd(Num, Den), + Num2 = Num * signum(Den), + Den2 = int.abs(Den), + Rat = r(Num2 // G, Den2 // G) + ). :- func gcd(int, int) = int. @@ -174,25 +180,31 @@ gcd_2(A, B) = ( B = 0 -> A ; gcd_2(B, A rem B) ). :- func lcm(int, int) = int. lcm(A, B) = - ( A = 0 -> 0 - ; B = 0 -> 0 - ; int.abs((A // gcd(A, B)) * B) - ). + ( A = 0 -> + 0 + ; B = 0 -> + 0 + ; + int.abs((A // gcd(A, B)) * B) + ). :- func signum(int) = int. signum(N) = ( N = 0 -> 0 ; N < 0 -> -1 ; 1 ). - % Builtin comparison does not give a natural ordering - % on rats. + % Builtin comparison does not give a natural ordering on rats. + % :- func cmp(rat, rat) = comparison_result. cmp(X, Y) = Cmp :- - Diff = X - Y, - ( is_zero(Diff) -> Cmp = (=) - ; is_negative(Diff) -> Cmp = (<) - ; Cmp = (>) - ). + Diff = X - Y, + ( is_zero(Diff) -> + Cmp = (=) + ; is_negative(Diff) -> + Cmp = (<) + ; + Cmp = (>) + ). :- pred is_zero(rat::in) is semidet. @@ -203,24 +215,24 @@ is_zero(r(0, _)). is_negative(r(Num, _)) :- Num < 0. rat.to_string(r(Num, Denom)) = - ( Num = 0 -> - "0" - ; - "(" ++ string.int_to_string(Num) ++ - ( Denom = 1 -> - "" - ; - "/" ++ string.int_to_string(Denom) - ) - ++ ")" - ). + ( Num = 0 -> + "0" + ; + "(" ++ string.int_to_string(Num) ++ + ( Denom = 1 -> + "" + ; + "/" ++ string.int_to_string(Denom) + ) + ++ ")" + ). write_rat(r(Numerator, Denominator), !IO) :- - io.write_string("r(", !IO), - io.write_int(Numerator, !IO), - io.write_string(", ", !IO), - io.write_int(Denominator, !IO), - io.write_char(')', !IO). + io.write_string("r(", !IO), + io.write_int(Numerator, !IO), + io.write_string(", ", !IO), + io.write_int(Denominator, !IO), + io.write_char(')', !IO). %------------------------------------------------------------------------------% :- end_module libs.rat. diff --git a/compiler/source_file_map.m b/compiler/source_file_map.m index 04dddaf77..de389644b 100644 --- a/compiler/source_file_map.m +++ b/compiler/source_file_map.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 2002-2005 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. @@ -20,20 +22,21 @@ :- import_module io. :- import_module list. - % lookup_module_source_file(ModuleName, FileName, FileNameIsMapped). - % - % FileNameIsMapped is `yes' if ModuleName is in - % the Mercury.modules file. + % lookup_module_source_file(ModuleName, FileName, !IO) + % :- pred lookup_module_source_file(module_name::in, file_name::out, - io::di, io::uo) is det. + io::di, io::uo) is det. - % Return `yes' if there is a valid Mercury.modules file. + % Return `yes' if there is a valid Mercury.modules file. + % :- pred have_source_file_map(bool::out, io::di, io::uo) is det. - % Return the default fully-qualified source file name. + % Return the default fully-qualified source file name. + % :- func default_source_file(module_name) = file_name. - % Given a list of file names, produce the Mercury.modules file. + % Given a list of file names, produce the Mercury.modules file. + % :- pred write_source_file_map(list(string)::in, io::di, io::uo) is det. %-----------------------------------------------------------------------------% @@ -53,164 +56,164 @@ :- import_module string. lookup_module_source_file(ModuleName, FileName, !IO) :- - get_source_file_map(SourceFileMap, !IO), - ( map__search(SourceFileMap, ModuleName, FileName0) -> - FileName = FileName0 - ; - FileName = default_source_file(ModuleName) - ). + get_source_file_map(SourceFileMap, !IO), + ( map__search(SourceFileMap, ModuleName, FileName0) -> + FileName = FileName0 + ; + FileName = default_source_file(ModuleName) + ). default_source_file(ModuleName) = BaseFileName ++ ".m" :- - mdbcomp__prim_data__sym_name_to_string(ModuleName, ".", BaseFileName). + mdbcomp__prim_data__sym_name_to_string(ModuleName, ".", BaseFileName). have_source_file_map(HaveMap, !IO) :- - get_source_file_map(_, !IO), - globals__io_get_globals(Globals, !IO), - globals__get_source_file_map(Globals, MaybeSourceFileMap), - ( MaybeSourceFileMap = yes(Map), \+ map__is_empty(Map) -> - HaveMap = yes - ; - HaveMap = no - ). + get_source_file_map(_, !IO), + globals__io_get_globals(Globals, !IO), + globals__get_source_file_map(Globals, MaybeSourceFileMap), + ( MaybeSourceFileMap = yes(Map), \+ map__is_empty(Map) -> + HaveMap = yes + ; + HaveMap = no + ). - % Read the Mercury.modules file (if it exists) to find - % the mapping from module name to file name. + % Read the Mercury.modules file (if it exists) to find the mapping + % from module name to file name. + % :- pred get_source_file_map(source_file_map::out, io::di, io::uo) is det. get_source_file_map(SourceFileMap, !IO) :- - globals__io_get_globals(Globals0, !IO), - globals__get_source_file_map(Globals0, MaybeSourceFileMap0), - ( MaybeSourceFileMap0 = yes(SourceFileMap0) -> - SourceFileMap = SourceFileMap0 - ; - io__open_input(modules_file_name, OpenRes, !IO), - ( - OpenRes = ok(Stream), - io__set_input_stream(Stream, OldStream, !IO), - read_source_file_map([], map__init, SourceFileMap, !IO), - io__set_input_stream(OldStream, _, !IO), - io__close_input(Stream, !IO) - ; - OpenRes = error(_), - % If the file doesn't exist, then the mapping is empty. - SourceFileMap = map__init - ), - globals__io_get_globals(Globals1, !IO), - globals__set_source_file_map(yes(SourceFileMap), - Globals1, Globals2), - unsafe_promise_unique(Globals2, Globals), - globals__io_set_globals(Globals, !IO) - ). + globals__io_get_globals(Globals0, !IO), + globals__get_source_file_map(Globals0, MaybeSourceFileMap0), + ( + MaybeSourceFileMap0 = yes(SourceFileMap0), + SourceFileMap = SourceFileMap0 + ; + MaybeSourceFileMap0 = no, + io__open_input(modules_file_name, OpenRes, !IO), + ( + OpenRes = ok(Stream), + io__set_input_stream(Stream, OldStream, !IO), + read_source_file_map([], map__init, SourceFileMap, !IO), + io__set_input_stream(OldStream, _, !IO), + io__close_input(Stream, !IO) + ; + OpenRes = error(_), + % If the file doesn't exist, then the mapping is empty. + SourceFileMap = map__init + ), + globals__io_get_globals(Globals1, !IO), + globals__set_source_file_map(yes(SourceFileMap), Globals1, Globals2), + unsafe_promise_unique(Globals2, Globals), + globals__io_set_globals(Globals, !IO) + ). :- pred read_source_file_map(list(char)::in, - source_file_map::in, source_file_map::out, io::di, io::uo) is det. + source_file_map::in, source_file_map::out, io::di, io::uo) is det. read_source_file_map(ModuleChars, !Map, !IO) :- - read_until_char('\t', [], ModuleCharsResult, !IO), - ( - ModuleCharsResult = ok(RevModuleChars), - string__from_rev_char_list(RevModuleChars, ModuleStr), - string_to_sym_name(ModuleStr, ".", ModuleName), - read_until_char('\n', [], FileNameCharsResult, !IO), - ( - FileNameCharsResult = ok(FileNameChars), - string__from_rev_char_list(FileNameChars, - FileName), - map__set(!.Map, ModuleName, FileName, !:Map), - read_source_file_map(ModuleChars, !Map, !IO) - ; - FileNameCharsResult = eof, - io__set_exit_status(1, !IO), - io__write_string("mercury_compile: unexpected end " ++ - "of file in Mercury.modules file.\n", !IO) - ; - FileNameCharsResult = error(Error), - io__set_exit_status(1, !IO), - io__write_string("mercury_compile: error in " ++ - "Mercury.modules file: ", !IO), - io__write_string(io__error_message(Error), !IO), - io__nl(!IO) - ) - ; - ModuleCharsResult = eof - ; - ModuleCharsResult = error(Error), - io__set_exit_status(1, !IO), - io__write_string("mercury_compile: error in " ++ - "Mercury.modules file: ", !IO), - io__write_string(io__error_message(Error), !IO), - io__nl(!IO) - ). + read_until_char('\t', [], ModuleCharsResult, !IO), + ( + ModuleCharsResult = ok(RevModuleChars), + string__from_rev_char_list(RevModuleChars, ModuleStr), + string_to_sym_name(ModuleStr, ".", ModuleName), + read_until_char('\n', [], FileNameCharsResult, !IO), + ( + FileNameCharsResult = ok(FileNameChars), + string__from_rev_char_list(FileNameChars, FileName), + map__set(!.Map, ModuleName, FileName, !:Map), + read_source_file_map(ModuleChars, !Map, !IO) + ; + FileNameCharsResult = eof, + io__set_exit_status(1, !IO), + io__write_string("mercury_compile: unexpected end " ++ + "of file in Mercury.modules file.\n", !IO) + ; + FileNameCharsResult = error(Error), + io__set_exit_status(1, !IO), + io__write_string("mercury_compile: error in " ++ + "Mercury.modules file: ", !IO), + io__write_string(io__error_message(Error), !IO), + io__nl(!IO) + ) + ; + ModuleCharsResult = eof + ; + ModuleCharsResult = error(Error), + io__set_exit_status(1, !IO), + io__write_string("mercury_compile: error in " ++ + "Mercury.modules file: ", !IO), + io__write_string(io__error_message(Error), !IO), + io__nl(!IO) + ). :- pred read_until_char(char::in, list(char)::in, io__result(list(char))::out, - io::di, io::uo) is det. + io::di, io::uo) is det. read_until_char(EndChar, Chars0, Result, !IO) :- - io__read_char(CharRes, !IO), - ( - CharRes = ok(Char), - ( Char = EndChar -> - Result = ok(Chars0) - ; - read_until_char(EndChar, [Char | Chars0], Result, !IO) - ) - ; - CharRes = eof, - Result = ( Chars0 = [] -> eof ; ok(Chars0) ) - ; - CharRes = error(Error), - Result = error(Error) - ). + io__read_char(CharRes, !IO), + ( + CharRes = ok(Char), + ( Char = EndChar -> + Result = ok(Chars0) + ; + read_until_char(EndChar, [Char | Chars0], Result, !IO) + ) + ; + CharRes = eof, + Result = ( Chars0 = [] -> eof ; ok(Chars0) ) + ; + CharRes = error(Error), + Result = error(Error) + ). write_source_file_map(FileNames, !IO) :- - ModulesFileName = modules_file_name, - io__open_output(ModulesFileName, OpenRes, !IO), - ( - OpenRes = ok(Stream), - list__foldl(write_source_file_map_2(Stream), FileNames, !IO), - io__close_output(Stream, !IO) - ; - OpenRes = error(Error), - io__set_exit_status(1, !IO), - io__write_string("mercury_compile: error opening `", !IO), - io__write_string(ModulesFileName, !IO), - io__write_string("' for output: ", !IO), - io__write_string(io__error_message(Error), !IO) - ). + ModulesFileName = modules_file_name, + io__open_output(ModulesFileName, OpenRes, !IO), + ( + OpenRes = ok(Stream), + list__foldl(write_source_file_map_2(Stream), FileNames, !IO), + io__close_output(Stream, !IO) + ; + OpenRes = error(Error), + io__set_exit_status(1, !IO), + io__write_string("mercury_compile: error opening `", !IO), + io__write_string(ModulesFileName, !IO), + io__write_string("' for output: ", !IO), + io__write_string(io__error_message(Error), !IO) + ). :- pred write_source_file_map_2(io__output_stream::in, file_name::in, - io::di, io::uo) is det. + io::di, io::uo) is det. write_source_file_map_2(MapStream, FileName, !IO) :- - find_module_name(FileName, MaybeModuleName, !IO), - ( - MaybeModuleName = yes(ModuleName), - ( string__remove_suffix(FileName, ".m", PartialFileName0) -> - PartialFileName = PartialFileName0 - ; - PartialFileName = FileName - ), - file_name_to_module_name(dir__basename_det(PartialFileName), - DefaultModuleName), - ( - % Only include a module in the mapping if the - % name doesn't match the default. - dir__dirname(PartialFileName) = - dir__this_directory `with_type` string, - ModuleName = DefaultModuleName - -> - true - ; - io__set_output_stream(MapStream, OldStream, !IO), - prog_out__write_sym_name(ModuleName, !IO), - io__write_string("\t", !IO), - io__write_string(FileName, !IO), - io__nl(!IO), - io__set_output_stream(OldStream, _, !IO) - ) - ; - MaybeModuleName = no - ). + find_module_name(FileName, MaybeModuleName, !IO), + ( + MaybeModuleName = yes(ModuleName), + ( string__remove_suffix(FileName, ".m", PartialFileName0) -> + PartialFileName = PartialFileName0 + ; + PartialFileName = FileName + ), + file_name_to_module_name(dir__basename_det(PartialFileName), + DefaultModuleName), + ( + % Only include a module in the mapping if the name doesn't match + % the default. + dir__dirname(PartialFileName) = dir__this_directory : string, + ModuleName = DefaultModuleName + -> + true + ; + io__set_output_stream(MapStream, OldStream, !IO), + prog_out__write_sym_name(ModuleName, !IO), + io__write_string("\t", !IO), + io__write_string(FileName, !IO), + io__nl(!IO), + io__set_output_stream(OldStream, _, !IO) + ) + ; + MaybeModuleName = no + ). :- func modules_file_name = string. diff --git a/compiler/stack_layout.m b/compiler/stack_layout.m index ce0ad5f38..57b5e9a4c 100644 --- a/compiler/stack_layout.m +++ b/compiler/stack_layout.m @@ -1,4 +1,6 @@ %---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% % Copyright (C) 1997-2005 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. @@ -39,29 +41,31 @@ :- import_module list. :- import_module map. -:- pred stack_layout__generate_llds(module_info::in, - global_data::in, global_data::out, - list(comp_gen_c_data)::out, map(label, data_addr)::out) is det. + % Process all the continuation information stored in the HLDS, + % converting it into LLDS data structures. + % +:- pred generate_llds(module_info::in, global_data::in, global_data::out, + list(comp_gen_c_data)::out, map(label, data_addr)::out) is det. -:- pred stack_layout__construct_closure_layout(proc_label::in, int::in, - closure_layout_info::in, proc_label::in, module_name::in, - string::in, int::in, pred_origin::in, string::in, static_cell_info::in, - static_cell_info::out, assoc_list(rval, llds_type)::out, - comp_gen_c_data::out) is det. +:- pred construct_closure_layout(proc_label::in, int::in, + closure_layout_info::in, proc_label::in, module_name::in, + string::in, int::in, pred_origin::in, string::in, static_cell_info::in, + static_cell_info::out, assoc_list(rval, llds_type)::out, + comp_gen_c_data::out) is det. - % Construct a representation of a variable location as a 32-bit - % integer. -:- pred stack_layout__represent_locn_as_int(layout_locn::in, int::out) is det. + % Construct a representation of a variable location as a 32-bit + % integer. + % +:- pred represent_locn_as_int(layout_locn::in, int::out) is det. - % Construct a representation of the interface determinism of a - % procedure. -:- pred stack_layout__represent_determinism_rval(determinism::in, - rval::out) is det. + % Construct a representation of the interface determinism of a procedure. + % +:- pred represent_determinism_rval(determinism::in, rval::out) is det. :- type stack_layout_info. -:- pred stack_layout__lookup_string_in_table(string::in, int::out, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred lookup_string_in_table(string::in, int::out, + stack_layout_info::in, stack_layout_info::out) is det. :- implementation. @@ -95,1706 +99,1650 @@ :- import_module set. :- import_module std_util. :- import_module string. +:- import_module svmap. :- import_module term. :- import_module varset. %---------------------------------------------------------------------------% - % Process all the continuation information stored in the HLDS, - % converting it into LLDS data structures. +generate_llds(ModuleInfo0, !GlobalData, Layouts, LayoutLabels) :- + global_data_get_all_proc_layouts(!.GlobalData, ProcLayoutList), + module_info_get_globals(ModuleInfo0, Globals), + globals__lookup_bool_option(Globals, agc_stack_layout, AgcLayout), + globals__lookup_bool_option(Globals, trace_stack_layout, TraceLayout), + globals__lookup_bool_option(Globals, procid_stack_layout, + ProcIdLayout), + globals__get_trace_level(Globals, TraceLevel), + globals__get_trace_suppress(Globals, TraceSuppress), + globals__have_static_code_addresses(Globals, StaticCodeAddr), + map__init(LayoutLabels0), -stack_layout__generate_llds(ModuleInfo0, !GlobalData, Layouts, LayoutLabels) :- - global_data_get_all_proc_layouts(!.GlobalData, ProcLayoutList), - module_info_get_globals(ModuleInfo0, Globals), - globals__lookup_bool_option(Globals, agc_stack_layout, AgcLayout), - globals__lookup_bool_option(Globals, trace_stack_layout, TraceLayout), - globals__lookup_bool_option(Globals, procid_stack_layout, - ProcIdLayout), - globals__get_trace_level(Globals, TraceLevel), - globals__get_trace_suppress(Globals, TraceSuppress), - globals__have_static_code_addresses(Globals, StaticCodeAddr), - map__init(LayoutLabels0), + map__init(StringMap0), + map__init(LabelTables0), + StringTable0 = string_table(StringMap0, [], 0), + global_data_get_static_cell_info(!.GlobalData, StaticCellInfo0), + counter__init(1, LabelCounter0), + LayoutInfo0 = stack_layout_info(ModuleInfo0, + AgcLayout, TraceLayout, ProcIdLayout, StaticCodeAddr, + LabelCounter0, [], [], [], LayoutLabels0, [], + StringTable0, LabelTables0, StaticCellInfo0), + lookup_string_in_table("", _, LayoutInfo0, LayoutInfo1), + lookup_string_in_table("", _, + LayoutInfo1, LayoutInfo2), + list__foldl(construct_layouts, ProcLayoutList, LayoutInfo2, LayoutInfo), + LabelsCounter = LayoutInfo ^ label_counter, + counter__allocate(NumLabels, LabelsCounter, _), + TableIoDecls = LayoutInfo ^ table_infos, + ProcLayouts = LayoutInfo ^ proc_layouts, + InternalLayouts = LayoutInfo ^ internal_layouts, + LayoutLabels = LayoutInfo ^ label_set, + ProcLayoutNames = LayoutInfo ^ proc_layout_name_list, + StringTable = LayoutInfo ^ string_table, + LabelTables = LayoutInfo ^ label_tables, + global_data_set_static_cell_info(LayoutInfo ^ static_cell_info, + !GlobalData), + StringTable = string_table(_, RevStringList, StringOffset), + list__reverse(RevStringList, StringList), + concat_string_list(StringList, StringOffset, ConcatStrings), - map__init(StringMap0), - map__init(LabelTables0), - StringTable0 = string_table(StringMap0, [], 0), - global_data_get_static_cell_info(!.GlobalData, StaticCellInfo0), - counter__init(1, LabelCounter0), - LayoutInfo0 = stack_layout_info(ModuleInfo0, - AgcLayout, TraceLayout, ProcIdLayout, StaticCodeAddr, - LabelCounter0, [], [], [], LayoutLabels0, [], - StringTable0, LabelTables0, StaticCellInfo0), - stack_layout__lookup_string_in_table("", _, LayoutInfo0, LayoutInfo1), - stack_layout__lookup_string_in_table("", _, - LayoutInfo1, LayoutInfo2), - list__foldl(stack_layout__construct_layouts, ProcLayoutList, - LayoutInfo2, LayoutInfo), - LabelsCounter = LayoutInfo ^ label_counter, - counter__allocate(NumLabels, LabelsCounter, _), - TableIoDecls = LayoutInfo ^ table_infos, - ProcLayouts = LayoutInfo ^ proc_layouts, - InternalLayouts = LayoutInfo ^ internal_layouts, - LayoutLabels = LayoutInfo ^ label_set, - ProcLayoutNames = LayoutInfo ^ proc_layout_name_list, - StringTable = LayoutInfo ^ string_table, - LabelTables = LayoutInfo ^ label_tables, - global_data_set_static_cell_info(LayoutInfo ^ static_cell_info, - !GlobalData), - StringTable = string_table(_, RevStringList, StringOffset), - list__reverse(RevStringList, StringList), - stack_layout__concat_string_list(StringList, StringOffset, - ConcatStrings), + list__condense([TableIoDecls, ProcLayouts, InternalLayouts], Layouts0), + ( + TraceLayout = yes, + module_info_get_name(ModuleInfo0, ModuleName), + globals__lookup_bool_option(Globals, rtti_line_numbers, LineNumbers), + ( + LineNumbers = yes, + EffLabelTables = LabelTables + ; + LineNumbers = no, + map__init(EffLabelTables) + ), + format_label_tables(EffLabelTables, SourceFileLayouts), + SuppressedEvents = encode_suppressed_events(TraceSuppress), + ModuleLayout = layout_data(module_layout_data(ModuleName, + StringOffset, ConcatStrings, ProcLayoutNames, + SourceFileLayouts, TraceLevel, SuppressedEvents, NumLabels)), + Layouts = [ModuleLayout | Layouts0] + ; + TraceLayout = no, + Layouts = Layouts0 + ). - list__condense([TableIoDecls, ProcLayouts, InternalLayouts], - Layouts0), - ( - TraceLayout = yes, - module_info_get_name(ModuleInfo0, ModuleName), - globals__lookup_bool_option(Globals, rtti_line_numbers, - LineNumbers), - ( - LineNumbers = yes, - EffLabelTables = LabelTables - ; - LineNumbers = no, - map__init(EffLabelTables) - ), - stack_layout__format_label_tables(EffLabelTables, - SourceFileLayouts), - SuppressedEvents = encode_suppressed_events(TraceSuppress), - ModuleLayout = layout_data(module_layout_data(ModuleName, - StringOffset, ConcatStrings, ProcLayoutNames, - SourceFileLayouts, TraceLevel, SuppressedEvents, - NumLabels)), - Layouts = [ModuleLayout | Layouts0] - ; - TraceLayout = no, - Layouts = Layouts0 - ). +:- pred valid_proc_layout(proc_layout_info::in) is semidet. -:- pred stack_layout__valid_proc_layout(proc_layout_info::in) is semidet. - -stack_layout__valid_proc_layout(ProcLayoutInfo) :- - EntryLabel = ProcLayoutInfo ^ entry_label, - ProcLabel = get_proc_label(EntryLabel), - ( - ProcLabel = proc(_, _, DeclModule, Name, Arity, _), - \+ no_type_info_builtin(DeclModule, Name, Arity) - ; - ProcLabel = special_proc(_, _, _, _, _, _) - ). +valid_proc_layout(ProcLayoutInfo) :- + EntryLabel = ProcLayoutInfo ^ entry_label, + ProcLabel = get_proc_label(EntryLabel), + ( + ProcLabel = proc(_, _, DeclModule, Name, Arity, _), + \+ no_type_info_builtin(DeclModule, Name, Arity) + ; + ProcLabel = special_proc(_, _, _, _, _, _) + ). %---------------------------------------------------------------------------% - % concat_string_list appends a list of strings together, - % appending a null character after each string. - % The resulting string will contain embedded null characters, -:- pred stack_layout__concat_string_list(list(string)::in, int::in, - string_with_0s::out) is det. + % concat_string_list appends a list of strings together, + % appending a null character after each string. + % The resulting string will contain embedded null characters, +:- pred concat_string_list(list(string)::in, int::in, + string_with_0s::out) is det. concat_string_list(Strings, Len, string_with_0s(Result)) :- - concat_string_list_2(Strings, Len, Result). + concat_string_list_2(Strings, Len, Result). -:- pred stack_layout__concat_string_list_2(list(string)::in, int::in, - string::out) is det. +:- pred concat_string_list_2(list(string)::in, int::in, string::out) is det. :- pragma foreign_decl("C", " - #include ""mercury_tags.h"" /* for MR_list_*() */ - #include ""mercury_heap.h"" /* for MR_offset_incr_hp_atomic*() */ - #include ""mercury_misc.h"" /* for MR_fatal_error() */ + #include ""mercury_tags.h"" /* for MR_list_*() */ + #include ""mercury_heap.h"" /* for MR_offset_incr_hp_atomic*() */ + #include ""mercury_misc.h"" /* for MR_fatal_error() */ "). :- pragma foreign_proc("C", - stack_layout__concat_string_list_2(StringList::in, ArenaSize::in, - Arena::out), - [will_not_call_mercury, promise_pure, thread_safe], + concat_string_list_2(StringList::in, ArenaSize::in, Arena::out), + [will_not_call_mercury, promise_pure, thread_safe], "{ - MR_Word cur_node; - MR_Integer cur_offset; - MR_Word tmp; + MR_Word cur_node; + MR_Integer cur_offset; + MR_Word tmp; - MR_offset_incr_hp_atomic(tmp, 0, - (ArenaSize + sizeof(MR_Word)) / sizeof(MR_Word)); - Arena = (char *) tmp; + MR_offset_incr_hp_atomic(tmp, 0, + (ArenaSize + sizeof(MR_Word)) / sizeof(MR_Word)); + Arena = (char *) tmp; - cur_offset = 0; - cur_node = StringList; + cur_offset = 0; + cur_node = StringList; - while (! MR_list_is_empty(cur_node)) { - (void) strcpy(&Arena[cur_offset], - (char *) MR_list_head(cur_node)); - cur_offset += strlen((char *) MR_list_head(cur_node)) + 1; - cur_node = MR_list_tail(cur_node); - } + while (! MR_list_is_empty(cur_node)) { + (void) strcpy(&Arena[cur_offset], (char *) MR_list_head(cur_node)); + cur_offset += strlen((char *) MR_list_head(cur_node)) + 1; + cur_node = MR_list_tail(cur_node); + } - if (cur_offset != ArenaSize) { - char msg[256]; + if (cur_offset != ArenaSize) { + char msg[256]; - sprintf(msg, ""internal error in creating string table;\\n"" - ""cur_offset = %ld, ArenaSize = %ld\\n"", - (long) cur_offset, (long) ArenaSize); - MR_fatal_error(msg); - } + sprintf(msg, ""internal error in creating string table;\\n"" + ""cur_offset = %ld, ArenaSize = %ld\\n"", + (long) cur_offset, (long) ArenaSize); + MR_fatal_error(msg); + } }"). % This version is only used if there is no matching foreign_proc version. % Note that this version only works if the Mercury implementation's -% string representation allows strings to contain embedded null -% characters. So we check that. +% string representation allows strings to contain embedded null characters. +% So we check that. concat_string_list_2(StringsList, _Len, StringWithNulls) :- - ( - char__to_int(NullChar, 0), - NullCharString = string__char_to_string(NullChar), - string__length(NullCharString, 1) - -> - StringsWithNullsList = list__map(func(S) = S ++ NullCharString, - StringsList), - StringWithNulls = string__append_list(StringsWithNullsList) - ; - % the Mercury implementation's string representation - % doesn't support strings containing null characters - private_builtin.sorry("stack_layout.concat_string_list") - ). + ( + char__to_int(NullChar, 0), + NullCharString = string__char_to_string(NullChar), + string__length(NullCharString, 1) + -> + StringsWithNullsList = list__map(func(S) = S ++ NullCharString, + StringsList), + StringWithNulls = string__append_list(StringsWithNullsList) + ; + % the Mercury implementation's string representation + % doesn't support strings containing null characters + private_builtin.sorry("stack_layout.concat_string_list") + ). %---------------------------------------------------------------------------% -:- pred stack_layout__format_label_tables(map(string, label_table)::in, - list(file_layout_data)::out) is det. +:- pred format_label_tables(map(string, label_table)::in, + list(file_layout_data)::out) is det. -stack_layout__format_label_tables(LabelTableMap, SourceFileLayouts) :- - map__to_assoc_list(LabelTableMap, LabelTableList), - list__map(stack_layout__format_label_table, LabelTableList, - SourceFileLayouts). +format_label_tables(LabelTableMap, SourceFileLayouts) :- + map__to_assoc_list(LabelTableMap, LabelTableList), + list__map(format_label_table, LabelTableList, SourceFileLayouts). -:- pred stack_layout__format_label_table(pair(string, label_table)::in, - file_layout_data::out) is det. +:- pred format_label_table(pair(string, label_table)::in, + file_layout_data::out) is det. -stack_layout__format_label_table(FileName - LineNoMap, - file_layout_data(FileName, FilteredList)) :- - % This step should produce a list ordered on line numbers. - map__to_assoc_list(LineNoMap, LineNoList), - % And this step should preserve that order. - stack_layout__flatten_label_table(LineNoList, [], FlatLineNoList), - Filter = (pred(LineNoInfo::in, FilteredLineNoInfo::out) is det :- - LineNoInfo = LineNo - (Label - _IsReturn), - FilteredLineNoInfo = LineNo - Label - ), - list__map(Filter, FlatLineNoList, FilteredList). +format_label_table(FileName - LineNoMap, + file_layout_data(FileName, FilteredList)) :- + % This step should produce a list ordered on line numbers. + map__to_assoc_list(LineNoMap, LineNoList), + % And this step should preserve that order. + flatten_label_table(LineNoList, [], FlatLineNoList), + Filter = (pred(LineNoInfo::in, FilteredLineNoInfo::out) is det :- + LineNoInfo = LineNo - (Label - _IsReturn), + FilteredLineNoInfo = LineNo - Label + ), + list__map(Filter, FlatLineNoList, FilteredList). -:- pred stack_layout__flatten_label_table( - assoc_list(int, list(line_no_info))::in, - assoc_list(int, line_no_info)::in, - assoc_list(int, line_no_info)::out) is det. +:- pred flatten_label_table(assoc_list(int, list(line_no_info))::in, + assoc_list(int, line_no_info)::in, + assoc_list(int, line_no_info)::out) is det. -stack_layout__flatten_label_table([], RevList, List) :- - list__reverse(RevList, List). -stack_layout__flatten_label_table([LineNo - LinesInfos | Lines], - RevList0, List) :- - list__foldl(stack_layout__add_line_no(LineNo), LinesInfos, - RevList0, RevList1), - stack_layout__flatten_label_table(Lines, RevList1, List). +flatten_label_table([], RevList, List) :- + list__reverse(RevList, List). +flatten_label_table([LineNo - LinesInfos | Lines], RevList0, List) :- + list__foldl(add_line_no(LineNo), LinesInfos, RevList0, RevList1), + flatten_label_table(Lines, RevList1, List). -:- pred stack_layout__add_line_no(int::in, line_no_info::in, - assoc_list(int, line_no_info)::in, - assoc_list(int, line_no_info)::out) is det. +:- pred add_line_no(int::in, line_no_info::in, + assoc_list(int, line_no_info)::in, + assoc_list(int, line_no_info)::out) is det. -stack_layout__add_line_no(LineNo, LineInfo, RevList0, RevList) :- - RevList = [LineNo - LineInfo | RevList0]. +add_line_no(LineNo, LineInfo, RevList0, RevList) :- + RevList = [LineNo - LineInfo | RevList0]. %---------------------------------------------------------------------------% - % Construct the layouts that concern a single procedure: - % the procedure-specific layout and the layouts of the labels - % inside that procedure. Also update the module-wide label table - % with the labels defined in this procedure. + % Construct the layouts that concern a single procedure: + % the procedure-specific layout and the layouts of the labels + % inside that procedure. Also update the module-wide label table + % with the labels defined in this procedure. + % +:- pred construct_layouts(proc_layout_info::in, + stack_layout_info::in, stack_layout_info::out) is det. -:- pred stack_layout__construct_layouts(proc_layout_info::in, - stack_layout_info::in, stack_layout_info::out) is det. +construct_layouts(ProcLayoutInfo, !Info) :- + ProcLayoutInfo = proc_layout_info(RttiProcLabel, + EntryLabel, + _Detism, + _StackSlots, + _SuccipLoc, + _EvalMethod, + _EffTraceLevel, + _MaybeCallLabel, + _MaxTraceReg, + HeadVars, + _ArgModes, + Goal, + _NeedGoalRep, + _InstMap, + _TraceSlotInfo, + ForceProcIdLayout, + VarSet, + _VarTypes, + InternalMap, + MaybeTableIoDecl, + _NeedsAllNames, + _MaybeDeepProfInfo), + map__to_assoc_list(InternalMap, Internals), + compute_var_number_map(HeadVars, VarSet, Internals, Goal, VarNumMap), -stack_layout__construct_layouts(ProcLayoutInfo, !Info) :- - ProcLayoutInfo = proc_layout_info(RttiProcLabel, EntryLabel, _Detism, - _StackSlots, _SuccipLoc, _EvalMethod, _EffTraceLevel, - _MaybeCallLabel, _MaxTraceReg, HeadVars, _ArgModes, - Goal, _NeedGoalRep, _InstMap, _TraceSlotInfo, - ForceProcIdLayout, VarSet, _VarTypes, InternalMap, - MaybeTableIoDecl, _NeedsAllNames, _MaybeDeepProfInfo), - map__to_assoc_list(InternalMap, Internals), - compute_var_number_map(HeadVars, VarSet, Internals, Goal, VarNumMap), - - ProcLabel = get_proc_label(EntryLabel), - stack_layout__get_procid_stack_layout(!.Info, ProcIdLayout0), - bool__or(ProcIdLayout0, ForceProcIdLayout, ProcIdLayout), - ( - ( ProcIdLayout = yes - ; MaybeTableIoDecl = yes(_) - ) - -> - Kind = proc_layout_proc_id(proc_label_user_or_uci(ProcLabel)) - ; - Kind = proc_layout_traversal - ), - ProcLayoutName = proc_layout(RttiProcLabel, Kind), - ( - ( !.Info ^ agc_stack_layout = yes - ; !.Info ^ trace_stack_layout = yes - ), - valid_proc_layout(ProcLayoutInfo) - -> - list__map_foldl(stack_layout__construct_internal_layout( - ProcLabel, ProcLayoutName, VarNumMap), - Internals, InternalLayouts, !Info) - ; - InternalLayouts = [] - ), - stack_layout__get_label_tables(!.Info, LabelTables0), - list__foldl(stack_layout__update_label_table, InternalLayouts, - LabelTables0, LabelTables), - stack_layout__set_label_tables(LabelTables, !Info), - stack_layout__construct_proc_layout(ProcLayoutInfo, Kind, VarNumMap, - !Info). + ProcLabel = get_proc_label(EntryLabel), + get_procid_stack_layout(!.Info, ProcIdLayout0), + bool__or(ProcIdLayout0, ForceProcIdLayout, ProcIdLayout), + ( + ( ProcIdLayout = yes + ; MaybeTableIoDecl = yes(_) + ) + -> + Kind = proc_layout_proc_id(proc_label_user_or_uci(ProcLabel)) + ; + Kind = proc_layout_traversal + ), + ProcLayoutName = proc_layout(RttiProcLabel, Kind), + ( + ( !.Info ^ agc_stack_layout = yes + ; !.Info ^ trace_stack_layout = yes + ), + valid_proc_layout(ProcLayoutInfo) + -> + list__map_foldl( + construct_internal_layout(ProcLabel, ProcLayoutName, VarNumMap), + Internals, InternalLayouts, !Info) + ; + InternalLayouts = [] + ), + get_label_tables(!.Info, LabelTables0), + list__foldl(update_label_table, InternalLayouts, + LabelTables0, LabelTables), + set_label_tables(LabelTables, !Info), + construct_proc_layout(ProcLayoutInfo, Kind, VarNumMap, !Info). %---------------------------------------------------------------------------% - % Add the given label layout to the module-wide label tables. + % Add the given label layout to the module-wide label tables. -:- pred stack_layout__update_label_table( - {proc_label, int, label_vars, internal_layout_info}::in, - map(string, label_table)::in, map(string, label_table)::out) is det. +:- pred update_label_table( + {proc_label, int, label_vars, internal_layout_info}::in, + map(string, label_table)::in, map(string, label_table)::out) is det. -stack_layout__update_label_table( - {ProcLabel, LabelNum, LabelVars, InternalInfo}, - !LabelTables) :- - InternalInfo = internal_layout_info(Port, _, Return), - ( - Return = yes(return_layout_info(TargetsContexts, _)), - stack_layout__find_valid_return_context(TargetsContexts, - Target, Context, _GoalPath) - -> - ( Target = label(TargetLabel) -> - IsReturn = known_callee(TargetLabel) - ; - IsReturn = unknown_callee - ), - stack_layout__update_label_table_2(ProcLabel, LabelNum, - LabelVars, Context, IsReturn, !LabelTables) - ; - Port = yes(trace_port_layout_info(Context, _, _, _, _)), - stack_layout__context_is_valid(Context) - -> - stack_layout__update_label_table_2(ProcLabel, LabelNum, - LabelVars, Context, not_a_return, !LabelTables) - ; - true - ). +update_label_table({ProcLabel, LabelNum, LabelVars, InternalInfo}, + !LabelTables) :- + InternalInfo = internal_layout_info(Port, _, Return), + ( + Return = yes(return_layout_info(TargetsContexts, _)), + find_valid_return_context(TargetsContexts, Target, Context, _GoalPath) + -> + ( Target = label(TargetLabel) -> + IsReturn = known_callee(TargetLabel) + ; + IsReturn = unknown_callee + ), + update_label_table_2(ProcLabel, LabelNum, + LabelVars, Context, IsReturn, !LabelTables) + ; + Port = yes(trace_port_layout_info(Context, _, _, _, _)), + context_is_valid(Context) + -> + update_label_table_2(ProcLabel, LabelNum, LabelVars, Context, + not_a_return, !LabelTables) + ; + true + ). -:- pred stack_layout__update_label_table_2(proc_label::in, int::in, - label_vars::in, context::in, is_label_return::in, - map(string, label_table)::in, map(string, label_table)::out) is det. +:- pred update_label_table_2(proc_label::in, int::in, + label_vars::in, context::in, is_label_return::in, + map(string, label_table)::in, map(string, label_table)::out) is det. -stack_layout__update_label_table_2(ProcLabel, LabelNum, LabelVars, Context, - IsReturn, !LabelTables) :- - term__context_file(Context, File), - term__context_line(Context, Line), - ( map__search(!.LabelTables, File, LabelTable0) -> - LabelLayout = label_layout(ProcLabel, LabelNum, LabelVars), - ( map__search(LabelTable0, Line, LineInfo0) -> - LineInfo = [LabelLayout - IsReturn | LineInfo0], - map__det_update(LabelTable0, Line, LineInfo, - LabelTable), - map__det_update(!.LabelTables, File, LabelTable, - !:LabelTables) - ; - LineInfo = [LabelLayout - IsReturn], - map__det_insert(LabelTable0, Line, LineInfo, - LabelTable), - map__det_update(!.LabelTables, File, LabelTable, - !:LabelTables) - ) - ; stack_layout__context_is_valid(Context) -> - map__init(LabelTable0), - LabelLayout = label_layout(ProcLabel, LabelNum, LabelVars), - LineInfo = [LabelLayout - IsReturn], - map__det_insert(LabelTable0, Line, LineInfo, LabelTable), - map__det_insert(!.LabelTables, File, LabelTable, !:LabelTables) - ; - % We don't have a valid context for this label, - % so we don't enter it into any tables. - true - ). +update_label_table_2(ProcLabel, LabelNum, LabelVars, Context, + IsReturn, !LabelTables) :- + term__context_file(Context, File), + term__context_line(Context, Line), + ( map__search(!.LabelTables, File, LabelTable0) -> + LabelLayout = label_layout(ProcLabel, LabelNum, LabelVars), + ( map__search(LabelTable0, Line, LineInfo0) -> + LineInfo = [LabelLayout - IsReturn | LineInfo0], + map__det_update(LabelTable0, Line, LineInfo, LabelTable), + svmap__det_update(File, LabelTable, !LabelTables) + ; + LineInfo = [LabelLayout - IsReturn], + map__det_insert(LabelTable0, Line, LineInfo, LabelTable), + svmap__det_update(File, LabelTable, !LabelTables) + ) + ; context_is_valid(Context) -> + map__init(LabelTable0), + LabelLayout = label_layout(ProcLabel, LabelNum, LabelVars), + LineInfo = [LabelLayout - IsReturn], + map__det_insert(LabelTable0, Line, LineInfo, LabelTable), + svmap__det_insert(File, LabelTable, !LabelTables) + ; + % We don't have a valid context for this label, + % so we don't enter it into any tables. + true + ). -:- pred stack_layout__find_valid_return_context( - assoc_list(code_addr, pair(prog_context, goal_path))::in, - code_addr::out, prog_context::out, goal_path::out) is semidet. +:- pred find_valid_return_context( + assoc_list(code_addr, pair(prog_context, goal_path))::in, + code_addr::out, prog_context::out, goal_path::out) is semidet. -stack_layout__find_valid_return_context([TargetContext | TargetContexts], - ValidTarget, ValidContext, ValidGoalPath) :- - TargetContext = Target - (Context - GoalPath), - ( stack_layout__context_is_valid(Context) -> - ValidTarget = Target, - ValidContext = Context, - ValidGoalPath = GoalPath - ; - stack_layout__find_valid_return_context(TargetContexts, - ValidTarget, ValidContext, ValidGoalPath) - ). +find_valid_return_context([TargetContext | TargetContexts], + ValidTarget, ValidContext, ValidGoalPath) :- + TargetContext = Target - (Context - GoalPath), + ( context_is_valid(Context) -> + ValidTarget = Target, + ValidContext = Context, + ValidGoalPath = GoalPath + ; + find_valid_return_context(TargetContexts, ValidTarget, ValidContext, + ValidGoalPath) + ). -:- pred stack_layout__context_is_valid(prog_context::in) is semidet. +:- pred context_is_valid(prog_context::in) is semidet. -stack_layout__context_is_valid(Context) :- - term__context_file(Context, File), - term__context_line(Context, Line), - File \= "", - Line > 0. +context_is_valid(Context) :- + term__context_file(Context, File), + term__context_line(Context, Line), + File \= "", + Line > 0. %---------------------------------------------------------------------------% -:- pred stack_layout__construct_proc_traversal(label::in, determinism::in, - int::in, maybe(int)::in, proc_layout_stack_traversal::out, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred construct_proc_traversal(label::in, determinism::in, + int::in, maybe(int)::in, proc_layout_stack_traversal::out, + stack_layout_info::in, stack_layout_info::out) is det. -stack_layout__construct_proc_traversal(EntryLabel, Detism, NumStackSlots, - MaybeSuccipLoc, Traversal, !Info) :- - ( - MaybeSuccipLoc = yes(Location), - ( determinism_components(Detism, _, at_most_many) -> - SuccipLval = framevar(Location) - ; - SuccipLval = stackvar(Location) - ), - stack_layout__represent_locn_as_int(direct(SuccipLval), - SuccipInt), - MaybeSuccipInt = yes(SuccipInt) - ; - MaybeSuccipLoc = no, - % Use a dummy location if there is no succip slot - % on the stack. - % - % This case can arise in two circumstances. - % First, procedures that use the nondet stack - % have a special slot for the succip, so the - % succip is not stored in a general purpose - % slot. Second, procedures that use the det stack - % but which do not call other procedures - % do not save the succip on the stack. - % - % The tracing system does not care about the - % location of the saved succip. The accurate - % garbage collector does. It should know from - % the determinism that the procedure uses the - % nondet stack, which takes care of the first - % possibility above. Procedures that do not call - % other procedures do not establish resumption - % points and thus agc is not interested in them. - % As far as stack dumps go, calling error counts - % as a call, so any procedure that may call error - % (directly or indirectly) will have its saved succip - % location recorded, so the stack dump will work. - % - % Future uses of stack layouts will have to have - % similar constraints. - MaybeSuccipInt = no - ), - stack_layout__get_static_code_addresses(!.Info, StaticCodeAddr), - ( - StaticCodeAddr = yes, - MaybeEntryLabel = yes(EntryLabel) - ; - StaticCodeAddr = no, - MaybeEntryLabel = no - ), - Traversal = proc_layout_stack_traversal(MaybeEntryLabel, - MaybeSuccipInt, NumStackSlots, Detism). +construct_proc_traversal(EntryLabel, Detism, NumStackSlots, + MaybeSuccipLoc, Traversal, !Info) :- + ( + MaybeSuccipLoc = yes(Location), + ( determinism_components(Detism, _, at_most_many) -> + SuccipLval = framevar(Location) + ; + SuccipLval = stackvar(Location) + ), + represent_locn_as_int(direct(SuccipLval), SuccipInt), + MaybeSuccipInt = yes(SuccipInt) + ; + MaybeSuccipLoc = no, + % Use a dummy location if there is no succip slot on the stack. + % + % This case can arise in two circumstances. First, procedures that + % use the nondet stack have a special slot for the succip, so the + % succip is not stored in a general purpose slot. Second, procedures + % that use the det stack but which do not call other procedures + % do not save the succip on the stack. + % + % The tracing system does not care about the location of the saved + % succip. The accurate garbage collector does. It should know from + % the determinism that the procedure uses the nondet stack, which + % takes care of the first possibility above. Procedures that do not + % call other procedures do not establish resumption points and thus + % agc is not interested in them. As far as stack dumps go, calling + % error counts as a call, so any procedure that may call error + % (directly or indirectly) will have its saved succip location + % recorded, so the stack dump will work. + % + % Future uses of stack layouts will have to have similar constraints. + MaybeSuccipInt = no + ), + get_static_code_addresses(!.Info, StaticCodeAddr), + ( + StaticCodeAddr = yes, + MaybeEntryLabel = yes(EntryLabel) + ; + StaticCodeAddr = no, + MaybeEntryLabel = no + ), + Traversal = proc_layout_stack_traversal(MaybeEntryLabel, + MaybeSuccipInt, NumStackSlots, Detism). - % Construct a procedure-specific layout. + % Construct a procedure-specific layout. + % +:- pred construct_proc_layout(proc_layout_info::in, + proc_layout_kind::in, var_num_map::in, + stack_layout_info::in, stack_layout_info::out) is det. -:- pred stack_layout__construct_proc_layout(proc_layout_info::in, - proc_layout_kind::in, var_num_map::in, - stack_layout_info::in, stack_layout_info::out) is det. +construct_proc_layout(ProcLayoutInfo, Kind, VarNumMap, !Info) :- + ProcLayoutInfo = proc_layout_info(RttiProcLabel, + EntryLabel, + Detism, + StackSlots, + SuccipLoc, + EvalMethod, + EffTraceLevel, + MaybeCallLabel, + MaxTraceReg, + HeadVars, + ArgModes, + Goal, + NeedGoalRep, + InstMap, + TraceSlotInfo, + _ForceProcIdLayout, + VarSet, + VarTypes, + _InternalMap, + MaybeTableInfo, + NeedsAllNames, + MaybeProcStatic), + construct_proc_traversal(EntryLabel, Detism, StackSlots, + SuccipLoc, Traversal, !Info), + ( + Kind = proc_layout_traversal, + More = no_proc_id + ; + Kind = proc_layout_proc_id(_), + get_trace_stack_layout(!.Info, TraceStackLayout), + ( + TraceStackLayout = yes, + given_trace_level_is_none(EffTraceLevel) = no, + valid_proc_layout(ProcLayoutInfo) + -> + construct_trace_layout(RttiProcLabel, EvalMethod, EffTraceLevel, + MaybeCallLabel, MaxTraceReg, HeadVars, ArgModes, Goal, + NeedGoalRep, InstMap, TraceSlotInfo, + VarSet, VarTypes, MaybeTableInfo, + NeedsAllNames, VarNumMap, ExecTrace, !Info), + MaybeExecTrace = yes(ExecTrace) + ; + MaybeExecTrace = no + ), + More = proc_id(MaybeProcStatic, MaybeExecTrace) + ), + ProcLayout = proc_layout_data(RttiProcLabel, Traversal, More), + Data = layout_data(ProcLayout), + LayoutName = proc_layout(RttiProcLabel, Kind), + add_proc_layout_data(Data, LayoutName, EntryLabel, + !Info), + ( + MaybeTableInfo = no + ; + MaybeTableInfo = yes(TableInfo), + get_static_cell_info(!.Info, StaticCellInfo0), + make_table_data(RttiProcLabel, Kind, TableInfo, TableData, + StaticCellInfo0, StaticCellInfo), + set_static_cell_info(StaticCellInfo, !Info), + add_table_data(TableData, !Info) + ). -stack_layout__construct_proc_layout(ProcLayoutInfo, Kind, VarNumMap, !Info) :- - ProcLayoutInfo = proc_layout_info(RttiProcLabel, EntryLabel, Detism, - StackSlots, SuccipLoc, EvalMethod, EffTraceLevel, - MaybeCallLabel, MaxTraceReg, HeadVars, ArgModes, - Goal, NeedGoalRep, InstMap, TraceSlotInfo, _ForceProcIdLayout, - VarSet, VarTypes, _InternalMap, MaybeTableInfo, NeedsAllNames, - MaybeProcStatic), - stack_layout__construct_proc_traversal(EntryLabel, Detism, StackSlots, - SuccipLoc, Traversal, !Info), - ( - Kind = proc_layout_traversal, - More = no_proc_id - ; - Kind = proc_layout_proc_id(_), - stack_layout__get_trace_stack_layout(!.Info, TraceStackLayout), - ( - TraceStackLayout = yes, - given_trace_level_is_none(EffTraceLevel) = no, - valid_proc_layout(ProcLayoutInfo) - -> - stack_layout__construct_trace_layout(RttiProcLabel, - EvalMethod, EffTraceLevel, MaybeCallLabel, - MaxTraceReg, HeadVars, ArgModes, Goal, - NeedGoalRep, InstMap, TraceSlotInfo, - VarSet, VarTypes, MaybeTableInfo, - NeedsAllNames, VarNumMap, ExecTrace, !Info), - MaybeExecTrace = yes(ExecTrace) - ; - MaybeExecTrace = no - ), - More = proc_id(MaybeProcStatic, MaybeExecTrace) - ), - ProcLayout = proc_layout_data(RttiProcLabel, Traversal, More), - Data = layout_data(ProcLayout), - LayoutName = proc_layout(RttiProcLabel, Kind), - stack_layout__add_proc_layout_data(Data, LayoutName, EntryLabel, - !Info), - ( - MaybeTableInfo = no - ; - MaybeTableInfo = yes(TableInfo), - stack_layout__get_static_cell_info(!.Info, StaticCellInfo0), - stack_layout__make_table_data(RttiProcLabel, Kind, - TableInfo, TableData, - StaticCellInfo0, StaticCellInfo), - stack_layout__set_static_cell_info(StaticCellInfo, !Info), - stack_layout__add_table_data(TableData, !Info) - ). +:- pred construct_trace_layout(rtti_proc_label::in, + eval_method::in, trace_level::in, maybe(label)::in, int::in, + list(prog_var)::in, list(mode)::in, hlds_goal::in, bool::in, + instmap::in, trace_slot_info::in, prog_varset::in, vartypes::in, + maybe(proc_table_info)::in, bool::in, var_num_map::in, + proc_layout_exec_trace::out, + stack_layout_info::in, stack_layout_info::out) is det. -:- pred stack_layout__construct_trace_layout(rtti_proc_label::in, - eval_method::in, trace_level::in, maybe(label)::in, int::in, - list(prog_var)::in, list(mode)::in, hlds_goal::in, bool::in, - instmap::in, trace_slot_info::in, prog_varset::in, vartypes::in, - maybe(proc_table_info)::in, bool::in, var_num_map::in, - proc_layout_exec_trace::out, - stack_layout_info::in, stack_layout_info::out) is det. - -stack_layout__construct_trace_layout(RttiProcLabel, EvalMethod, EffTraceLevel, - MaybeCallLabel, MaxTraceReg, HeadVars, ArgModes, - Goal, NeedGoalRep, InstMap, TraceSlotInfo, _VarSet, VarTypes, - MaybeTableInfo, NeedsAllNames, VarNumMap, ExecTrace, !Info) :- - stack_layout__construct_var_name_vector(VarNumMap, - NeedsAllNames, MaxVarNum, VarNameVector, !Info), - list__map(convert_var_to_int(VarNumMap), HeadVars, HeadVarNumVector), - ModuleInfo = !.Info ^ module_info, - ( - NeedGoalRep = no, - ProcBytes = [] - ; - NeedGoalRep = yes, - prog_rep__represent_proc(HeadVars, - Goal, InstMap, VarTypes, VarNumMap, ModuleInfo, - !Info, ProcBytes) - ), - ( - MaybeCallLabel = yes(CallLabelPrime), - CallLabel = CallLabelPrime - ; - MaybeCallLabel = no, - error("stack_layout__construct_trace_layout: " ++ - "call label not present") - ), - TraceSlotInfo = trace_slot_info(MaybeFromFullSlot, MaybeIoSeqSlot, - MaybeTrailSlots, MaybeMaxfrSlot, MaybeCallTableSlot), - % The label associated with an event must have variable info. - ( - CallLabel = internal(CallLabelNum, CallProcLabel) - ; - CallLabel = entry(_, _), - error("stack_layout__construct_trace_layout: entry call label") - ), - CallLabelLayout = label_layout(CallProcLabel, CallLabelNum, - label_has_var_info), - ( - MaybeTableInfo = no, - MaybeTableName = no - ; - MaybeTableInfo = yes(TableInfo), - ( - TableInfo = table_io_decl_info(_), - MaybeTableName = yes(table_io_decl(RttiProcLabel)) - ; - TableInfo = table_gen_info(_, _, _, _), - MaybeTableName = yes(table_gen_info(RttiProcLabel)) - ) - ), - encode_exec_trace_flags(ModuleInfo, HeadVars, ArgModes, VarTypes, - 0, Flags), - ExecTrace = proc_layout_exec_trace(CallLabelLayout, ProcBytes, - MaybeTableName, HeadVarNumVector, VarNameVector, - MaxVarNum, MaxTraceReg, MaybeFromFullSlot, MaybeIoSeqSlot, - MaybeTrailSlots, MaybeMaxfrSlot, EvalMethod, - MaybeCallTableSlot, EffTraceLevel, Flags). +construct_trace_layout(RttiProcLabel, EvalMethod, EffTraceLevel, + MaybeCallLabel, MaxTraceReg, HeadVars, ArgModes, + Goal, NeedGoalRep, InstMap, TraceSlotInfo, _VarSet, VarTypes, + MaybeTableInfo, NeedsAllNames, VarNumMap, ExecTrace, !Info) :- + construct_var_name_vector(VarNumMap, + NeedsAllNames, MaxVarNum, VarNameVector, !Info), + list__map(convert_var_to_int(VarNumMap), HeadVars, HeadVarNumVector), + ModuleInfo = !.Info ^ module_info, + ( + NeedGoalRep = no, + ProcBytes = [] + ; + NeedGoalRep = yes, + prog_rep__represent_proc(HeadVars, Goal, InstMap, VarTypes, VarNumMap, + ModuleInfo, !Info, ProcBytes) + ), + ( + MaybeCallLabel = yes(CallLabelPrime), + CallLabel = CallLabelPrime + ; + MaybeCallLabel = no, + error("construct_trace_layout: call label not present") + ), + TraceSlotInfo = trace_slot_info(MaybeFromFullSlot, MaybeIoSeqSlot, + MaybeTrailSlots, MaybeMaxfrSlot, MaybeCallTableSlot), + % The label associated with an event must have variable info. + ( + CallLabel = internal(CallLabelNum, CallProcLabel) + ; + CallLabel = entry(_, _), + error("construct_trace_layout: entry call label") + ), + CallLabelLayout = label_layout(CallProcLabel, CallLabelNum, + label_has_var_info), + ( + MaybeTableInfo = no, + MaybeTableName = no + ; + MaybeTableInfo = yes(TableInfo), + ( + TableInfo = table_io_decl_info(_), + MaybeTableName = yes(table_io_decl(RttiProcLabel)) + ; + TableInfo = table_gen_info(_, _, _, _), + MaybeTableName = yes(table_gen_info(RttiProcLabel)) + ) + ), + encode_exec_trace_flags(ModuleInfo, HeadVars, ArgModes, VarTypes, + 0, Flags), + ExecTrace = proc_layout_exec_trace(CallLabelLayout, ProcBytes, + MaybeTableName, HeadVarNumVector, VarNameVector, + MaxVarNum, MaxTraceReg, MaybeFromFullSlot, MaybeIoSeqSlot, + MaybeTrailSlots, MaybeMaxfrSlot, EvalMethod, + MaybeCallTableSlot, EffTraceLevel, Flags). :- pred encode_exec_trace_flags(module_info::in, list(prog_var)::in, - list(mode)::in, vartypes::in, int::in, int::out) is det. + list(mode)::in, vartypes::in, int::in, int::out) is det. encode_exec_trace_flags(ModuleInfo, HeadVars, ArgModes, VarTypes, !Flags) :- - ( - proc_info_has_io_state_pair_from_details(ModuleInfo, HeadVars, - ArgModes, VarTypes, _, _) - -> - !:Flags = !.Flags + 1 - ; - true - ). + ( + proc_info_has_io_state_pair_from_details(ModuleInfo, HeadVars, + ArgModes, VarTypes, _, _) + -> + !:Flags = !.Flags + 1 + ; + true + ). -:- pred stack_layout__construct_var_name_vector(var_num_map::in, - bool::in, int::out, list(int)::out, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred construct_var_name_vector(var_num_map::in, + bool::in, int::out, list(int)::out, + stack_layout_info::in, stack_layout_info::out) is det. -stack_layout__construct_var_name_vector(VarNumMap, NeedsAllNames, MaxVarNum, - Offsets, !Info) :- - map__values(VarNumMap, VarNames0), - ( - NeedsAllNames = yes, - VarNames = VarNames0 - ; - NeedsAllNames = no, - list__filter(var_has_name, VarNames0, VarNames) - ), - list__sort(VarNames, SortedVarNames), - ( SortedVarNames = [FirstVarNum - _ | _] -> - MaxVarNum0 = FirstVarNum, - stack_layout__construct_var_name_rvals(SortedVarNames, 1, - MaxVarNum0, MaxVarNum, Offsets, !Info) - ; - % Since variable numbers start at 1, MaxVarNum = 0 - % implies an empty array. - MaxVarNum = 0, - Offsets = [] - ). +construct_var_name_vector(VarNumMap, NeedsAllNames, MaxVarNum, Offsets, + !Info) :- + map__values(VarNumMap, VarNames0), + ( + NeedsAllNames = yes, + VarNames = VarNames0 + ; + NeedsAllNames = no, + list__filter(var_has_name, VarNames0, VarNames) + ), + list__sort(VarNames, SortedVarNames), + ( SortedVarNames = [FirstVarNum - _ | _] -> + MaxVarNum0 = FirstVarNum, + construct_var_name_rvals(SortedVarNames, 1, MaxVarNum0, MaxVarNum, + Offsets, !Info) + ; + % Since variable numbers start at 1, MaxVarNum = 0 implies + % an empty array. + MaxVarNum = 0, + Offsets = [] + ). :- pred var_has_name(pair(int, string)::in) is semidet. var_has_name(_VarNum - VarName) :- - VarName \= "". + VarName \= "". -:- pred stack_layout__construct_var_name_rvals(assoc_list(int, string)::in, - int::in, int::in, int::out, list(int)::out, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred construct_var_name_rvals(assoc_list(int, string)::in, + int::in, int::in, int::out, list(int)::out, + stack_layout_info::in, stack_layout_info::out) is det. -stack_layout__construct_var_name_rvals([], _CurNum, MaxNum, MaxNum, [], !Info). -stack_layout__construct_var_name_rvals([Var - Name | VarNamesTail], CurNum, - !MaxNum, [Offset | OffsetsTail], !Info) :- - ( Var = CurNum -> - stack_layout__lookup_string_in_table(Name, Offset, !Info), - !:MaxNum = Var, - VarNames = VarNamesTail - ; - Offset = 0, - VarNames = [Var - Name | VarNamesTail] - ), - stack_layout__construct_var_name_rvals(VarNames, CurNum + 1, - !MaxNum, OffsetsTail, !Info). +construct_var_name_rvals([], _CurNum, MaxNum, MaxNum, [], !Info). +construct_var_name_rvals([Var - Name | VarNamesTail], CurNum, + !MaxNum, [Offset | OffsetsTail], !Info) :- + ( Var = CurNum -> + lookup_string_in_table(Name, Offset, !Info), + !:MaxNum = Var, + VarNames = VarNamesTail + ; + Offset = 0, + VarNames = [Var - Name | VarNamesTail] + ), + construct_var_name_rvals(VarNames, CurNum + 1, + !MaxNum, OffsetsTail, !Info). %---------------------------------------------------------------------------% :- pred compute_var_number_map(list(prog_var)::in, prog_varset::in, - assoc_list(int, internal_layout_info)::in, hlds_goal::in, - var_num_map::out) is det. + assoc_list(int, internal_layout_info)::in, hlds_goal::in, + var_num_map::out) is det. compute_var_number_map(HeadVars, VarSet, Internals, Goal, VarNumMap) :- - some [!VarNumMap, !Counter] ( - !:VarNumMap = map__init, - !:Counter = counter__init(1), % to match term__var_supply_init - goal_util__goal_vars(Goal, GoalVarSet), - set__to_sorted_list(GoalVarSet, GoalVars), - list__foldl2(add_var_to_var_number_map(VarSet), GoalVars, - !VarNumMap, !Counter), - list__foldl2(add_var_to_var_number_map(VarSet), HeadVars, - !VarNumMap, !Counter), - list__foldl2(internal_var_number_map, Internals, !VarNumMap, - !.Counter, _), - VarNumMap = !.VarNumMap - ). + some [!VarNumMap, !Counter] ( + !:VarNumMap = map__init, + !:Counter = counter__init(1), % to match term__var_supply_init + goal_util__goal_vars(Goal, GoalVarSet), + set__to_sorted_list(GoalVarSet, GoalVars), + list__foldl2(add_var_to_var_number_map(VarSet), GoalVars, + !VarNumMap, !Counter), + list__foldl2(add_var_to_var_number_map(VarSet), HeadVars, + !VarNumMap, !Counter), + list__foldl2(internal_var_number_map, Internals, !VarNumMap, + !.Counter, _), + VarNumMap = !.VarNumMap + ). :- pred internal_var_number_map(pair(int, internal_layout_info)::in, - var_num_map::in, var_num_map::out, counter::in, counter::out) is det. + var_num_map::in, var_num_map::out, counter::in, counter::out) is det. internal_var_number_map(_Label - Internal, !VarNumMap, !Counter) :- - Internal = internal_layout_info(MaybeTrace, MaybeResume, MaybeReturn), - ( - MaybeTrace = yes(Trace), - Trace = trace_port_layout_info(_, _, _, _, TraceLayout), - label_layout_var_number_map(TraceLayout, !VarNumMap, !Counter) - ; - MaybeTrace = no - ), - ( - MaybeResume = yes(ResumeLayout), - label_layout_var_number_map(ResumeLayout, !VarNumMap, !Counter) - ; - MaybeResume = no - ), - ( - MaybeReturn = yes(Return), - Return = return_layout_info(_, ReturnLayout), - label_layout_var_number_map(ReturnLayout, !VarNumMap, !Counter) - ; - MaybeReturn = no - ). + Internal = internal_layout_info(MaybeTrace, MaybeResume, MaybeReturn), + ( + MaybeTrace = yes(Trace), + Trace = trace_port_layout_info(_, _, _, _, TraceLayout), + label_layout_var_number_map(TraceLayout, !VarNumMap, !Counter) + ; + MaybeTrace = no + ), + ( + MaybeResume = yes(ResumeLayout), + label_layout_var_number_map(ResumeLayout, !VarNumMap, !Counter) + ; + MaybeResume = no + ), + ( + MaybeReturn = yes(Return), + Return = return_layout_info(_, ReturnLayout), + label_layout_var_number_map(ReturnLayout, !VarNumMap, !Counter) + ; + MaybeReturn = no + ). :- pred label_layout_var_number_map(layout_label_info::in, - var_num_map::in, var_num_map::out, counter::in, counter::out) is det. + var_num_map::in, var_num_map::out, counter::in, counter::out) is det. label_layout_var_number_map(LabelLayout, !VarNumMap, !Counter) :- - LabelLayout = layout_label_info(VarInfoSet, _), - VarInfos = set__to_sorted_list(VarInfoSet), - FindVar = (pred(VarInfo::in, Var - Name::out) is semidet :- - VarInfo = layout_var_info(_, LiveValueType, _), - LiveValueType = var(Var, Name, _, _) - ), - list__filter_map(FindVar, VarInfos, VarsNames), - list__foldl2(add_named_var_to_var_number_map, VarsNames, - !VarNumMap, !Counter). + LabelLayout = layout_label_info(VarInfoSet, _), + VarInfos = set__to_sorted_list(VarInfoSet), + FindVar = (pred(VarInfo::in, Var - Name::out) is semidet :- + VarInfo = layout_var_info(_, LiveValueType, _), + LiveValueType = var(Var, Name, _, _) + ), + list__filter_map(FindVar, VarInfos, VarsNames), + list__foldl2(add_named_var_to_var_number_map, VarsNames, + !VarNumMap, !Counter). :- pred add_var_to_var_number_map(prog_varset::in, prog_var::in, - var_num_map::in, var_num_map::out, counter::in, counter::out) is det. + var_num_map::in, var_num_map::out, counter::in, counter::out) is det. add_var_to_var_number_map(VarSet, Var, !VarNumMap, !Counter) :- - ( varset__search_name(VarSet, Var, VarName) -> - Name = VarName - ; - Name = "" - ), - add_named_var_to_var_number_map(Var - Name, !VarNumMap, !Counter). + ( varset__search_name(VarSet, Var, VarName) -> + Name = VarName + ; + Name = "" + ), + add_named_var_to_var_number_map(Var - Name, !VarNumMap, !Counter). :- pred add_named_var_to_var_number_map(pair(prog_var, string)::in, - var_num_map::in, var_num_map::out, counter::in, counter::out) is det. + var_num_map::in, var_num_map::out, counter::in, counter::out) is det. add_named_var_to_var_number_map(Var - Name, !VarNumMap, !Counter) :- - ( map__search(!.VarNumMap, Var, _) -> - % Name shouldn't differ from the name recorded in !.VarNumMap. - true - ; - counter__allocate(VarNum, !Counter), - map__det_insert(!.VarNumMap, Var, VarNum - Name, !:VarNumMap) - ). + ( map__search(!.VarNumMap, Var, _) -> + % Name shouldn't differ from the name recorded in !.VarNumMap. + true + ; + counter__allocate(VarNum, !Counter), + map__det_insert(!.VarNumMap, Var, VarNum - Name, !:VarNumMap) + ). %---------------------------------------------------------------------------% - % Construct the layout describing a single internal label - % for accurate GC and/or execution tracing. + % Construct the layout describing a single internal label + % for accurate GC and/or execution tracing. + % +:- pred construct_internal_layout(proc_label::in, + layout_name::in, var_num_map::in, pair(int, internal_layout_info)::in, + {proc_label, int, label_vars, internal_layout_info}::out, + stack_layout_info::in, stack_layout_info::out) is det. -:- pred stack_layout__construct_internal_layout(proc_label::in, - layout_name::in, var_num_map::in, pair(int, internal_layout_info)::in, - {proc_label, int, label_vars, internal_layout_info}::out, - stack_layout_info::in, stack_layout_info::out) is det. +construct_internal_layout(ProcLabel, ProcLayoutName, VarNumMap, + LabelNum - Internal, LabelLayout, !Info) :- + Internal = internal_layout_info(Trace, Resume, Return), + ( + Trace = no, + set__init(TraceLiveVarSet), + map__init(TraceTypeVarMap) + ; + Trace = yes(trace_port_layout_info(_,_,_,_, TraceLayout)), + TraceLayout = layout_label_info(TraceLiveVarSet, TraceTypeVarMap) + ), + ( + Resume = no, + set__init(ResumeLiveVarSet), + map__init(ResumeTypeVarMap) + ; + Resume = yes(ResumeLayout), + ResumeLayout = layout_label_info(ResumeLiveVarSet, ResumeTypeVarMap) + ), + ( + Trace = yes(trace_port_layout_info(_, Port, IsHidden, GoalPath, _)), + Return = no, + MaybePort = yes(Port), + MaybeIsHidden = yes(IsHidden), + goal_path_to_string(GoalPath, GoalPathStr), + lookup_string_in_table(GoalPathStr, GoalPathNum, !Info), + MaybeGoalPath = yes(GoalPathNum) + ; + Trace = no, + Return = yes(ReturnInfo), + % We only ever use the port fields of these layout structures + % when we process exception events. (Since exception events are + % interface events, the goal path field is not meaningful then.) + MaybePort = yes(exception), + MaybeIsHidden = yes(no), + % We only ever use the goal path fields of these layout structures + % when we process "fail" commands in the debugger. + ReturnInfo = return_layout_info(TargetsContexts, _), + ( + find_valid_return_context(TargetsContexts, _, _, GoalPath) + -> + goal_path_to_string(GoalPath, GoalPathStr), + lookup_string_in_table(GoalPathStr, GoalPathNum, !Info), + MaybeGoalPath = yes(GoalPathNum) + ; + % If tracing is enabled, then exactly one of the calls for which + % this label is a return site would have had a valid context. + % If none do, then tracing is not enabled, and therefore the goal + % path of this label will not be accessed. + MaybeGoalPath = no + ) + ; + Trace = no, + Return = no, + MaybePort = no, + MaybeIsHidden = no, + MaybeGoalPath = no + ; + Trace = yes(_), + Return = yes(_), + error("label has both trace and return layout info") + ), + get_agc_stack_layout(!.Info, AgcStackLayout), + ( + Return = no, + set__init(ReturnLiveVarSet), + map__init(ReturnTypeVarMap) + ; + Return = yes(return_layout_info(_, ReturnLayout)), + ReturnLayout = layout_label_info(ReturnLiveVarSet0, ReturnTypeVarMap0), + ( + AgcStackLayout = yes, + ReturnLiveVarSet = ReturnLiveVarSet0, + ReturnTypeVarMap = ReturnTypeVarMap0 + ; + AgcStackLayout = no, + % This set of variables must be for uplevel printing in execution + % tracing, so we are interested only in (a) variables, not + % temporaries, (b) only named variables, and (c) only those + % on the stack, not the return values. + set__to_sorted_list(ReturnLiveVarSet0, ReturnLiveVarList0), + select_trace_return( + ReturnLiveVarList0, ReturnTypeVarMap0, + ReturnLiveVarList, ReturnTypeVarMap), + set__list_to_set(ReturnLiveVarList, ReturnLiveVarSet) + ) + ), + ( + Trace = no, + Resume = no, + Return = no + -> + MaybeVarInfo = no, + LabelVars = label_has_no_var_info + ; + % XXX Ignore differences in insts inside layout_var_infos. + set__union(TraceLiveVarSet, ResumeLiveVarSet, LiveVarSet0), + set__union(LiveVarSet0, ReturnLiveVarSet, LiveVarSet), + map__union(set__intersect, TraceTypeVarMap, ResumeTypeVarMap, + TypeVarMap0), + map__union(set__intersect, TypeVarMap0, ReturnTypeVarMap, TypeVarMap), + construct_livelval_rvals(LiveVarSet, VarNumMap, TypeVarMap, + EncodedLength, LiveValRval, NamesRval, TypeParamRval, !Info), + VarInfo = label_var_info(EncodedLength, LiveValRval, NamesRval, + TypeParamRval), + MaybeVarInfo = yes(VarInfo), + LabelVars = label_has_var_info + ), -stack_layout__construct_internal_layout(ProcLabel, ProcLayoutName, VarNumMap, - LabelNum - Internal, LabelLayout, !Info) :- - Internal = internal_layout_info(Trace, Resume, Return), - ( - Trace = no, - set__init(TraceLiveVarSet), - map__init(TraceTypeVarMap) - ; - Trace = yes(trace_port_layout_info(_,_,_,_, TraceLayout)), - TraceLayout = layout_label_info(TraceLiveVarSet, - TraceTypeVarMap) - ), - ( - Resume = no, - set__init(ResumeLiveVarSet), - map__init(ResumeTypeVarMap) - ; - Resume = yes(ResumeLayout), - ResumeLayout = layout_label_info(ResumeLiveVarSet, - ResumeTypeVarMap) - ), - ( - Trace = yes(trace_port_layout_info(_, Port, IsHidden, - GoalPath, _)), - Return = no, - MaybePort = yes(Port), - MaybeIsHidden = yes(IsHidden), - goal_path_to_string(GoalPath, GoalPathStr), - stack_layout__lookup_string_in_table(GoalPathStr, GoalPathNum, - !Info), - MaybeGoalPath = yes(GoalPathNum) - ; - Trace = no, - Return = yes(ReturnInfo), - % We only ever use the port fields of these layout - % structures when we process exception events. - % (Since exception events are interface events, - % the goal path field is not meaningful then.) - MaybePort = yes(exception), - MaybeIsHidden = yes(no), - % We only ever use the goal path fields of these - % layout structures when we process "fail" commands - % in the debugger. - ReturnInfo = return_layout_info(TargetsContexts, _), - ( - stack_layout__find_valid_return_context( - TargetsContexts, _, _, GoalPath) - -> - goal_path_to_string(GoalPath, GoalPathStr), - stack_layout__lookup_string_in_table(GoalPathStr, - GoalPathNum, !Info), - MaybeGoalPath = yes(GoalPathNum) - ; - % If tracing is enabled, then exactly one of - % the calls for which this label is a return - % site would have had a valid context. If none - % do, then tracing is not enabled, and - % therefore the goal path of this label will - % not be accessed. - MaybeGoalPath = no - ) - ; - Trace = no, - Return = no, - MaybePort = no, - MaybeIsHidden = no, - MaybeGoalPath = no - ; - Trace = yes(_), - Return = yes(_), - error("label has both trace and return layout info") - ), - stack_layout__get_agc_stack_layout(!.Info, AgcStackLayout), - ( - Return = no, - set__init(ReturnLiveVarSet), - map__init(ReturnTypeVarMap) - ; - Return = yes(return_layout_info(_, ReturnLayout)), - ReturnLayout = layout_label_info(ReturnLiveVarSet0, - ReturnTypeVarMap0), - ( - AgcStackLayout = yes, - ReturnLiveVarSet = ReturnLiveVarSet0, - ReturnTypeVarMap = ReturnTypeVarMap0 - ; - AgcStackLayout = no, - % This set of variables must be for uplevel printing - % in execution tracing, so we are interested only - % in (a) variables, not temporaries, (b) only named - % variables, and (c) only those on the stack, not - % the return values. - set__to_sorted_list(ReturnLiveVarSet0, - ReturnLiveVarList0), - stack_layout__select_trace_return( - ReturnLiveVarList0, ReturnTypeVarMap0, - ReturnLiveVarList, ReturnTypeVarMap), - set__list_to_set(ReturnLiveVarList, ReturnLiveVarSet) - ) - ), - ( - Trace = no, - Resume = no, - Return = no - -> - MaybeVarInfo = no, - LabelVars = label_has_no_var_info - ; - % XXX ignore differences in insts inside - % layout_var_infos - set__union(TraceLiveVarSet, ResumeLiveVarSet, LiveVarSet0), - set__union(LiveVarSet0, ReturnLiveVarSet, LiveVarSet), - map__union(set__intersect, TraceTypeVarMap, ResumeTypeVarMap, - TypeVarMap0), - map__union(set__intersect, TypeVarMap0, ReturnTypeVarMap, - TypeVarMap), - stack_layout__construct_livelval_rvals(LiveVarSet, VarNumMap, - TypeVarMap, EncodedLength, LiveValRval, NamesRval, - TypeParamRval, !Info), - VarInfo = label_var_info(EncodedLength, LiveValRval, NamesRval, - TypeParamRval), - MaybeVarInfo = yes(VarInfo), - LabelVars = label_has_var_info - ), - - ( - Trace = yes(_), - stack_layout__allocate_label_number(LabelNumber0, !Info), - % MR_ml_label_exec_count[0] is never written out; - % it is reserved for cases like this, for labels without - % events, and for handwritten labels. - ( LabelNumber0 < (1 << 16) -> - LabelNumber = LabelNumber0 - ; - LabelNumber = 0 - ) - ; - Trace = no, - LabelNumber = 0 - ), - LayoutData = label_layout_data(ProcLabel, LabelNum, ProcLayoutName, - MaybePort, MaybeIsHidden, LabelNumber, MaybeGoalPath, - MaybeVarInfo), - CData = layout_data(LayoutData), - LayoutName = label_layout(ProcLabel, LabelNum, LabelVars), - Label = internal(LabelNum, ProcLabel), - stack_layout__add_internal_layout_data(CData, Label, LayoutName, - !Info), - LabelLayout = {ProcLabel, LabelNum, LabelVars, Internal}. + ( + Trace = yes(_), + allocate_label_number(LabelNumber0, !Info), + % MR_ml_label_exec_count[0] is never written out; + % it is reserved for cases like this, for labels without + % events, and for handwritten labels. + ( LabelNumber0 < (1 << 16) -> + LabelNumber = LabelNumber0 + ; + LabelNumber = 0 + ) + ; + Trace = no, + LabelNumber = 0 + ), + LayoutData = label_layout_data(ProcLabel, LabelNum, ProcLayoutName, + MaybePort, MaybeIsHidden, LabelNumber, MaybeGoalPath, MaybeVarInfo), + CData = layout_data(LayoutData), + LayoutName = label_layout(ProcLabel, LabelNum, LabelVars), + Label = internal(LabelNum, ProcLabel), + add_internal_layout_data(CData, Label, LayoutName, !Info), + LabelLayout = {ProcLabel, LabelNum, LabelVars, Internal}. %---------------------------------------------------------------------------% -:- pred stack_layout__construct_livelval_rvals(set(layout_var_info)::in, - var_num_map::in, map(tvar, set(layout_locn))::in, int::out, - rval::out, rval::out, rval::out, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred construct_livelval_rvals(set(layout_var_info)::in, + var_num_map::in, map(tvar, set(layout_locn))::in, int::out, + rval::out, rval::out, rval::out, + stack_layout_info::in, stack_layout_info::out) is det. -stack_layout__construct_livelval_rvals(LiveLvalSet, VarNumMap, TVarLocnMap, - EncodedLength, LiveValRval, NamesRval, TypeParamRval, !Info) :- - set__to_sorted_list(LiveLvalSet, LiveLvals), - stack_layout__sort_livevals(LiveLvals, SortedLiveLvals), - stack_layout__construct_liveval_arrays(SortedLiveLvals, VarNumMap, - EncodedLength, LiveValRval, NamesRval, !Info), - StaticCellInfo0 = !.Info ^ static_cell_info, - stack_layout__construct_tvar_vector(TVarLocnMap, - TypeParamRval, StaticCellInfo0, StaticCellInfo), - !:Info = !.Info ^ static_cell_info := StaticCellInfo. +construct_livelval_rvals(LiveLvalSet, VarNumMap, TVarLocnMap, + EncodedLength, LiveValRval, NamesRval, TypeParamRval, !Info) :- + set__to_sorted_list(LiveLvalSet, LiveLvals), + sort_livevals(LiveLvals, SortedLiveLvals), + construct_liveval_arrays(SortedLiveLvals, VarNumMap, + EncodedLength, LiveValRval, NamesRval, !Info), + StaticCellInfo0 = !.Info ^ static_cell_info, + construct_tvar_vector(TVarLocnMap, TypeParamRval, + StaticCellInfo0, StaticCellInfo), + !:Info = !.Info ^ static_cell_info := StaticCellInfo. -:- pred stack_layout__construct_tvar_vector(map(tvar, set(layout_locn))::in, - rval::out, static_cell_info::in, static_cell_info::out) is det. +:- pred construct_tvar_vector(map(tvar, set(layout_locn))::in, + rval::out, static_cell_info::in, static_cell_info::out) is det. -stack_layout__construct_tvar_vector(TVarLocnMap, TypeParamRval, - !StaticCellInfo) :- - ( map__is_empty(TVarLocnMap) -> - TypeParamRval = const(int_const(0)) - ; - stack_layout__construct_tvar_rvals(TVarLocnMap, Vector), - add_static_cell(Vector, DataAddr, !StaticCellInfo), - TypeParamRval = const(data_addr_const(DataAddr, no)) - ). +construct_tvar_vector(TVarLocnMap, TypeParamRval, !StaticCellInfo) :- + ( map__is_empty(TVarLocnMap) -> + TypeParamRval = const(int_const(0)) + ; + construct_tvar_rvals(TVarLocnMap, Vector), + add_static_cell(Vector, DataAddr, !StaticCellInfo), + TypeParamRval = const(data_addr_const(DataAddr, no)) + ). -:- pred stack_layout__construct_tvar_rvals(map(tvar, set(layout_locn))::in, - assoc_list(rval, llds_type)::out) is det. +:- pred construct_tvar_rvals(map(tvar, set(layout_locn))::in, + assoc_list(rval, llds_type)::out) is det. -stack_layout__construct_tvar_rvals(TVarLocnMap, Vector) :- - map__to_assoc_list(TVarLocnMap, TVarLocns), - stack_layout__construct_type_param_locn_vector(TVarLocns, 1, - TypeParamLocs), - list__length(TypeParamLocs, TypeParamsLength), - LengthRval = const(int_const(TypeParamsLength)), - Vector = [LengthRval - uint_least32 | TypeParamLocs]. +construct_tvar_rvals(TVarLocnMap, Vector) :- + map__to_assoc_list(TVarLocnMap, TVarLocns), + construct_type_param_locn_vector(TVarLocns, 1, TypeParamLocs), + list__length(TypeParamLocs, TypeParamsLength), + LengthRval = const(int_const(TypeParamsLength)), + Vector = [LengthRval - uint_least32 | TypeParamLocs]. %---------------------------------------------------------------------------% - % Given a list of layout_var_infos and the type variables that occur - % in them, select only the layout_var_infos that may be required - % by up-level printing in the trace-based debugger. At the moment - % the typeinfo list we return may be bigger than necessary, but this - % does not compromise correctness; we do this to avoid having to - % scan the types of all the selected layout_var_infos. + % Given a list of layout_var_infos and the type variables that occur + % in them, select only the layout_var_infos that may be required + % by up-level printing in the trace-based debugger. At the moment + % the typeinfo list we return may be bigger than necessary, but this + % does not compromise correctness; we do this to avoid having to + % scan the types of all the selected layout_var_infos. + % +:- pred select_trace_return( + list(layout_var_info)::in, map(tvar, set(layout_locn))::in, + list(layout_var_info)::out, map(tvar, set(layout_locn))::out) is det. -:- pred stack_layout__select_trace_return( - list(layout_var_info)::in, map(tvar, set(layout_locn))::in, - list(layout_var_info)::out, map(tvar, set(layout_locn))::out) is det. +select_trace_return(Infos, TVars, TraceReturnInfos, TVars) :- + IsNamedReturnVar = (pred(LocnInfo::in) is semidet :- + LocnInfo = layout_var_info(Locn, LvalType, _), + LvalType = var(_, Name, _, _), + Name \= "", + ( Locn = direct(Lval) ; Locn = indirect(Lval, _)), + ( Lval = stackvar(_) ; Lval = framevar(_) ) + ), + list__filter(IsNamedReturnVar, Infos, TraceReturnInfos). -stack_layout__select_trace_return(Infos, TVars, TraceReturnInfos, TVars) :- - IsNamedReturnVar = (pred(LocnInfo::in) is semidet :- - LocnInfo = layout_var_info(Locn, LvalType, _), - LvalType = var(_, Name, _, _), - Name \= "", - ( Locn = direct(Lval) ; Locn = indirect(Lval, _)), - ( Lval = stackvar(_) ; Lval = framevar(_) ) - ), - list__filter(IsNamedReturnVar, Infos, TraceReturnInfos). + % Given a list of layout_var_infos, put the ones that tracing can be + % interested in (whether at an internal port or for uplevel printing) + % in a block at the start, and both this block and the remaining + % block. The division into two blocks can make the job of the + % debugger somewhat easier, the sorting of the named var block makes + % the output of the debugger look nicer, and the sorting of the both + % blocks makes it more likely that different labels' layout structures + % will have common parts (e.g. name vectors). + % +:- pred sort_livevals(list(layout_var_info)::in, list(layout_var_info)::out) + is det. - % Given a list of layout_var_infos, put the ones that tracing can be - % interested in (whether at an internal port or for uplevel printing) - % in a block at the start, and both this block and the remaining - % block. The division into two blocks can make the job of the - % debugger somewhat easier, the sorting of the named var block makes - % the output of the debugger look nicer, and the sorting of the both - % blocks makes it more likely that different labels' layout structures - % will have common parts (e.g. name vectors). +sort_livevals(OrigInfos, FinalInfos) :- + IsNamedVar = (pred(LvalInfo::in) is semidet :- + LvalInfo = layout_var_info(_Lval, LvalType, _), + LvalType = var(_, Name, _, _), + Name \= "" + ), + list__filter(IsNamedVar, OrigInfos, NamedVarInfos0, OtherInfos0), + CompareVarInfos = (pred(Var1::in, Var2::in, Result::out) is det :- + Var1 = layout_var_info(Lval1, LiveType1, _), + Var2 = layout_var_info(Lval2, LiveType2, _), + get_name_from_live_value_type(LiveType1, Name1), + get_name_from_live_value_type(LiveType2, Name2), + compare(NameResult, Name1, Name2), + ( NameResult = (=) -> + compare(Result, Lval1, Lval2) + ; + Result = NameResult + ) + ), + list__sort(CompareVarInfos, NamedVarInfos0, NamedVarInfos), + list__sort(CompareVarInfos, OtherInfos0, OtherInfos), + list__append(NamedVarInfos, OtherInfos, FinalInfos). -:- pred stack_layout__sort_livevals(list(layout_var_info)::in, - list(layout_var_info)::out) is det. +:- pred get_name_from_live_value_type(live_value_type::in, + string::out) is det. -stack_layout__sort_livevals(OrigInfos, FinalInfos) :- - IsNamedVar = (pred(LvalInfo::in) is semidet :- - LvalInfo = layout_var_info(_Lval, LvalType, _), - LvalType = var(_, Name, _, _), - Name \= "" - ), - list__filter(IsNamedVar, OrigInfos, NamedVarInfos0, OtherInfos0), - CompareVarInfos = (pred(Var1::in, Var2::in, Result::out) is det :- - Var1 = layout_var_info(Lval1, LiveType1, _), - Var2 = layout_var_info(Lval2, LiveType2, _), - stack_layout__get_name_from_live_value_type(LiveType1, Name1), - stack_layout__get_name_from_live_value_type(LiveType2, Name2), - compare(NameResult, Name1, Name2), - ( NameResult = (=) -> - compare(Result, Lval1, Lval2) - ; - Result = NameResult - ) - ), - list__sort(CompareVarInfos, NamedVarInfos0, NamedVarInfos), - list__sort(CompareVarInfos, OtherInfos0, OtherInfos), - list__append(NamedVarInfos, OtherInfos, FinalInfos). - -:- pred stack_layout__get_name_from_live_value_type(live_value_type::in, - string::out) is det. - -stack_layout__get_name_from_live_value_type(LiveType, Name) :- - ( LiveType = var(_, NamePrime, _, _) -> - Name = NamePrime - ; - Name = "" - ). +get_name_from_live_value_type(LiveType, Name) :- + ( LiveType = var(_, NamePrime, _, _) -> + Name = NamePrime + ; + Name = "" + ). %---------------------------------------------------------------------------% - % Given a association list of type variables and their locations - % sorted on the type variables, represent them in an array of - % location descriptions indexed by the type variable. The next - % slot to fill is given by the second argument. + % Given a association list of type variables and their locations + % sorted on the type variables, represent them in an array of + % location descriptions indexed by the type variable. The next + % slot to fill is given by the second argument. + % +:- pred construct_type_param_locn_vector( + assoc_list(tvar, set(layout_locn))::in, + int::in, assoc_list(rval, llds_type)::out) is det. -:- pred stack_layout__construct_type_param_locn_vector( - assoc_list(tvar, set(layout_locn))::in, - int::in, assoc_list(rval, llds_type)::out) is det. - -stack_layout__construct_type_param_locn_vector([], _, []). -stack_layout__construct_type_param_locn_vector([TVar - Locns | TVarLocns], - CurSlot, Vector) :- - term__var_to_int(TVar, TVarNum), - NextSlot = CurSlot + 1, - ( TVarNum = CurSlot -> - ( set__remove_least(Locns, LeastLocn, _) -> - Locn = LeastLocn - ; - error("tvar has empty set of locations") - ), - stack_layout__represent_locn_as_int_rval(Locn, Rval), - stack_layout__construct_type_param_locn_vector(TVarLocns, - NextSlot, VectorTail), - Vector = [Rval - uint_least32 | VectorTail] - ; TVarNum > CurSlot -> - stack_layout__construct_type_param_locn_vector( - [TVar - Locns | TVarLocns], NextSlot, VectorTail), - % This slot will never be referred to. - Vector = [const(int_const(0)) - uint_least32 | VectorTail] - ; - error("unsorted tvars in construct_type_param_locn_vector") - ). +construct_type_param_locn_vector([], _, []). +construct_type_param_locn_vector([TVar - Locns | TVarLocns], CurSlot, + Vector) :- + term__var_to_int(TVar, TVarNum), + NextSlot = CurSlot + 1, + ( TVarNum = CurSlot -> + ( set__remove_least(Locns, LeastLocn, _) -> + Locn = LeastLocn + ; + error("tvar has empty set of locations") + ), + represent_locn_as_int_rval(Locn, Rval), + construct_type_param_locn_vector(TVarLocns, NextSlot, VectorTail), + Vector = [Rval - uint_least32 | VectorTail] + ; TVarNum > CurSlot -> + construct_type_param_locn_vector([TVar - Locns | TVarLocns], NextSlot, + VectorTail), + % This slot will never be referred to. + Vector = [const(int_const(0)) - uint_least32 | VectorTail] + ; + error("unsorted tvars in construct_type_param_locn_vector") + ). %---------------------------------------------------------------------------% :- type liveval_array_info - ---> live_array_info( - rval, % Rval describing the location of a live value. - % Always of llds type uint_least8 if the cell - % is in the byte array, and uint_least32 if it - % is in the int array. - rval, % Rval describing the type of a live value. - llds_type, % The llds type of the rval describing the - % type. - rval % Rval describing the variable number of a - % live value. Always of llds type uint_least16. - % Contains zero if the live value is not - % a variable. Contains the hightest possible - % uint_least16 value if the variable number - % does not fit in 16 bits. - ). + ---> live_array_info( + rval, % Rval describing the location of a live value. + % Always of llds type uint_least8 if the cell + % is in the byte array, and uint_least32 if it + % is in the int array. + rval, % Rval describing the type of a live value. + llds_type, % The llds type of the rval describing the type. + rval % Rval describing the variable number of a + % live value. Always of llds type uint_least16. + % Contains zero if the live value is not + % a variable. Contains the hightest possible + % uint_least16 value if the variable number + % does not fit in 16 bits. + ). - % Construct a vector of (locn, live_value_type) pairs, - % and a corresponding vector of variable names. + % Construct a vector of (locn, live_value_type) pairs, + % and a corresponding vector of variable names. + % +:- pred construct_liveval_arrays(list(layout_var_info)::in, + var_num_map::in, int::out, rval::out, rval::out, + stack_layout_info::in, stack_layout_info::out) is det. -:- pred stack_layout__construct_liveval_arrays(list(layout_var_info)::in, - var_num_map::in, int::out, rval::out, rval::out, - stack_layout_info::in, stack_layout_info::out) is det. +construct_liveval_arrays(VarInfos, VarNumMap, EncodedLength, + TypeLocnVector, NumVector, !Info) :- + int__pow(2, short_count_bits, BytesLimit), + construct_liveval_array_infos(VarInfos, VarNumMap, + 0, BytesLimit, IntArrayInfo, ByteArrayInfo, !Info), -stack_layout__construct_liveval_arrays(VarInfos, VarNumMap, EncodedLength, - TypeLocnVector, NumVector, !Info) :- - int__pow(2, stack_layout__short_count_bits, BytesLimit), - stack_layout__construct_liveval_array_infos(VarInfos, VarNumMap, - 0, BytesLimit, IntArrayInfo, ByteArrayInfo, !Info), + list__length(IntArrayInfo, IntArrayLength), + list__length(ByteArrayInfo, ByteArrayLength), + list__append(IntArrayInfo, ByteArrayInfo, AllArrayInfo), - list__length(IntArrayInfo, IntArrayLength), - list__length(ByteArrayInfo, ByteArrayLength), - list__append(IntArrayInfo, ByteArrayInfo, AllArrayInfo), + EncodedLength = IntArrayLength << short_count_bits + ByteArrayLength, - EncodedLength = IntArrayLength << stack_layout__short_count_bits - + ByteArrayLength, + SelectLocns = (pred(ArrayInfo::in, LocnRval::out) is det :- + ArrayInfo = live_array_info(LocnRval, _, _, _) + ), + SelectTypes = (pred(ArrayInfo::in, TypeRval - TypeType::out) is det :- + ArrayInfo = live_array_info(_, TypeRval, TypeType, _) + ), + AddRevNums = (pred(ArrayInfo::in, NumRvals0::in, NumRvals::out) is det :- + ArrayInfo = live_array_info(_, _, _, NumRval), + NumRvals = [NumRval | NumRvals0] + ), - SelectLocns = (pred(ArrayInfo::in, LocnRval::out) is det :- - ArrayInfo = live_array_info(LocnRval, _, _, _) - ), - SelectTypes = (pred(ArrayInfo::in, TypeRval - TypeType::out) is det :- - ArrayInfo = live_array_info(_, TypeRval, TypeType, _) - ), - AddRevNums = (pred(ArrayInfo::in, NumRvals0::in, NumRvals::out) - is det :- - ArrayInfo = live_array_info(_, _, _, NumRval), - NumRvals = [NumRval | NumRvals0] - ), + list__map(SelectTypes, AllArrayInfo, AllTypeRvalsTypes), + list__map(SelectLocns, IntArrayInfo, IntLocns), + list__map(associate_type(uint_least32), IntLocns, IntLocnsTypes), + list__map(SelectLocns, ByteArrayInfo, ByteLocns), + list__map(associate_type(uint_least8), ByteLocns, ByteLocnsTypes), + list__append(IntLocnsTypes, ByteLocnsTypes, AllLocnsTypes), + list__append(AllTypeRvalsTypes, AllLocnsTypes, TypeLocnVectorRvalsTypes), + get_static_cell_info(!.Info, StaticCellInfo0), + add_static_cell(TypeLocnVectorRvalsTypes, TypeLocnVectorAddr, + StaticCellInfo0, StaticCellInfo1), + TypeLocnVector = const(data_addr_const(TypeLocnVectorAddr, no)), + set_static_cell_info(StaticCellInfo1, !Info), - list__map(SelectTypes, AllArrayInfo, AllTypeRvalsTypes), - list__map(SelectLocns, IntArrayInfo, IntLocns), - list__map(associate_type(uint_least32), IntLocns, IntLocnsTypes), - list__map(SelectLocns, ByteArrayInfo, ByteLocns), - list__map(associate_type(uint_least8), ByteLocns, ByteLocnsTypes), - list__append(IntLocnsTypes, ByteLocnsTypes, AllLocnsTypes), - list__append(AllTypeRvalsTypes, AllLocnsTypes, - TypeLocnVectorRvalsTypes), - stack_layout__get_static_cell_info(!.Info, StaticCellInfo0), - add_static_cell(TypeLocnVectorRvalsTypes, TypeLocnVectorAddr, - StaticCellInfo0, StaticCellInfo1), - TypeLocnVector = const(data_addr_const(TypeLocnVectorAddr, no)), - stack_layout__set_static_cell_info(StaticCellInfo1, !Info), - - stack_layout__get_trace_stack_layout(!.Info, TraceStackLayout), - ( - TraceStackLayout = yes, - list__foldl(AddRevNums, AllArrayInfo, - [], RevVarNumRvals), - list__reverse(RevVarNumRvals, VarNumRvals), - list__map(associate_type(uint_least16), VarNumRvals, - VarNumRvalsTypes), - stack_layout__get_static_cell_info(!.Info, StaticCellInfo2), - add_static_cell(VarNumRvalsTypes, NumVectorAddr, - StaticCellInfo2, StaticCellInfo), - stack_layout__set_static_cell_info(StaticCellInfo, !Info), - NumVector = const(data_addr_const(NumVectorAddr, no)) - ; - TraceStackLayout = no, - NumVector = const(int_const(0)) - ). + get_trace_stack_layout(!.Info, TraceStackLayout), + ( + TraceStackLayout = yes, + list__foldl(AddRevNums, AllArrayInfo, [], RevVarNumRvals), + list__reverse(RevVarNumRvals, VarNumRvals), + list__map(associate_type(uint_least16), VarNumRvals, VarNumRvalsTypes), + get_static_cell_info(!.Info, StaticCellInfo2), + add_static_cell(VarNumRvalsTypes, NumVectorAddr, + StaticCellInfo2, StaticCellInfo), + set_static_cell_info(StaticCellInfo, !Info), + NumVector = const(data_addr_const(NumVectorAddr, no)) + ; + TraceStackLayout = no, + NumVector = const(int_const(0)) + ). :- pred associate_type(llds_type::in, rval::in, pair(rval, llds_type)::out) - is det. + is det. associate_type(LldsType, Rval, Rval - LldsType). -:- pred stack_layout__construct_liveval_array_infos(list(layout_var_info)::in, - var_num_map::in, int::in, int::in, - list(liveval_array_info)::out, list(liveval_array_info)::out, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred construct_liveval_array_infos(list(layout_var_info)::in, + var_num_map::in, int::in, int::in, + list(liveval_array_info)::out, list(liveval_array_info)::out, + stack_layout_info::in, stack_layout_info::out) is det. -stack_layout__construct_liveval_array_infos([], _, _, _, [], [], !Info). -stack_layout__construct_liveval_array_infos([VarInfo | VarInfos], VarNumMap, - BytesSoFar, BytesLimit, IntVars, ByteVars, !Info) :- - VarInfo = layout_var_info(Locn, LiveValueType, _), - stack_layout__represent_live_value_type(LiveValueType, TypeRval, - TypeRvalType, !Info), - stack_layout__construct_liveval_num_rval(VarNumMap, VarInfo, - VarNumRval, !Info), - ( - LiveValueType = var(_, _, Type, _), - stack_layout__get_module_info(!.Info, ModuleInfo), - is_dummy_argument_type(ModuleInfo, Type), - % We want to preserve I/O states in registers - \+ ( - Locn = direct(reg(_, _)) - ) - -> - error("construct_liveval_array_infos: " ++ - "unexpected reference to dummy value") - ; - BytesSoFar < BytesLimit, - stack_layout__represent_locn_as_byte(Locn, LocnByteRval) - -> - Var = live_array_info(LocnByteRval, TypeRval, TypeRvalType, - VarNumRval), - stack_layout__construct_liveval_array_infos(VarInfos, - VarNumMap, BytesSoFar + 1, BytesLimit, - IntVars, ByteVars0, !Info), - ByteVars = [Var | ByteVars0] - ; - stack_layout__represent_locn_as_int_rval(Locn, LocnRval), - Var = live_array_info(LocnRval, TypeRval, TypeRvalType, - VarNumRval), - stack_layout__construct_liveval_array_infos(VarInfos, - VarNumMap, BytesSoFar, BytesLimit, - IntVars0, ByteVars, !Info), - IntVars = [Var | IntVars0] - ). +construct_liveval_array_infos([], _, _, _, [], [], !Info). +construct_liveval_array_infos([VarInfo | VarInfos], VarNumMap, + BytesSoFar, BytesLimit, IntVars, ByteVars, !Info) :- + VarInfo = layout_var_info(Locn, LiveValueType, _), + represent_live_value_type(LiveValueType, TypeRval, TypeRvalType, !Info), + construct_liveval_num_rval(VarNumMap, VarInfo, VarNumRval, !Info), + ( + LiveValueType = var(_, _, Type, _), + get_module_info(!.Info, ModuleInfo), + is_dummy_argument_type(ModuleInfo, Type), + % We want to preserve I/O states in registers + \+ ( + Locn = direct(reg(_, _)) + ) + -> + error("construct_liveval_array_infos: " ++ + "unexpected reference to dummy value") + ; + BytesSoFar < BytesLimit, + represent_locn_as_byte(Locn, LocnByteRval) + -> + Var = live_array_info(LocnByteRval, TypeRval, TypeRvalType, + VarNumRval), + construct_liveval_array_infos(VarInfos, VarNumMap, + BytesSoFar + 1, BytesLimit, IntVars, ByteVars0, !Info), + ByteVars = [Var | ByteVars0] + ; + represent_locn_as_int_rval(Locn, LocnRval), + Var = live_array_info(LocnRval, TypeRval, TypeRvalType, VarNumRval), + construct_liveval_array_infos(VarInfos, VarNumMap, + BytesSoFar, BytesLimit, IntVars0, ByteVars, !Info), + IntVars = [Var | IntVars0] + ). -:- pred stack_layout__construct_liveval_num_rval(var_num_map::in, - layout_var_info::in, rval::out, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred construct_liveval_num_rval(var_num_map::in, + layout_var_info::in, rval::out, + stack_layout_info::in, stack_layout_info::out) is det. -stack_layout__construct_liveval_num_rval(VarNumMap, - layout_var_info(_, LiveValueType, _), VarNumRval, !Info) :- - ( LiveValueType = var(Var, _, _, _) -> - stack_layout__convert_var_to_int(VarNumMap, Var, VarNum), - VarNumRval = const(int_const(VarNum)) - ; - VarNumRval = const(int_const(0)) - ). +construct_liveval_num_rval(VarNumMap, + layout_var_info(_, LiveValueType, _), VarNumRval, !Info) :- + ( LiveValueType = var(Var, _, _, _) -> + convert_var_to_int(VarNumMap, Var, VarNum), + VarNumRval = const(int_const(VarNum)) + ; + VarNumRval = const(int_const(0)) + ). -:- pred stack_layout__convert_var_to_int(var_num_map::in, prog_var::in, - int::out) is det. +:- pred convert_var_to_int(var_num_map::in, prog_var::in, + int::out) is det. -stack_layout__convert_var_to_int(VarNumMap, Var, VarNum) :- - map__lookup(VarNumMap, Var, VarNum0 - _), - % The variable number has to fit into two bytes. - % We reserve the largest such number (Limit) - % to mean that the variable number is too large - % to be represented. This ought not to happen, - % since compilation would be glacial at best - % for procedures with that many variables. - Limit = (1 << (2 * stack_layout__byte_bits)) - 1, - int__min(VarNum0, Limit, VarNum). +convert_var_to_int(VarNumMap, Var, VarNum) :- + map__lookup(VarNumMap, Var, VarNum0 - _), + % The variable number has to fit into two bytes. We reserve the largest + % such number (Limit) to mean that the variable number is too large + % to be represented. This ought not to happen, since compilation + % would be glacial at best for procedures with that many variables. + Limit = (1 << (2 * byte_bits)) - 1, + int__min(VarNum0, Limit, VarNum). %---------------------------------------------------------------------------% - % The representation we build here should be kept in sync - % with runtime/mercury_ho_call.h, which contains macros to access - % the data structures we build here. + % The representation we build here should be kept in sync + % with runtime/mercury_ho_call.h, which contains macros to access + % the data structures we build here. + % +construct_closure_layout(CallerProcLabel, SeqNo, + ClosureLayoutInfo, ClosureProcLabel, ModuleName, + FileName, LineNumber, Origin, GoalPath, !StaticCellInfo, + RvalsTypes, Data) :- + DataAddr = layout_addr( + closure_proc_id(CallerProcLabel, SeqNo, ClosureProcLabel)), + Data = layout_data(closure_proc_id_data(CallerProcLabel, SeqNo, + ClosureProcLabel, ModuleName, FileName, LineNumber, Origin, + GoalPath)), + ProcIdRvalType = const(data_addr_const(DataAddr, no)) - data_ptr, + ClosureLayoutInfo = closure_layout_info(ClosureArgs, TVarLocnMap), + construct_closure_arg_rvals(ClosureArgs, + ClosureArgRvalsTypes, !StaticCellInfo), + construct_tvar_vector(TVarLocnMap, TVarVectorRval, !StaticCellInfo), + RvalsTypes = [ProcIdRvalType, TVarVectorRval - data_ptr | + ClosureArgRvalsTypes]. -stack_layout__construct_closure_layout(CallerProcLabel, SeqNo, - ClosureLayoutInfo, ClosureProcLabel, ModuleName, - FileName, LineNumber, Origin, GoalPath, !StaticCellInfo, - RvalsTypes, Data) :- - DataAddr = layout_addr( - closure_proc_id(CallerProcLabel, SeqNo, ClosureProcLabel)), - Data = layout_data(closure_proc_id_data(CallerProcLabel, SeqNo, - ClosureProcLabel, ModuleName, FileName, LineNumber, Origin, - GoalPath)), - ProcIdRvalType = const(data_addr_const(DataAddr, no)) - data_ptr, - ClosureLayoutInfo = closure_layout_info(ClosureArgs, TVarLocnMap), - stack_layout__construct_closure_arg_rvals(ClosureArgs, - ClosureArgRvalsTypes, !StaticCellInfo), - stack_layout__construct_tvar_vector(TVarLocnMap, TVarVectorRval, - !StaticCellInfo), - RvalsTypes = [ProcIdRvalType, TVarVectorRval - data_ptr | - ClosureArgRvalsTypes]. +:- pred construct_closure_arg_rvals(list(closure_arg_info)::in, + assoc_list(rval, llds_type)::out, + static_cell_info::in, static_cell_info::out) is det. -:- pred stack_layout__construct_closure_arg_rvals(list(closure_arg_info)::in, - assoc_list(rval, llds_type)::out, - static_cell_info::in, static_cell_info::out) is det. +construct_closure_arg_rvals(ClosureArgs, ClosureArgRvalsTypes, + !StaticCellInfo) :- + list__map_foldl(construct_closure_arg_rval, ClosureArgs, ArgRvalsTypes, + !StaticCellInfo), + list__length(ArgRvalsTypes, Length), + ClosureArgRvalsTypes = + [const(int_const(Length)) - integer | ArgRvalsTypes]. -stack_layout__construct_closure_arg_rvals(ClosureArgs, ClosureArgRvalsTypes, - !StaticCellInfo) :- - list__map_foldl(stack_layout__construct_closure_arg_rval, - ClosureArgs, ArgRvalsTypes, !StaticCellInfo), - list__length(ArgRvalsTypes, Length), - ClosureArgRvalsTypes = - [const(int_const(Length)) - integer | ArgRvalsTypes]. +:- pred construct_closure_arg_rval(closure_arg_info::in, + pair(rval, llds_type)::out, + static_cell_info::in, static_cell_info::out) is det. -:- pred stack_layout__construct_closure_arg_rval(closure_arg_info::in, - pair(rval, llds_type)::out, - static_cell_info::in, static_cell_info::out) is det. - -stack_layout__construct_closure_arg_rval(ClosureArg, ArgRval - ArgRvalType, - !StaticCellInfo) :- - ClosureArg = closure_arg_info(Type, _Inst), - % For a stack layout, we can treat all type variables as - % universally quantified. This is not the argument of a - % constructor, so we do not need to distinguish between type - % variables that are and aren't in scope; we can take the - % variable number directly from the procedure's tvar set. - ExistQTvars = [], - NumUnivQTvars = -1, - ll_pseudo_type_info__construct_typed_llds_pseudo_type_info(Type, - NumUnivQTvars, ExistQTvars, !StaticCellInfo, - ArgRval, ArgRvalType). +construct_closure_arg_rval(ClosureArg, ArgRval - ArgRvalType, + !StaticCellInfo) :- + ClosureArg = closure_arg_info(Type, _Inst), + % For a stack layout, we can treat all type variables as universally + % quantified. This is not the argument of a constructor, so we do not need + % to distinguish between type variables that are and aren't in scope; + % we can take the variable number directly from the procedure's tvar set. + ExistQTvars = [], + NumUnivQTvars = -1, + ll_pseudo_type_info__construct_typed_llds_pseudo_type_info(Type, + NumUnivQTvars, ExistQTvars, !StaticCellInfo, ArgRval, ArgRvalType). %---------------------------------------------------------------------------% -:- pred stack_layout__make_table_data(rtti_proc_label::in, - proc_layout_kind::in, proc_table_info::in, layout_data::out, - static_cell_info::in, static_cell_info::out) is det. +:- pred make_table_data(rtti_proc_label::in, + proc_layout_kind::in, proc_table_info::in, layout_data::out, + static_cell_info::in, static_cell_info::out) is det. -stack_layout__make_table_data(RttiProcLabel, Kind, TableInfo, TableData, - !StaticCellInfo) :- - ( - TableInfo = table_io_decl_info(TableArgInfo), - stack_layout__convert_table_arg_info(TableArgInfo, - NumPTIs, PTIVectorRval, TVarVectorRval, - !StaticCellInfo), - TableData = table_io_decl_data(RttiProcLabel, Kind, - NumPTIs, PTIVectorRval, TVarVectorRval) - ; - TableInfo = table_gen_info(NumInputs, NumOutputs, Steps, - TableArgInfo), - stack_layout__convert_table_arg_info(TableArgInfo, - NumPTIs, PTIVectorRval, TVarVectorRval, - !StaticCellInfo), - NumArgs = NumInputs + NumOutputs, - require(unify(NumArgs, NumPTIs), - "stack_layout__make_table_data: args mismatch"), - TableData = table_gen_data(RttiProcLabel, - NumInputs, NumOutputs, Steps, - PTIVectorRval, TVarVectorRval) - ). +make_table_data(RttiProcLabel, Kind, TableInfo, TableData, + !StaticCellInfo) :- + ( + TableInfo = table_io_decl_info(TableArgInfo), + convert_table_arg_info(TableArgInfo, NumPTIs, PTIVectorRval, + TVarVectorRval, !StaticCellInfo), + TableData = table_io_decl_data(RttiProcLabel, Kind, + NumPTIs, PTIVectorRval, TVarVectorRval) + ; + TableInfo = table_gen_info(NumInputs, NumOutputs, Steps, + TableArgInfo), + convert_table_arg_info(TableArgInfo, NumPTIs, PTIVectorRval, + TVarVectorRval, !StaticCellInfo), + NumArgs = NumInputs + NumOutputs, + require(unify(NumArgs, NumPTIs), "make_table_data: args mismatch"), + TableData = table_gen_data(RttiProcLabel, NumInputs, NumOutputs, Steps, + PTIVectorRval, TVarVectorRval) + ). -:- pred stack_layout__convert_table_arg_info(table_arg_infos::in, - int::out, rval::out, rval::out, - static_cell_info::in, static_cell_info::out) is det. +:- pred convert_table_arg_info(table_arg_infos::in, + int::out, rval::out, rval::out, + static_cell_info::in, static_cell_info::out) is det. -stack_layout__convert_table_arg_info(TableArgInfos, NumPTIs, - PTIVectorRval, TVarVectorRval, !StaticCellInfo) :- - TableArgInfos = table_arg_infos(Args, TVarSlotMap), - list__length(Args, NumPTIs), - list__map_foldl(stack_layout__construct_table_arg_pti_rval, - Args, PTIRvalsTypes, !StaticCellInfo), - add_static_cell(PTIRvalsTypes, PTIVectorAddr, !StaticCellInfo), - PTIVectorRval = const(data_addr_const(PTIVectorAddr, no)), - map__map_values(stack_layout__convert_slot_to_locn_map, - TVarSlotMap, TVarLocnMap), - stack_layout__construct_tvar_vector(TVarLocnMap, TVarVectorRval, - !StaticCellInfo). +convert_table_arg_info(TableArgInfos, NumPTIs, + PTIVectorRval, TVarVectorRval, !StaticCellInfo) :- + TableArgInfos = table_arg_infos(Args, TVarSlotMap), + list__length(Args, NumPTIs), + list__map_foldl(construct_table_arg_pti_rval, Args, PTIRvalsTypes, + !StaticCellInfo), + add_static_cell(PTIRvalsTypes, PTIVectorAddr, !StaticCellInfo), + PTIVectorRval = const(data_addr_const(PTIVectorAddr, no)), + map__map_values(convert_slot_to_locn_map, TVarSlotMap, TVarLocnMap), + construct_tvar_vector(TVarLocnMap, TVarVectorRval, !StaticCellInfo). -:- pred stack_layout__convert_slot_to_locn_map(tvar::in, table_locn::in, - set(layout_locn)::out) is det. +:- pred convert_slot_to_locn_map(tvar::in, table_locn::in, + set(layout_locn)::out) is det. -stack_layout__convert_slot_to_locn_map(_TVar, SlotLocn, LvalLocns) :- - ( - SlotLocn = direct(SlotNum), - LvalLocn = direct(reg(r, SlotNum)) - ; - SlotLocn = indirect(SlotNum, Offset), - LvalLocn = indirect(reg(r, SlotNum), Offset) - ), - LvalLocns = set__make_singleton_set(LvalLocn). +convert_slot_to_locn_map(_TVar, SlotLocn, LvalLocns) :- + ( + SlotLocn = direct(SlotNum), + LvalLocn = direct(reg(r, SlotNum)) + ; + SlotLocn = indirect(SlotNum, Offset), + LvalLocn = indirect(reg(r, SlotNum), Offset) + ), + LvalLocns = set__make_singleton_set(LvalLocn). -:- pred stack_layout__construct_table_arg_pti_rval( - table_arg_info::in, pair(rval, llds_type)::out, - static_cell_info::in, static_cell_info::out) is det. +:- pred construct_table_arg_pti_rval( + table_arg_info::in, pair(rval, llds_type)::out, + static_cell_info::in, static_cell_info::out) is det. -stack_layout__construct_table_arg_pti_rval(ClosureArg, - ArgRval - ArgRvalType, !StaticCellInfo) :- - ClosureArg = table_arg_info(_, _, Type), - ExistQTvars = [], - NumUnivQTvars = -1, - ll_pseudo_type_info__construct_typed_llds_pseudo_type_info(Type, - NumUnivQTvars, ExistQTvars, !StaticCellInfo, - ArgRval, ArgRvalType). +construct_table_arg_pti_rval(ClosureArg, ArgRval - ArgRvalType, + !StaticCellInfo) :- + ClosureArg = table_arg_info(_, _, Type), + ExistQTvars = [], + NumUnivQTvars = -1, + ll_pseudo_type_info__construct_typed_llds_pseudo_type_info(Type, + NumUnivQTvars, ExistQTvars, !StaticCellInfo, ArgRval, ArgRvalType). %---------------------------------------------------------------------------% - % Construct a representation of the type of a value. - % - % For values representing variables, this will be a pseudo_type_info - % describing the type of the variable. - % - % For the kinds of values used internally by the compiler, - % this will be a pointer to a specific type_ctor_info (acting as a - % type_info) defined by hand in builtin.m to stand for values of - % each such kind; one for succips, one for hps, etc. + % Construct a representation of the type of a value. + % + % For values representing variables, this will be a pseudo_type_info + % describing the type of the variable. + % + % For the kinds of values used internally by the compiler, + % this will be a pointer to a specific type_ctor_info (acting as a + % type_info) defined by hand in builtin.m to stand for values of + % each such kind; one for succips, one for hps, etc. + % +:- pred represent_live_value_type(live_value_type::in, rval::out, + llds_type::out, stack_layout_info::in, stack_layout_info::out) is det. -:- pred stack_layout__represent_live_value_type(live_value_type::in, rval::out, - llds_type::out, stack_layout_info::in, stack_layout_info::out) is det. +represent_live_value_type(succip, Rval, data_ptr, !Info) :- + represent_special_live_value_type("succip", Rval). +represent_live_value_type(hp, Rval, data_ptr, !Info) :- + represent_special_live_value_type("hp", Rval). +represent_live_value_type(curfr, Rval, data_ptr, !Info) :- + represent_special_live_value_type("curfr", Rval). +represent_live_value_type(maxfr, Rval, data_ptr, !Info) :- + represent_special_live_value_type("maxfr", Rval). +represent_live_value_type(redofr, Rval, data_ptr, !Info) :- + represent_special_live_value_type("redofr", Rval). +represent_live_value_type(redoip, Rval, data_ptr, !Info) :- + represent_special_live_value_type("redoip", Rval). +represent_live_value_type(trail_ptr, Rval, data_ptr, !Info) :- + represent_special_live_value_type("trail_ptr", Rval). +represent_live_value_type(ticket, Rval, data_ptr, !Info) :- + represent_special_live_value_type("ticket", Rval). +represent_live_value_type(unwanted, Rval, data_ptr, !Info) :- + represent_special_live_value_type("unwanted", Rval). +represent_live_value_type(var(_, _, Type, _), Rval, LldsType, !Info) :- + % For a stack layout, we can treat all type variables as universally + % quantified. This is not the argument of a constructor, so we do not + % need to distinguish between type variables that are and aren't in scope; + % we can take the variable number directly from the procedure's tvar set. + ExistQTvars = [], + NumUnivQTvars = -1, + get_static_cell_info(!.Info, StaticCellInfo0), + ll_pseudo_type_info__construct_typed_llds_pseudo_type_info(Type, + NumUnivQTvars, ExistQTvars, StaticCellInfo0, StaticCellInfo, + Rval, LldsType), + set_static_cell_info(StaticCellInfo, !Info). -stack_layout__represent_live_value_type(succip, Rval, data_ptr, !Info) :- - stack_layout__represent_special_live_value_type("succip", Rval). -stack_layout__represent_live_value_type(hp, Rval, data_ptr, !Info) :- - stack_layout__represent_special_live_value_type("hp", Rval). -stack_layout__represent_live_value_type(curfr, Rval, data_ptr, !Info) :- - stack_layout__represent_special_live_value_type("curfr", Rval). -stack_layout__represent_live_value_type(maxfr, Rval, data_ptr, !Info) :- - stack_layout__represent_special_live_value_type("maxfr", Rval). -stack_layout__represent_live_value_type(redofr, Rval, data_ptr, !Info) :- - stack_layout__represent_special_live_value_type("redofr", Rval). -stack_layout__represent_live_value_type(redoip, Rval, data_ptr, !Info) :- - stack_layout__represent_special_live_value_type("redoip", Rval). -stack_layout__represent_live_value_type(trail_ptr, Rval, data_ptr, !Info) :- - stack_layout__represent_special_live_value_type("trail_ptr", Rval). -stack_layout__represent_live_value_type(ticket, Rval, data_ptr, !Info) :- - stack_layout__represent_special_live_value_type("ticket", Rval). -stack_layout__represent_live_value_type(unwanted, Rval, data_ptr, !Info) :- - stack_layout__represent_special_live_value_type("unwanted", Rval). -stack_layout__represent_live_value_type(var(_, _, Type, _), Rval, LldsType, - !Info) :- - % For a stack layout, we can treat all type variables as - % universally quantified. This is not the argument of a - % constructor, so we do not need to distinguish between type - % variables that are and aren't in scope; we can take the - % variable number directly from the procedure's tvar set. - ExistQTvars = [], - NumUnivQTvars = -1, - stack_layout__get_static_cell_info(!.Info, StaticCellInfo0), - ll_pseudo_type_info__construct_typed_llds_pseudo_type_info(Type, - NumUnivQTvars, ExistQTvars, StaticCellInfo0, StaticCellInfo, - Rval, LldsType), - stack_layout__set_static_cell_info(StaticCellInfo, !Info). +:- pred represent_special_live_value_type(string::in, rval::out) + is det. -:- pred stack_layout__represent_special_live_value_type(string::in, rval::out) - is det. - -stack_layout__represent_special_live_value_type(SpecialTypeName, Rval) :- - RttiTypeCtor = rtti_type_ctor(unqualified(""), SpecialTypeName, 0), - DataAddr = rtti_addr(ctor_rtti_id(RttiTypeCtor, type_ctor_info)), - Rval = const(data_addr_const(DataAddr, no)). +represent_special_live_value_type(SpecialTypeName, Rval) :- + RttiTypeCtor = rtti_type_ctor(unqualified(""), SpecialTypeName, 0), + DataAddr = rtti_addr(ctor_rtti_id(RttiTypeCtor, type_ctor_info)), + Rval = const(data_addr_const(DataAddr, no)). %---------------------------------------------------------------------------% - % Construct a representation of a variable location as a 32-bit - % integer. - % - % Most of the time, a layout specifies a location as an lval. - % However, a type_info variable may be hidden inside a typeclass_info, - % In this case, accessing the type_info requires indirection. - % The address of the typeclass_info is given as an lval, and - % the location of the typeinfo within the typeclass_info as an index; - % private_builtin.type_info_from_typeclass_info interprets the index. - % - % This one level of indirection is sufficient, since type_infos - % cannot be nested inside typeclass_infos any deeper than this. - % A more general representation that would allow more indirection - % would be much harder to fit into one machine word. + % Construct a representation of a variable location as a 32-bit + % integer. + % + % Most of the time, a layout specifies a location as an lval. + % However, a type_info variable may be hidden inside a typeclass_info, + % In this case, accessing the type_info requires indirection. + % The address of the typeclass_info is given as an lval, and + % the location of the typeinfo within the typeclass_info as an index; + % private_builtin.type_info_from_typeclass_info interprets the index. + % + % This one level of indirection is sufficient, since type_infos + % cannot be nested inside typeclass_infos any deeper than this. + % A more general representation that would allow more indirection + % would be much harder to fit into one machine word. + % +:- pred represent_locn_as_int_rval(layout_locn::in, rval::out) is det. -:- pred stack_layout__represent_locn_as_int_rval(layout_locn::in, rval::out) - is det. +represent_locn_as_int_rval(Locn, Rval) :- + represent_locn_as_int(Locn, Word), + Rval = const(int_const(Word)). -stack_layout__represent_locn_as_int_rval(Locn, Rval) :- - stack_layout__represent_locn_as_int(Locn, Word), - Rval = const(int_const(Word)). +represent_locn_as_int(direct(Lval), Word) :- + represent_lval(Lval, Word). +represent_locn_as_int(indirect(Lval, Offset), Word) :- + represent_lval(Lval, BaseWord), + require((1 << long_lval_offset_bits) > Offset, + "represent_locn: offset too large to be represented"), + BaseAndOffset is (BaseWord << long_lval_offset_bits) + Offset, + make_tagged_word(lval_indirect, BaseAndOffset, Word). -stack_layout__represent_locn_as_int(direct(Lval), Word) :- - stack_layout__represent_lval(Lval, Word). -stack_layout__represent_locn_as_int(indirect(Lval, Offset), Word) :- - stack_layout__represent_lval(Lval, BaseWord), - require((1 << stack_layout__long_lval_offset_bits) > Offset, - "stack_layout__represent_locn: offset too large to be represented"), - BaseAndOffset is (BaseWord << stack_layout__long_lval_offset_bits) - + Offset, - stack_layout__make_tagged_word(lval_indirect, BaseAndOffset, Word). + % Construct a four byte representation of an lval. + % +:- pred represent_lval(lval::in, int::out) is det. - % Construct a four byte representation of an lval. +represent_lval(reg(r, Num), Word) :- + make_tagged_word(lval_r_reg, Num, Word). +represent_lval(reg(f, Num), Word) :- + make_tagged_word(lval_f_reg, Num, Word). +represent_lval(stackvar(Num), Word) :- + require(Num > 0, "represent_lval: bad stackvar"), + make_tagged_word(lval_stackvar, Num, Word). +represent_lval(framevar(Num), Word) :- + require(Num > 0, "represent_lval: bad framevar"), + make_tagged_word(lval_framevar, Num, Word). +represent_lval(succip, Word) :- + make_tagged_word(lval_succip, 0, Word). +represent_lval(maxfr, Word) :- + make_tagged_word(lval_maxfr, 0, Word). +represent_lval(curfr, Word) :- + make_tagged_word(lval_curfr, 0, Word). +represent_lval(hp, Word) :- + make_tagged_word(lval_hp, 0, Word). +represent_lval(sp, Word) :- + make_tagged_word(lval_sp, 0, Word). -:- pred stack_layout__represent_lval(lval::in, int::out) is det. +represent_lval(temp(_, _), _) :- + error("stack_layout: continuation live value stored in temp register"). -stack_layout__represent_lval(reg(r, Num), Word) :- - stack_layout__make_tagged_word(lval_r_reg, Num, Word). -stack_layout__represent_lval(reg(f, Num), Word) :- - stack_layout__make_tagged_word(lval_f_reg, Num, Word). -stack_layout__represent_lval(stackvar(Num), Word) :- - require(Num > 0, "stack_layout__represent_lval: bad stackvar"), - stack_layout__make_tagged_word(lval_stackvar, Num, Word). -stack_layout__represent_lval(framevar(Num), Word) :- - require(Num > 0, "stack_layout__represent_lval: bad framevar"), - stack_layout__make_tagged_word(lval_framevar, Num, Word). -stack_layout__represent_lval(succip, Word) :- - stack_layout__make_tagged_word(lval_succip, 0, Word). -stack_layout__represent_lval(maxfr, Word) :- - stack_layout__make_tagged_word(lval_maxfr, 0, Word). -stack_layout__represent_lval(curfr, Word) :- - stack_layout__make_tagged_word(lval_curfr, 0, Word). -stack_layout__represent_lval(hp, Word) :- - stack_layout__make_tagged_word(lval_hp, 0, Word). -stack_layout__represent_lval(sp, Word) :- - stack_layout__make_tagged_word(lval_sp, 0, Word). +represent_lval(succip(_), _) :- + error("stack_layout: continuation live value stored in fixed slot"). +represent_lval(redoip(_), _) :- + error("stack_layout: continuation live value stored in fixed slot"). +represent_lval(redofr(_), _) :- + error("stack_layout: continuation live value stored in fixed slot"). +represent_lval(succfr(_), _) :- + error("stack_layout: continuation live value stored in fixed slot"). +represent_lval(prevfr(_), _) :- + error("stack_layout: continuation live value stored in fixed slot"). -stack_layout__represent_lval(temp(_, _), _) :- - error("stack_layout: continuation live value stored in temp register"). +represent_lval(field(_, _, _), _) :- + error("stack_layout: continuation live value stored in field"). +represent_lval(mem_ref(_), _) :- + error("stack_layout: continuation live value stored in mem_ref"). +represent_lval(lvar(_), _) :- + error("stack_layout: continuation live value stored in lvar"). -stack_layout__represent_lval(succip(_), _) :- - error("stack_layout: continuation live value stored in fixed slot"). -stack_layout__represent_lval(redoip(_), _) :- - error("stack_layout: continuation live value stored in fixed slot"). -stack_layout__represent_lval(redofr(_), _) :- - error("stack_layout: continuation live value stored in fixed slot"). -stack_layout__represent_lval(succfr(_), _) :- - error("stack_layout: continuation live value stored in fixed slot"). -stack_layout__represent_lval(prevfr(_), _) :- - error("stack_layout: continuation live value stored in fixed slot"). + % Some things in this module are encoded using a low tag. + % This is not done using the normal compiler mkword, but by + % doing the bit shifting here. + % + % This allows us to use more than the usual 2 or 3 bits, but + % we have to use low tags and cannot tag pointers this way. + % +:- pred make_tagged_word(locn_type::in, int::in, int::out) is det. -stack_layout__represent_lval(field(_, _, _), _) :- - error("stack_layout: continuation live value stored in field"). -stack_layout__represent_lval(mem_ref(_), _) :- - error("stack_layout: continuation live value stored in mem_ref"). -stack_layout__represent_lval(lvar(_), _) :- - error("stack_layout: continuation live value stored in lvar"). - - % Some things in this module are encoded using a low tag. - % This is not done using the normal compiler mkword, but by - % doing the bit shifting here. - % - % This allows us to use more than the usual 2 or 3 bits, but - % we have to use low tags and cannot tag pointers this way. - -:- pred stack_layout__make_tagged_word(locn_type::in, int::in, int::out) is det. - -stack_layout__make_tagged_word(Locn, Value, TaggedValue) :- - stack_layout__locn_type_code(Locn, Tag), - TaggedValue is (Value << stack_layout__long_lval_tag_bits) + Tag. +make_tagged_word(Locn, Value, TaggedValue) :- + locn_type_code(Locn, Tag), + TaggedValue is (Value << long_lval_tag_bits) + Tag. :- type locn_type - ---> lval_r_reg - ; lval_f_reg - ; lval_stackvar - ; lval_framevar - ; lval_succip - ; lval_maxfr - ; lval_curfr - ; lval_hp - ; lval_sp - ; lval_indirect. + ---> lval_r_reg + ; lval_f_reg + ; lval_stackvar + ; lval_framevar + ; lval_succip + ; lval_maxfr + ; lval_curfr + ; lval_hp + ; lval_sp + ; lval_indirect. -:- pred stack_layout__locn_type_code(locn_type::in, int::out) is det. +:- pred locn_type_code(locn_type::in, int::out) is det. -stack_layout__locn_type_code(lval_r_reg, 0). -stack_layout__locn_type_code(lval_f_reg, 1). -stack_layout__locn_type_code(lval_stackvar, 2). -stack_layout__locn_type_code(lval_framevar, 3). -stack_layout__locn_type_code(lval_succip, 4). -stack_layout__locn_type_code(lval_maxfr, 5). -stack_layout__locn_type_code(lval_curfr, 6). -stack_layout__locn_type_code(lval_hp, 7). -stack_layout__locn_type_code(lval_sp, 8). -stack_layout__locn_type_code(lval_indirect, 9). +locn_type_code(lval_r_reg, 0). +locn_type_code(lval_f_reg, 1). +locn_type_code(lval_stackvar, 2). +locn_type_code(lval_framevar, 3). +locn_type_code(lval_succip, 4). +locn_type_code(lval_maxfr, 5). +locn_type_code(lval_curfr, 6). +locn_type_code(lval_hp, 7). +locn_type_code(lval_sp, 8). +locn_type_code(lval_indirect, 9). -:- func stack_layout__long_lval_tag_bits = int. + % This number of tag bits must be able to encode all values of + % locn_type_code. +:- func long_lval_tag_bits = int. -% This number of tag bits must be able to encode all values of -% stack_layout__locn_type_code. +long_lval_tag_bits = 4. -stack_layout__long_lval_tag_bits = 4. + % This number of tag bits must be able to encode the largest offset + % of a type_info within a typeclass_info. +:- func long_lval_offset_bits = int. -% This number of tag bits must be able to encode the largest offset -% of a type_info within a typeclass_info. - -:- func stack_layout__long_lval_offset_bits = int. - -stack_layout__long_lval_offset_bits = 6. +long_lval_offset_bits = 6. %---------------------------------------------------------------------------% - % Construct a representation of a variable location as a byte, - % if this is possible. + % Construct a representation of a variable location as a byte, + % if this is possible. + % +:- pred represent_locn_as_byte(layout_locn::in, rval::out) is semidet. -:- pred stack_layout__represent_locn_as_byte(layout_locn::in, rval::out) - is semidet. +represent_locn_as_byte(LayoutLocn, Rval) :- + LayoutLocn = direct(Lval), + represent_lval_as_byte(Lval, Byte), + 0 =< Byte, + Byte < 256, + Rval = const(int_const(Byte)). -stack_layout__represent_locn_as_byte(LayoutLocn, Rval) :- - LayoutLocn = direct(Lval), - stack_layout__represent_lval_as_byte(Lval, Byte), - 0 =< Byte, - Byte < 256, - Rval = const(int_const(Byte)). + % Construct a representation of an lval in a byte, if possible. + % +:- pred represent_lval_as_byte(lval::in, int::out) is semidet. - % Construct a representation of an lval in a byte, if possible. +represent_lval_as_byte(reg(r, Num), Byte) :- + require(Num > 0, "represent_lval_as_byte: bad reg"), + make_tagged_byte(0, Num, Byte). +represent_lval_as_byte(stackvar(Num), Byte) :- + require(Num > 0, "represent_lval_as_byte: bad stackvar"), + make_tagged_byte(1, Num, Byte). +represent_lval_as_byte(framevar(Num), Byte) :- + require(Num > 0, "represent_lval_as_byte: bad framevar"), + make_tagged_byte(2, Num, Byte). +represent_lval_as_byte(succip, Byte) :- + locn_type_code(lval_succip, Val), + make_tagged_byte(3, Val, Byte). +represent_lval_as_byte(maxfr, Byte) :- + locn_type_code(lval_maxfr, Val), + make_tagged_byte(3, Val, Byte). +represent_lval_as_byte(curfr, Byte) :- + locn_type_code(lval_curfr, Val), + make_tagged_byte(3, Val, Byte). +represent_lval_as_byte(hp, Byte) :- + locn_type_code(lval_hp, Val), + make_tagged_byte(3, Val, Byte). +represent_lval_as_byte(sp, Byte) :- + locn_type_code(lval_sp, Val), + make_tagged_byte(3, Val, Byte). -:- pred stack_layout__represent_lval_as_byte(lval::in, int::out) is semidet. +:- pred make_tagged_byte(int::in, int::in, int::out) is det. -stack_layout__represent_lval_as_byte(reg(r, Num), Byte) :- - require(Num > 0, "stack_layout__represent_lval_as_byte: bad reg"), - stack_layout__make_tagged_byte(0, Num, Byte). -stack_layout__represent_lval_as_byte(stackvar(Num), Byte) :- - require(Num > 0, "stack_layout__represent_lval_as_byte: bad stackvar"), - stack_layout__make_tagged_byte(1, Num, Byte). -stack_layout__represent_lval_as_byte(framevar(Num), Byte) :- - require(Num > 0, "stack_layout__represent_lval_as_byte: bad framevar"), - stack_layout__make_tagged_byte(2, Num, Byte). -stack_layout__represent_lval_as_byte(succip, Byte) :- - stack_layout__locn_type_code(lval_succip, Val), - stack_layout__make_tagged_byte(3, Val, Byte). -stack_layout__represent_lval_as_byte(maxfr, Byte) :- - stack_layout__locn_type_code(lval_maxfr, Val), - stack_layout__make_tagged_byte(3, Val, Byte). -stack_layout__represent_lval_as_byte(curfr, Byte) :- - stack_layout__locn_type_code(lval_curfr, Val), - stack_layout__make_tagged_byte(3, Val, Byte). -stack_layout__represent_lval_as_byte(hp, Byte) :- - stack_layout__locn_type_code(lval_hp, Val), - stack_layout__make_tagged_byte(3, Val, Byte). -stack_layout__represent_lval_as_byte(sp, Byte) :- - stack_layout__locn_type_code(lval_sp, Val), - stack_layout__make_tagged_byte(3, Val, Byte). +make_tagged_byte(Tag, Value, TaggedValue) :- + TaggedValue is unchecked_left_shift(Value, short_lval_tag_bits) + Tag. -:- pred stack_layout__make_tagged_byte(int::in, int::in, int::out) is det. +:- func short_lval_tag_bits = int. -stack_layout__make_tagged_byte(Tag, Value, TaggedValue) :- - TaggedValue is unchecked_left_shift(Value, - stack_layout__short_lval_tag_bits) + Tag. +short_lval_tag_bits = 2. -:- func stack_layout__short_lval_tag_bits = int. +:- func short_count_bits = int. -stack_layout__short_lval_tag_bits = 2. +short_count_bits = 10. -:- func stack_layout__short_count_bits = int. +:- func byte_bits = int. -stack_layout__short_count_bits = 10. - -:- func stack_layout__byte_bits = int. - -stack_layout__byte_bits = 8. +byte_bits = 8. %---------------------------------------------------------------------------% -stack_layout__represent_determinism_rval(Detism, - const(int_const(code_model__represent_determinism(Detism)))). +represent_determinism_rval(Detism, + const(int_const(code_model__represent_determinism(Detism)))). %---------------------------------------------------------------------------% - % Access to the stack_layout data structure. + % Access to the stack_layout data structure. - % The per-sourcefile label table maps line numbers to the list of - % labels that correspond to that line. Each label is accompanied - % by a flag that says whether the label is the return site of a call - % or not, and if it is, whether the called procedure is known. + % The per-sourcefile label table maps line numbers to the list of + % labels that correspond to that line. Each label is accompanied + % by a flag that says whether the label is the return site of a call + % or not, and if it is, whether the called procedure is known. :- type is_label_return - ---> known_callee(label) - ; unknown_callee - ; not_a_return. + ---> known_callee(label) + ; unknown_callee + ; not_a_return. :- type line_no_info == pair(layout_name, is_label_return). :- type label_table == map(int, list(line_no_info)). -:- type stack_layout_info ---> - stack_layout_info( - module_info :: module_info, - agc_stack_layout :: bool, % generate agc info? - trace_stack_layout :: bool, % generate tracing info? - procid_stack_layout :: bool, % generate proc id info? - static_code_addresses :: bool, % have static code addresses? - label_counter :: counter, - table_infos :: list(comp_gen_c_data), - proc_layouts :: list(comp_gen_c_data), - internal_layouts :: list(comp_gen_c_data), - label_set :: map(label, data_addr), - % The set of labels (both entry - % and internal) with layouts. - proc_layout_name_list :: list(layout_name), - % The list of proc_layouts in - % the module. - string_table :: string_table, - label_tables :: map(string, label_table), - % Maps each filename that - % contributes labels to this module - % to a table describing those - % labels. - static_cell_info :: static_cell_info - ). +:- type stack_layout_info + ---> stack_layout_info( + module_info :: module_info, + agc_stack_layout :: bool, % generate agc info? + trace_stack_layout :: bool, % generate tracing info? + procid_stack_layout :: bool, % generate proc id info? + static_code_addresses :: bool, % have static code addresses? + label_counter :: counter, + table_infos :: list(comp_gen_c_data), + proc_layouts :: list(comp_gen_c_data), + internal_layouts :: list(comp_gen_c_data), + label_set :: map(label, data_addr), + % The set of labels (both entry + % and internal) with layouts. + proc_layout_name_list :: list(layout_name), + % The list of proc_layouts in + % the module. + string_table :: string_table, + label_tables :: map(string, label_table), + % Maps each filename that + % contributes labels to this module + % to a table describing those + % labels. + static_cell_info :: static_cell_info + ). -:- pred stack_layout__get_module_info(stack_layout_info::in, - module_info::out) is det. -:- pred stack_layout__get_agc_stack_layout(stack_layout_info::in, - bool::out) is det. -:- pred stack_layout__get_trace_stack_layout(stack_layout_info::in, - bool::out) is det. -:- pred stack_layout__get_procid_stack_layout(stack_layout_info::in, - bool::out) is det. -:- pred stack_layout__get_static_code_addresses(stack_layout_info::in, - bool::out) is det. -:- pred stack_layout__get_table_infos(stack_layout_info::in, - list(comp_gen_c_data)::out) is det. -:- pred stack_layout__get_proc_layout_data(stack_layout_info::in, - list(comp_gen_c_data)::out) is det. -:- pred stack_layout__get_internal_layout_data(stack_layout_info::in, - list(comp_gen_c_data)::out) is det. -:- pred stack_layout__get_label_set(stack_layout_info::in, - map(label, data_addr)::out) is det. -:- pred stack_layout__get_string_table(stack_layout_info::in, - string_table::out) is det. -:- pred stack_layout__get_label_tables(stack_layout_info::in, - map(string, label_table)::out) is det. -:- pred stack_layout__get_static_cell_info(stack_layout_info::in, - static_cell_info::out) is det. +:- pred get_module_info(stack_layout_info::in, + module_info::out) is det. +:- pred get_agc_stack_layout(stack_layout_info::in, + bool::out) is det. +:- pred get_trace_stack_layout(stack_layout_info::in, + bool::out) is det. +:- pred get_procid_stack_layout(stack_layout_info::in, + bool::out) is det. +:- pred get_static_code_addresses(stack_layout_info::in, + bool::out) is det. +:- pred get_table_infos(stack_layout_info::in, + list(comp_gen_c_data)::out) is det. +:- pred get_proc_layout_data(stack_layout_info::in, + list(comp_gen_c_data)::out) is det. +:- pred get_internal_layout_data(stack_layout_info::in, + list(comp_gen_c_data)::out) is det. +:- pred get_label_set(stack_layout_info::in, + map(label, data_addr)::out) is det. +:- pred get_string_table(stack_layout_info::in, + string_table::out) is det. +:- pred get_label_tables(stack_layout_info::in, + map(string, label_table)::out) is det. +:- pred get_static_cell_info(stack_layout_info::in, + static_cell_info::out) is det. -stack_layout__get_module_info(LI, LI ^ module_info). -stack_layout__get_agc_stack_layout(LI, LI ^ agc_stack_layout). -stack_layout__get_trace_stack_layout(LI, LI ^ trace_stack_layout). -stack_layout__get_procid_stack_layout(LI, LI ^ procid_stack_layout). -stack_layout__get_static_code_addresses(LI, LI ^ static_code_addresses). -stack_layout__get_table_infos(LI, LI ^ table_infos). -stack_layout__get_proc_layout_data(LI, LI ^ proc_layouts). -stack_layout__get_internal_layout_data(LI, LI ^ internal_layouts). -stack_layout__get_label_set(LI, LI ^ label_set). -stack_layout__get_string_table(LI, LI ^ string_table). -stack_layout__get_label_tables(LI, LI ^ label_tables). -stack_layout__get_static_cell_info(LI, LI ^ static_cell_info). +get_module_info(LI, LI ^ module_info). +get_agc_stack_layout(LI, LI ^ agc_stack_layout). +get_trace_stack_layout(LI, LI ^ trace_stack_layout). +get_procid_stack_layout(LI, LI ^ procid_stack_layout). +get_static_code_addresses(LI, LI ^ static_code_addresses). +get_table_infos(LI, LI ^ table_infos). +get_proc_layout_data(LI, LI ^ proc_layouts). +get_internal_layout_data(LI, LI ^ internal_layouts). +get_label_set(LI, LI ^ label_set). +get_string_table(LI, LI ^ string_table). +get_label_tables(LI, LI ^ label_tables). +get_static_cell_info(LI, LI ^ static_cell_info). -:- pred stack_layout__allocate_label_number(int::out, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred allocate_label_number(int::out, + stack_layout_info::in, stack_layout_info::out) is det. -stack_layout__allocate_label_number(LabelNum, !LI) :- - Counter0 = !.LI ^ label_counter, - counter__allocate(LabelNum, Counter0, Counter), - !:LI = !.LI ^ label_counter := Counter. +allocate_label_number(LabelNum, !LI) :- + Counter0 = !.LI ^ label_counter, + counter__allocate(LabelNum, Counter0, Counter), + !:LI = !.LI ^ label_counter := Counter. -:- pred stack_layout__add_table_data(layout_data::in, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred add_table_data(layout_data::in, + stack_layout_info::in, stack_layout_info::out) is det. -stack_layout__add_table_data(TableIoDeclData, !LI) :- - TableIoDecls0 = !.LI ^ table_infos, - TableIoDecls = [layout_data(TableIoDeclData) | TableIoDecls0], - !:LI = !.LI ^ table_infos := TableIoDecls. +add_table_data(TableIoDeclData, !LI) :- + TableIoDecls0 = !.LI ^ table_infos, + TableIoDecls = [layout_data(TableIoDeclData) | TableIoDecls0], + !:LI = !.LI ^ table_infos := TableIoDecls. -:- pred stack_layout__add_proc_layout_data(comp_gen_c_data::in, - layout_name::in, label::in, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred add_proc_layout_data(comp_gen_c_data::in, + layout_name::in, label::in, + stack_layout_info::in, stack_layout_info::out) is det. -stack_layout__add_proc_layout_data(ProcLayout, ProcLayoutName, Label, !LI) :- - ProcLayouts0 = !.LI ^ proc_layouts, - ProcLayouts = [ProcLayout | ProcLayouts0], - LabelSet0 = !.LI ^ label_set, - map__det_insert(LabelSet0, Label, layout_addr(ProcLayoutName), - LabelSet), - ProcLayoutNames0 = !.LI ^ proc_layout_name_list, - ProcLayoutNames = [ProcLayoutName | ProcLayoutNames0], - !:LI = (((!.LI ^ proc_layouts := ProcLayouts) - ^ label_set := LabelSet) - ^ proc_layout_name_list := ProcLayoutNames). +add_proc_layout_data(ProcLayout, ProcLayoutName, Label, !LI) :- + ProcLayouts0 = !.LI ^ proc_layouts, + ProcLayouts = [ProcLayout | ProcLayouts0], + LabelSet0 = !.LI ^ label_set, + map__det_insert(LabelSet0, Label, layout_addr(ProcLayoutName), LabelSet), + ProcLayoutNames0 = !.LI ^ proc_layout_name_list, + ProcLayoutNames = [ProcLayoutName | ProcLayoutNames0], + !:LI = !.LI ^ proc_layouts := ProcLayouts, + !:LI = !.LI ^ label_set := LabelSet, + !:LI = !.LI ^ proc_layout_name_list := ProcLayoutNames. -:- pred stack_layout__add_internal_layout_data(comp_gen_c_data::in, - label::in, layout_name::in, stack_layout_info::in, - stack_layout_info::out) is det. +:- pred add_internal_layout_data(comp_gen_c_data::in, + label::in, layout_name::in, stack_layout_info::in, + stack_layout_info::out) is det. -stack_layout__add_internal_layout_data(InternalLayout, Label, LayoutName, - !LI) :- - InternalLayouts0 = !.LI ^ internal_layouts, - InternalLayouts = [InternalLayout | InternalLayouts0], - LabelSet0 = !.LI ^ label_set, - map__det_insert(LabelSet0, Label, layout_addr(LayoutName), LabelSet), - !:LI = ((!.LI ^ internal_layouts := InternalLayouts) - ^ label_set := LabelSet). +add_internal_layout_data(InternalLayout, Label, LayoutName, + !LI) :- + InternalLayouts0 = !.LI ^ internal_layouts, + InternalLayouts = [InternalLayout | InternalLayouts0], + LabelSet0 = !.LI ^ label_set, + map__det_insert(LabelSet0, Label, layout_addr(LayoutName), LabelSet), + !:LI = !.LI ^ internal_layouts := InternalLayouts, + !:LI = !.LI ^ label_set := LabelSet. -:- pred stack_layout__set_string_table(string_table::in, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred set_string_table(string_table::in, + stack_layout_info::in, stack_layout_info::out) is det. -:- pred stack_layout__set_label_tables(map(string, label_table)::in, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred set_label_tables(map(string, label_table)::in, + stack_layout_info::in, stack_layout_info::out) is det. -:- pred stack_layout__set_static_cell_info(static_cell_info::in, - stack_layout_info::in, stack_layout_info::out) is det. +:- pred set_static_cell_info(static_cell_info::in, + stack_layout_info::in, stack_layout_info::out) is det. -stack_layout__set_string_table(ST, LI, LI ^ string_table := ST). -stack_layout__set_label_tables(LT, LI, LI ^ label_tables := LT). -stack_layout__set_static_cell_info(SCI, LI, LI ^ static_cell_info := SCI). +set_string_table(ST, LI, LI ^ string_table := ST). +set_label_tables(LT, LI, LI ^ label_tables := LT). +set_static_cell_info(SCI, LI, LI ^ static_cell_info := SCI). %---------------------------------------------------------------------------% +% +% Access to the string_table data structure. - % Access to the string_table data structure. +:- type string_table + ---> string_table( + map(string, int), % Maps strings to their offsets. + list(string), % List of strings so far, + % in reverse order. + int % Next available offset + ). -:- type string_table ---> - string_table( - map(string, int), % Maps strings to their offsets. - list(string), % List of strings so far, - % in reverse order. - int % Next available offset - ). - -stack_layout__lookup_string_in_table(String, Offset, !Info) :- - StringTable0 = !.Info ^ string_table, - StringTable0 = string_table(TableMap0, TableList0, TableOffset0), - ( map__search(TableMap0, String, OldOffset) -> - Offset = OldOffset - ; - string__length(String, Length), - TableOffset = TableOffset0 + Length + 1, - % We use a 32 bit unsigned integer to represent the offset. - % Computing that limit exactly without getting an overflow - % or using unportable code isn't trivial. The code below - % is overly conservative, requiring the offset to be - % representable in only 30 bits. The over-conservatism - % should not be an issue; the machine will run out of - % virtual memory before the test below fails, for the - % next several years anyway. (Compiling a module that has - % a 1 Gb string table will require several tens of Gb - % of other compiler structures.) - TableOffset < (1 << ((4 * stack_layout__byte_bits) - 2)) - -> - Offset = TableOffset0, - map__det_insert(TableMap0, String, TableOffset0, - TableMap), - TableList = [String | TableList0], - StringTable = string_table(TableMap, TableList, TableOffset), - stack_layout__set_string_table(StringTable, !Info) - ; - % Says that the name of the variable is "TOO_MANY_VARIABLES". - Offset = 1 - ). +lookup_string_in_table(String, Offset, !Info) :- + StringTable0 = !.Info ^ string_table, + StringTable0 = string_table(TableMap0, TableList0, TableOffset0), + ( map__search(TableMap0, String, OldOffset) -> + Offset = OldOffset + ; + string__length(String, Length), + TableOffset = TableOffset0 + Length + 1, + % We use a 32 bit unsigned integer to represent the offset. + % Computing that limit exactly without getting an overflow + % or using unportable code isn't trivial. The code below + % is overly conservative, requiring the offset to be + % representable in only 30 bits. The over-conservatism + % should not be an issue; the machine will run out of + % virtual memory before the test below fails, for the + % next several years anyway. (Compiling a module that has + % a 1 Gb string table will require several tens of Gb + % of other compiler structures.) + TableOffset < (1 << ((4 * byte_bits) - 2)) + -> + Offset = TableOffset0, + map__det_insert(TableMap0, String, TableOffset0, TableMap), + TableList = [String | TableList0], + StringTable = string_table(TableMap, TableList, TableOffset), + set_string_table(StringTable, !Info) + ; + % Says that the name of the variable is "TOO_MANY_VARIABLES". + Offset = 1 + ). diff --git a/compiler/stack_opt.m b/compiler/stack_opt.m index 14e7dda79..1c480a4d0 100644 --- a/compiler/stack_opt.m +++ b/compiler/stack_opt.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 2002-2005 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. @@ -77,7 +79,7 @@ :- import_module io. :- pred stack_opt_cell(pred_id::in, proc_id::in, proc_info::in, proc_info::out, - module_info::in, module_info::out, io::di, io::uo) is det. + module_info::in, module_info::out, io::di, io::uo) is det. %-----------------------------------------------------------------------------% @@ -130,607 +132,574 @@ % moment, the only variables we treat this way are those that are required to % be on the stack by a parallel conjunction. -:- type opt_stack_alloc ---> - opt_stack_alloc( - par_conj_own_slots :: set(prog_var) - ). +:- type opt_stack_alloc + ---> opt_stack_alloc( + par_conj_own_slots :: set(prog_var) + ). -:- type stack_opt_params ---> - stack_opt_params( - matching_params :: matching_params, - all_path_node_ratio :: int, - fixpoint_loop :: bool, - full_path :: bool, - on_stack :: bool, - non_candidate_vars :: set(prog_var) - ). +:- type stack_opt_params + ---> stack_opt_params( + matching_params :: matching_params, + all_path_node_ratio :: int, + fixpoint_loop :: bool, + full_path :: bool, + on_stack :: bool, + non_candidate_vars :: set(prog_var) + ). -:- type matching_result ---> - matching_result( - prog_var, - cons_id, - list(prog_var), - set(prog_var), - goal_path, - set(interval_id), - set(interval_id), - set(anchor), - set(anchor) - ). +:- type matching_result + ---> matching_result( + prog_var, + cons_id, + list(prog_var), + set(prog_var), + goal_path, + set(interval_id), + set(interval_id), + set(anchor), + set(anchor) + ). -:- type stack_opt_info ---> - stack_opt_info( - stack_opt_params :: stack_opt_params, - left_anchor_inserts :: insert_map, - matching_results :: list(matching_result) - ). +:- type stack_opt_info + ---> stack_opt_info( + stack_opt_params :: stack_opt_params, + left_anchor_inserts :: insert_map, + matching_results :: list(matching_result) + ). stack_opt_cell(PredId, ProcId, !ProcInfo, !ModuleInfo, !IO) :- - % This simplication is necessary to fix some bad inputs from - % getting to the liveness computation. - % (see tests/valid/stack_opt_simplify.m) - simplify_proc([], PredId, ProcId, !ModuleInfo, !ProcInfo, !IO), - detect_liveness_proc(PredId, ProcId, !.ModuleInfo, !ProcInfo, !IO), - initial_liveness(!.ProcInfo, PredId, !.ModuleInfo, Liveness0), - module_info_get_globals(!.ModuleInfo, Globals), - module_info_pred_info(!.ModuleInfo, PredId, PredInfo), - body_should_use_typeinfo_liveness(PredInfo, Globals, TypeInfoLiveness), - globals__lookup_bool_option(Globals, opt_no_return_calls, - OptNoReturnCalls), - AllocData = alloc_data(!.ModuleInfo, !.ProcInfo, TypeInfoLiveness, - OptNoReturnCalls), - goal_path__fill_slots(!.ModuleInfo, !ProcInfo), - proc_info_goal(!.ProcInfo, Goal2), - OptStackAlloc0 = init_opt_stack_alloc, - set__init(FailVars), - set__init(NondetLiveness0), - build_live_sets_in_goal(Goal2, Goal, FailVars, AllocData, - OptStackAlloc0, OptStackAlloc, Liveness0, _Liveness, - NondetLiveness0, _NondetLiveness), - proc_info_set_goal(Goal, !ProcInfo), - allocate_store_maps(for_stack_opt, PredId, !.ModuleInfo, !ProcInfo), - globals__lookup_int_option(Globals, debug_stack_opt, DebugStackOpt), - pred_id_to_int(PredId, PredIdInt), - maybe_write_progress_message("\nbefore stack opt cell", - DebugStackOpt, PredIdInt, !.ProcInfo, !.ModuleInfo, !IO), - optimize_live_sets(!.ModuleInfo, OptStackAlloc, !ProcInfo, - Changed, DebugStackOpt, PredIdInt, !IO), - ( - Changed = yes, - maybe_write_progress_message( - "\nafter stack opt transformation", - DebugStackOpt, PredIdInt, !.ProcInfo, !.ModuleInfo, - !IO), - requantify_proc(!ProcInfo), - maybe_write_progress_message( - "\nafter stack opt requantify", - DebugStackOpt, PredIdInt, !.ProcInfo, !.ModuleInfo, - !IO), - recompute_instmap_delta_proc(yes, !ProcInfo, !ModuleInfo), - maybe_write_progress_message( - "\nafter stack opt recompute instmaps", - DebugStackOpt, PredIdInt, !.ProcInfo, !.ModuleInfo, - !IO) - ; - Changed = no - ). + % This simplication is necessary to fix some bad inputs from + % getting to the liveness computation. + % (see tests/valid/stack_opt_simplify.m) + simplify_proc([], PredId, ProcId, !ModuleInfo, !ProcInfo, !IO), + detect_liveness_proc(PredId, ProcId, !.ModuleInfo, !ProcInfo, !IO), + initial_liveness(!.ProcInfo, PredId, !.ModuleInfo, Liveness0), + module_info_get_globals(!.ModuleInfo, Globals), + module_info_pred_info(!.ModuleInfo, PredId, PredInfo), + body_should_use_typeinfo_liveness(PredInfo, Globals, TypeInfoLiveness), + globals__lookup_bool_option(Globals, opt_no_return_calls, + OptNoReturnCalls), + AllocData = alloc_data(!.ModuleInfo, !.ProcInfo, TypeInfoLiveness, + OptNoReturnCalls), + goal_path__fill_slots(!.ModuleInfo, !ProcInfo), + proc_info_goal(!.ProcInfo, Goal2), + OptStackAlloc0 = init_opt_stack_alloc, + set__init(FailVars), + set__init(NondetLiveness0), + build_live_sets_in_goal(Goal2, Goal, FailVars, AllocData, + OptStackAlloc0, OptStackAlloc, Liveness0, _Liveness, + NondetLiveness0, _NondetLiveness), + proc_info_set_goal(Goal, !ProcInfo), + allocate_store_maps(for_stack_opt, PredId, !.ModuleInfo, !ProcInfo), + globals__lookup_int_option(Globals, debug_stack_opt, DebugStackOpt), + pred_id_to_int(PredId, PredIdInt), + maybe_write_progress_message("\nbefore stack opt cell", + DebugStackOpt, PredIdInt, !.ProcInfo, !.ModuleInfo, !IO), + optimize_live_sets(!.ModuleInfo, OptStackAlloc, !ProcInfo, + Changed, DebugStackOpt, PredIdInt, !IO), + ( + Changed = yes, + maybe_write_progress_message("\nafter stack opt transformation", + DebugStackOpt, PredIdInt, !.ProcInfo, !.ModuleInfo, !IO), + requantify_proc(!ProcInfo), + maybe_write_progress_message("\nafter stack opt requantify", + DebugStackOpt, PredIdInt, !.ProcInfo, !.ModuleInfo, !IO), + recompute_instmap_delta_proc(yes, !ProcInfo, !ModuleInfo), + maybe_write_progress_message("\nafter stack opt recompute instmaps", + DebugStackOpt, PredIdInt, !.ProcInfo, !.ModuleInfo, !IO) + ; + Changed = no + ). :- func init_opt_stack_alloc = opt_stack_alloc. init_opt_stack_alloc = opt_stack_alloc(set__init). :- pred optimize_live_sets(module_info::in, opt_stack_alloc::in, - proc_info::in, proc_info::out, bool::out, int::in, int::in, - io::di, io::uo) is det. + proc_info::in, proc_info::out, bool::out, int::in, int::in, + io::di, io::uo) is det. optimize_live_sets(ModuleInfo, OptAlloc, !ProcInfo, Changed, DebugStackOpt, - PredIdInt, !IO) :- - proc_info_goal(!.ProcInfo, Goal0), - proc_info_vartypes(!.ProcInfo, VarTypes0), - proc_info_varset(!.ProcInfo, VarSet0), - OptAlloc = opt_stack_alloc(ParConjOwnSlot), - arg_info__partition_proc_args(!.ProcInfo, ModuleInfo, - InputArgs, OutputArgs, UnusedArgs), - HeadVars = set__union_list([InputArgs, OutputArgs, UnusedArgs]), - module_info_get_globals(ModuleInfo, Globals), - globals__lookup_bool_option(Globals, - optimize_saved_vars_cell_candidate_headvars, CandHeadvars), - ( - CandHeadvars = no, - set__union(HeadVars, ParConjOwnSlot, NonCandidateVars) - ; - CandHeadvars = yes, - NonCandidateVars = ParConjOwnSlot - ), - Counter0 = counter__init(1), - counter__allocate(CurInterval, Counter0, Counter1), - CurIntervalId = interval_id(CurInterval), - EndMap0 = map__det_insert(map__init, CurIntervalId, proc_end), - InsertMap0 = map__init, - StartMap0 = map__init, - SuccMap0 = map__det_insert(map__init, CurIntervalId, []), - VarsMap0 = map__det_insert(map__init, CurIntervalId, OutputArgs), - globals__lookup_int_option(Globals, - optimize_saved_vars_cell_cv_store_cost, CellVarStoreCost), - globals__lookup_int_option(Globals, - optimize_saved_vars_cell_cv_load_cost, CellVarLoadCost), - globals__lookup_int_option(Globals, - optimize_saved_vars_cell_fv_store_cost, FieldVarStoreCost), - globals__lookup_int_option(Globals, - optimize_saved_vars_cell_fv_load_cost, FieldVarLoadCost), - globals__lookup_int_option(Globals, - optimize_saved_vars_cell_op_ratio, OpRatio), - globals__lookup_int_option(Globals, - optimize_saved_vars_cell_node_ratio, NodeRatio), - globals__lookup_bool_option(Globals, - optimize_saved_vars_cell_include_all_candidates, InclAllCand), - MatchingParams = matching_params(CellVarStoreCost, CellVarLoadCost, - FieldVarStoreCost, FieldVarLoadCost, OpRatio, NodeRatio, - InclAllCand), - globals__lookup_int_option(Globals, - optimize_saved_vars_cell_all_path_node_ratio, - AllPathNodeRatio), - globals__lookup_bool_option(Globals, - optimize_saved_vars_cell_loop, FixpointLoop), - globals__lookup_bool_option(Globals, - optimize_saved_vars_cell_full_path, FullPath), - globals__lookup_bool_option(Globals, - optimize_saved_vars_cell_on_stack, OnStack), - globals__lookup_bool_option(Globals, - opt_no_return_calls, OptNoReturnCalls), - IntParams = interval_params(ModuleInfo, VarTypes0, OptNoReturnCalls), - IntervalInfo0 = interval_info(IntParams, set__init, OutputArgs, - map__init, map__init, map__init, CurIntervalId, Counter1, - set__make_singleton_set(CurIntervalId), - map__init, set__init, StartMap0, EndMap0, - SuccMap0, VarsMap0, map__init), - StackOptParams = stack_opt_params(MatchingParams, AllPathNodeRatio, - FixpointLoop, FullPath, OnStack, NonCandidateVars), - StackOptInfo0 = stack_opt_info(StackOptParams, InsertMap0, []), - build_interval_info_in_goal(Goal0, IntervalInfo0, IntervalInfo, - StackOptInfo0, StackOptInfo), - ( DebugStackOpt = PredIdInt -> - dump_interval_info(IntervalInfo, !IO), - dump_stack_opt_info(StackOptInfo, !IO) - ; - true - ), - InsertMap = StackOptInfo ^ left_anchor_inserts, - ( map__is_empty(InsertMap) -> - Changed = no - ; - record_decisions_in_goal(Goal0, Goal1, VarSet0, VarSet, - VarTypes0, VarTypes, map__init, RenameMap, - InsertMap, yes(stack_opt)), - apply_headvar_correction(HeadVars, RenameMap, Goal1, Goal), - proc_info_set_goal(Goal, !ProcInfo), - proc_info_set_varset(VarSet, !ProcInfo), - proc_info_set_vartypes(VarTypes, !ProcInfo), - Changed = yes - ). + PredIdInt, !IO) :- + proc_info_goal(!.ProcInfo, Goal0), + proc_info_vartypes(!.ProcInfo, VarTypes0), + proc_info_varset(!.ProcInfo, VarSet0), + OptAlloc = opt_stack_alloc(ParConjOwnSlot), + arg_info__partition_proc_args(!.ProcInfo, ModuleInfo, + InputArgs, OutputArgs, UnusedArgs), + HeadVars = set__union_list([InputArgs, OutputArgs, UnusedArgs]), + module_info_get_globals(ModuleInfo, Globals), + globals__lookup_bool_option(Globals, + optimize_saved_vars_cell_candidate_headvars, CandHeadvars), + ( + CandHeadvars = no, + set__union(HeadVars, ParConjOwnSlot, NonCandidateVars) + ; + CandHeadvars = yes, + NonCandidateVars = ParConjOwnSlot + ), + Counter0 = counter__init(1), + counter__allocate(CurInterval, Counter0, Counter1), + CurIntervalId = interval_id(CurInterval), + EndMap0 = map__det_insert(map__init, CurIntervalId, proc_end), + InsertMap0 = map__init, + StartMap0 = map__init, + SuccMap0 = map__det_insert(map__init, CurIntervalId, []), + VarsMap0 = map__det_insert(map__init, CurIntervalId, OutputArgs), + globals__lookup_int_option(Globals, + optimize_saved_vars_cell_cv_store_cost, CellVarStoreCost), + globals__lookup_int_option(Globals, + optimize_saved_vars_cell_cv_load_cost, CellVarLoadCost), + globals__lookup_int_option(Globals, + optimize_saved_vars_cell_fv_store_cost, FieldVarStoreCost), + globals__lookup_int_option(Globals, + optimize_saved_vars_cell_fv_load_cost, FieldVarLoadCost), + globals__lookup_int_option(Globals, + optimize_saved_vars_cell_op_ratio, OpRatio), + globals__lookup_int_option(Globals, + optimize_saved_vars_cell_node_ratio, NodeRatio), + globals__lookup_bool_option(Globals, + optimize_saved_vars_cell_include_all_candidates, InclAllCand), + MatchingParams = matching_params(CellVarStoreCost, CellVarLoadCost, + FieldVarStoreCost, FieldVarLoadCost, OpRatio, NodeRatio, + InclAllCand), + globals__lookup_int_option(Globals, + optimize_saved_vars_cell_all_path_node_ratio, + AllPathNodeRatio), + globals__lookup_bool_option(Globals, + optimize_saved_vars_cell_loop, FixpointLoop), + globals__lookup_bool_option(Globals, + optimize_saved_vars_cell_full_path, FullPath), + globals__lookup_bool_option(Globals, + optimize_saved_vars_cell_on_stack, OnStack), + globals__lookup_bool_option(Globals, + opt_no_return_calls, OptNoReturnCalls), + IntParams = interval_params(ModuleInfo, VarTypes0, OptNoReturnCalls), + IntervalInfo0 = interval_info(IntParams, set__init, OutputArgs, + map__init, map__init, map__init, CurIntervalId, Counter1, + set__make_singleton_set(CurIntervalId), + map__init, set__init, StartMap0, EndMap0, + SuccMap0, VarsMap0, map__init), + StackOptParams = stack_opt_params(MatchingParams, AllPathNodeRatio, + FixpointLoop, FullPath, OnStack, NonCandidateVars), + StackOptInfo0 = stack_opt_info(StackOptParams, InsertMap0, []), + build_interval_info_in_goal(Goal0, IntervalInfo0, IntervalInfo, + StackOptInfo0, StackOptInfo), + ( DebugStackOpt = PredIdInt -> + dump_interval_info(IntervalInfo, !IO), + dump_stack_opt_info(StackOptInfo, !IO) + ; + true + ), + InsertMap = StackOptInfo ^ left_anchor_inserts, + ( map__is_empty(InsertMap) -> + Changed = no + ; + record_decisions_in_goal(Goal0, Goal1, VarSet0, VarSet, + VarTypes0, VarTypes, map__init, RenameMap, + InsertMap, yes(stack_opt)), + apply_headvar_correction(HeadVars, RenameMap, Goal1, Goal), + proc_info_set_goal(Goal, !ProcInfo), + proc_info_set_varset(VarSet, !ProcInfo), + proc_info_set_vartypes(VarTypes, !ProcInfo), + Changed = yes + ). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- instance stack_alloc_info(opt_stack_alloc) where [ - pred(at_call_site/4) is opt_at_call_site, - pred(at_resume_site/4) is opt_at_resume_site, - pred(at_par_conj/4) is opt_at_par_conj + pred(at_call_site/4) is opt_at_call_site, + pred(at_resume_site/4) is opt_at_resume_site, + pred(at_par_conj/4) is opt_at_par_conj ]. :- pred opt_at_call_site(need_across_call::in, hlds_goal_info::in, - opt_stack_alloc::in, opt_stack_alloc::out) is det. + opt_stack_alloc::in, opt_stack_alloc::out) is det. opt_at_call_site(_NeedAtCall, _GoalInfo, StackAlloc, StackAlloc). :- pred opt_at_resume_site(need_in_resume::in, hlds_goal_info::in, - opt_stack_alloc::in, opt_stack_alloc::out) is det. + opt_stack_alloc::in, opt_stack_alloc::out) is det. opt_at_resume_site(_NeedAtResume, _GoalInfo, StackAlloc, StackAlloc). :- pred opt_at_par_conj(need_in_par_conj::in, hlds_goal_info::in, - opt_stack_alloc::in, opt_stack_alloc::out) is det. + opt_stack_alloc::in, opt_stack_alloc::out) is det. opt_at_par_conj(NeedParConj, _GoalInfo, StackAlloc0, StackAlloc) :- - NeedParConj = need_in_par_conj(StackVars), - ParConjOwnSlots0 = StackAlloc0 ^ par_conj_own_slots, - ParConjOwnSlots = set__union(StackVars, ParConjOwnSlots0), - StackAlloc = StackAlloc0 ^ par_conj_own_slots := ParConjOwnSlots. + NeedParConj = need_in_par_conj(StackVars), + ParConjOwnSlots0 = StackAlloc0 ^ par_conj_own_slots, + ParConjOwnSlots = set__union(StackVars, ParConjOwnSlots0), + StackAlloc = StackAlloc0 ^ par_conj_own_slots := ParConjOwnSlots. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- instance build_interval_info_acc(stack_opt_info) where [ - pred(use_cell/8) is stack_opt__use_cell + pred(use_cell/8) is stack_opt__use_cell ]. :- type match_path_info - ---> match_path_info( - set(prog_var), % The set of vars referenced in - % the first interval, before - % the first flush point. - list(set(prog_var)) % The set of vars referenced in - % later intervals, after the - % first flush point. - ). + ---> match_path_info( + set(prog_var), % The set of vars referenced in + % the first interval, before + % the first flush point. + list(set(prog_var)) % The set of vars referenced in + % later intervals, after the + % first flush point. + ). :- type match_info - ---> match_info( - list(match_path_info), % Information about the - % variables used along each - % path. - set(prog_var), % The variables used after the - % deconstruction goes out of - % scope. - bool, % Have we stepped over a - % model_non goal? - set(anchor), % The set of save points - % to which the results of the - % matching applies. - set(interval_id) - ). + ---> match_info( + list(match_path_info), % Information about the + % variables used along each + % path. + set(prog_var), % The variables used after the + % deconstruction goes out of + % scope. + bool, % Have we stepped over a + % model_non goal? + set(anchor), % The set of save points + % to which the results of the + % matching applies. + set(interval_id) + ). :- pred use_cell(prog_var::in, list(prog_var)::in, cons_id::in, hlds_goal::in, - interval_info::in, interval_info::out, stack_opt_info::in, - stack_opt_info::out) is det. + interval_info::in, interval_info::out, stack_opt_info::in, + stack_opt_info::out) is det. use_cell(CellVar, FieldVarList, ConsId, Goal, !IntervalInfo, !StackOptInfo) :- - FlushedLater = !.IntervalInfo ^ flushed_later, - StackOptParams = !.StackOptInfo ^ stack_opt_params, - NonCandidateVars = StackOptParams ^ non_candidate_vars, - set__list_to_set(FieldVarList, FieldVars), - set__intersect(FieldVars, FlushedLater, FlushedLaterFieldVars), - set__difference(FlushedLaterFieldVars, NonCandidateVars, - CandidateArgVars0), - ( - set__empty(CandidateArgVars0) - -> - true - ; - ConsId = cons(_Name, _Arity), - IntParams = !.IntervalInfo ^ interval_params, - VarTypes = IntParams ^ var_types, - map__lookup(VarTypes, CellVar, Type), - ( - type_is_tuple(Type, _) - -> - FreeOfCost = no - ; - type_to_ctor_and_args(Type, TypeCtor, _), - ModuleInfo = IntParams ^ module_info, - module_info_get_type_table(ModuleInfo, TypeTable), - map__lookup(TypeTable, TypeCtor, TypeDefn), - hlds_data__get_type_defn_body(TypeDefn, TypeBody), - ConsTable = TypeBody ^ du_type_cons_tag_values - -> - map__lookup(ConsTable, ConsId, ConsTag), - ( ConsTag = no_tag -> - FreeOfCost = yes - ; - FreeOfCost = no - ) - ; - fail - ) - -> - RelevantVars = set__insert(FieldVars, CellVar), - find_all_branches_from_cur_interval(RelevantVars, MatchInfo, - !.IntervalInfo, !.StackOptInfo), - MatchInfo = match_info(PathsInfo, RelevantAfterVars, - AfterModelNon, InsertAnchors, InsertIntervals), - ( - FreeOfCost = yes, - set__difference(CandidateArgVars0, RelevantAfterVars, - ViaCellVars), - record_matching_result(CellVar, ConsId, - FieldVarList, ViaCellVars, Goal, - InsertAnchors, InsertIntervals, !IntervalInfo, - !StackOptInfo) - ; - FreeOfCost = no, - ( - AfterModelNon = no, - OnStack = StackOptParams ^ on_stack, - set__difference(CandidateArgVars0, - RelevantAfterVars, CandidateArgVars), - ( - OnStack = yes, - ( set__member(CellVar, FlushedLater) -> - CellVarFlushedLater = yes - ; - CellVarFlushedLater = no - ) - ; - OnStack = no, - ( - list__member(PathInfo, - PathsInfo), - PathInfo = match_path_info(_, - Segments), - list__member(Segment, - Segments), - set__member(CellVar, Segment) - -> - CellVarFlushedLater = yes - ; - CellVarFlushedLater = no - ) - ), - apply_matching(CellVar, CellVarFlushedLater, - IntParams, StackOptParams, PathsInfo, - CandidateArgVars, ViaCellVars), - record_matching_result(CellVar, ConsId, - FieldVarList, ViaCellVars, Goal, - InsertAnchors, InsertIntervals, - !IntervalInfo, !StackOptInfo) - ; - AfterModelNon = yes - ) - ) - ; - true - ). + FlushedLater = !.IntervalInfo ^ flushed_later, + StackOptParams = !.StackOptInfo ^ stack_opt_params, + NonCandidateVars = StackOptParams ^ non_candidate_vars, + set__list_to_set(FieldVarList, FieldVars), + set__intersect(FieldVars, FlushedLater, FlushedLaterFieldVars), + set__difference(FlushedLaterFieldVars, NonCandidateVars, + CandidateArgVars0), + ( + set__empty(CandidateArgVars0) + -> + true + ; + ConsId = cons(_Name, _Arity), + IntParams = !.IntervalInfo ^ interval_params, + VarTypes = IntParams ^ var_types, + map__lookup(VarTypes, CellVar, Type), + ( + type_is_tuple(Type, _) + -> + FreeOfCost = no + ; + type_to_ctor_and_args(Type, TypeCtor, _), + ModuleInfo = IntParams ^ module_info, + module_info_get_type_table(ModuleInfo, TypeTable), + map__lookup(TypeTable, TypeCtor, TypeDefn), + hlds_data__get_type_defn_body(TypeDefn, TypeBody), + ConsTable = TypeBody ^ du_type_cons_tag_values + -> + map__lookup(ConsTable, ConsId, ConsTag), + ( ConsTag = no_tag -> + FreeOfCost = yes + ; + FreeOfCost = no + ) + ; + fail + ) + -> + RelevantVars = set__insert(FieldVars, CellVar), + find_all_branches_from_cur_interval(RelevantVars, MatchInfo, + !.IntervalInfo, !.StackOptInfo), + MatchInfo = match_info(PathsInfo, RelevantAfterVars, + AfterModelNon, InsertAnchors, InsertIntervals), + ( + FreeOfCost = yes, + set__difference(CandidateArgVars0, RelevantAfterVars, ViaCellVars), + record_matching_result(CellVar, ConsId, FieldVarList, ViaCellVars, + Goal, InsertAnchors, InsertIntervals, !IntervalInfo, + !StackOptInfo) + ; + FreeOfCost = no, + ( + AfterModelNon = no, + OnStack = StackOptParams ^ on_stack, + set__difference(CandidateArgVars0, RelevantAfterVars, + CandidateArgVars), + ( + OnStack = yes, + ( set__member(CellVar, FlushedLater) -> + CellVarFlushedLater = yes + ; + CellVarFlushedLater = no + ) + ; + OnStack = no, + ( + list__member(PathInfo, PathsInfo), + PathInfo = match_path_info(_, Segments), + list__member(Segment, Segments), + set__member(CellVar, Segment) + -> + CellVarFlushedLater = yes + ; + CellVarFlushedLater = no + ) + ), + apply_matching(CellVar, CellVarFlushedLater, IntParams, + StackOptParams, PathsInfo, CandidateArgVars, ViaCellVars), + record_matching_result(CellVar, ConsId, FieldVarList, + ViaCellVars, Goal, InsertAnchors, InsertIntervals, + !IntervalInfo, !StackOptInfo) + ; + AfterModelNon = yes + ) + ) + ; + true + ). :- pred apply_matching(prog_var::in, bool::in, interval_params::in, - stack_opt_params::in, list(match_path_info)::in, - set(prog_var)::in, set(prog_var)::out) is det. + stack_opt_params::in, list(match_path_info)::in, + set(prog_var)::in, set(prog_var)::out) is det. apply_matching(CellVar, CellVarFlushedLater, IntParams, StackOptParams, - PathInfos, CandidateArgVars0, ViaCellVars) :- - apply_matching_loop(CellVar, CellVarFlushedLater, IntParams, - StackOptParams, PathInfos, - CandidateArgVars0, BenefitNodeSets, CostNodeSets, - ViaCellVars0), - BenefitNodes = set__union_list(BenefitNodeSets), - CostNodes = set__union_list(CostNodeSets), - set__count(BenefitNodes, NumBenefitNodes), - set__count(CostNodes, NumCostNodes), - AllPathNodeRatio = StackOptParams ^ all_path_node_ratio, - ( NumBenefitNodes * 100 >= NumCostNodes * AllPathNodeRatio -> - ViaCellVars = ViaCellVars0 - ; - ViaCellVars = set__init - ). + PathInfos, CandidateArgVars0, ViaCellVars) :- + apply_matching_loop(CellVar, CellVarFlushedLater, IntParams, + StackOptParams, PathInfos, CandidateArgVars0, + BenefitNodeSets, CostNodeSets, ViaCellVars0), + BenefitNodes = set__union_list(BenefitNodeSets), + CostNodes = set__union_list(CostNodeSets), + set__count(BenefitNodes, NumBenefitNodes), + set__count(CostNodes, NumCostNodes), + AllPathNodeRatio = StackOptParams ^ all_path_node_ratio, + ( NumBenefitNodes * 100 >= NumCostNodes * AllPathNodeRatio -> + ViaCellVars = ViaCellVars0 + ; + ViaCellVars = set__init + ). :- pred apply_matching_loop(prog_var::in, bool::in, interval_params::in, - stack_opt_params::in, list(match_path_info)::in, set(prog_var)::in, - list(set(benefit_node))::out, list(set(cost_node))::out, - set(prog_var)::out) is det. + stack_opt_params::in, list(match_path_info)::in, set(prog_var)::in, + list(set(benefit_node))::out, list(set(cost_node))::out, + set(prog_var)::out) is det. apply_matching_loop(CellVar, CellVarFlushedLater, IntParams, StackOptParams, - PathInfos, CandidateArgVars0, BenefitNodeSets, CostNodeSets, - ViaCellVars) :- - list__map3(apply_matching_for_path(CellVar, CellVarFlushedLater, - StackOptParams, CandidateArgVars0), PathInfos, - BenefitNodeSets0, CostNodeSets0, PathViaCellVars), - ( list__all_same(PathViaCellVars) -> - BenefitNodeSets = BenefitNodeSets0, - CostNodeSets = CostNodeSets0, - ( PathViaCellVars = [ViaCellVarsPrime | _] -> - ViaCellVars = ViaCellVarsPrime - ; - ViaCellVars = set__init - ) - ; - CandidateArgVars1 = set__intersect_list(PathViaCellVars), - FixpointLoop = StackOptParams ^ fixpoint_loop, - ( - FixpointLoop = no, - BenefitNodeSets = BenefitNodeSets0, - CostNodeSets = CostNodeSets0, - ViaCellVars = CandidateArgVars1 - ; - FixpointLoop = yes, - apply_matching_loop(CellVar, CellVarFlushedLater, - IntParams, StackOptParams, PathInfos, - CandidateArgVars1, - BenefitNodeSets, CostNodeSets, ViaCellVars) - ) - ). + PathInfos, CandidateArgVars0, BenefitNodeSets, CostNodeSets, + ViaCellVars) :- + list__map3(apply_matching_for_path(CellVar, CellVarFlushedLater, + StackOptParams, CandidateArgVars0), PathInfos, + BenefitNodeSets0, CostNodeSets0, PathViaCellVars), + ( list__all_same(PathViaCellVars) -> + BenefitNodeSets = BenefitNodeSets0, + CostNodeSets = CostNodeSets0, + ( PathViaCellVars = [ViaCellVarsPrime | _] -> + ViaCellVars = ViaCellVarsPrime + ; + ViaCellVars = set__init + ) + ; + CandidateArgVars1 = set__intersect_list(PathViaCellVars), + FixpointLoop = StackOptParams ^ fixpoint_loop, + ( + FixpointLoop = no, + BenefitNodeSets = BenefitNodeSets0, + CostNodeSets = CostNodeSets0, + ViaCellVars = CandidateArgVars1 + ; + FixpointLoop = yes, + apply_matching_loop(CellVar, CellVarFlushedLater, + IntParams, StackOptParams, PathInfos, CandidateArgVars1, + BenefitNodeSets, CostNodeSets, ViaCellVars) + ) + ). :- pred apply_matching_for_path(prog_var::in, bool::in, stack_opt_params::in, - set(prog_var)::in, match_path_info::in, - set(benefit_node)::out, set(cost_node)::out, set(prog_var)::out) - is det. + set(prog_var)::in, match_path_info::in, + set(benefit_node)::out, set(cost_node)::out, set(prog_var)::out) is det. apply_matching_for_path(CellVar, CellVarFlushedLater, StackOptParams, - CandidateArgVars, PathInfo, BenefitNodes, CostNodes, - ViaCellVars) :- - ( set__empty(CandidateArgVars) -> - BenefitNodes = set__init, - CostNodes = set__init, - ViaCellVars = set__init - ; - PathInfo = match_path_info(FirstSegment, LaterSegments), - MatchingParams = StackOptParams ^ matching_params, - find_via_cell_vars(CellVar, CandidateArgVars, - CellVarFlushedLater, FirstSegment, LaterSegments, - MatchingParams, BenefitNodes, CostNodes, ViaCellVars) - ). + CandidateArgVars, PathInfo, BenefitNodes, CostNodes, ViaCellVars) :- + ( set__empty(CandidateArgVars) -> + BenefitNodes = set__init, + CostNodes = set__init, + ViaCellVars = set__init + ; + PathInfo = match_path_info(FirstSegment, LaterSegments), + MatchingParams = StackOptParams ^ matching_params, + find_via_cell_vars(CellVar, CandidateArgVars, CellVarFlushedLater, + FirstSegment, LaterSegments, MatchingParams, + BenefitNodes, CostNodes, ViaCellVars) + ). :- pred record_matching_result(prog_var::in, cons_id::in, list(prog_var)::in, - set(prog_var)::in, hlds_goal::in, set(anchor)::in, - set(interval_id)::in, interval_info::in, interval_info::out, - stack_opt_info::in, stack_opt_info::out) is det. + set(prog_var)::in, hlds_goal::in, set(anchor)::in, + set(interval_id)::in, interval_info::in, interval_info::out, + stack_opt_info::in, stack_opt_info::out) is det. record_matching_result(CellVar, ConsId, ArgVars, ViaCellVars, Goal, - PotentialAnchors, PotentialIntervals, - IntervalInfo0, IntervalInfo, StackOptInfo0, StackOptInfo) :- - ( set__empty(ViaCellVars) -> - IntervalInfo = IntervalInfo0, - StackOptInfo = StackOptInfo0 - ; - set__to_sorted_list(PotentialIntervals, PotentialIntervalList), - set__to_sorted_list(PotentialAnchors, PotentialAnchorList), - list__foldl3( - record_cell_var_for_interval(CellVar, ViaCellVars), - PotentialIntervalList, IntervalInfo0, IntervalInfo1, - StackOptInfo0, StackOptInfo1, - set__init, InsertIntervals), - list__foldl3( - add_anchor_inserts(Goal, ViaCellVars, InsertIntervals), - PotentialAnchorList, IntervalInfo1, IntervalInfo2, - StackOptInfo1, StackOptInfo2, - set__init, InsertAnchors), - Goal = _ - GoalInfo, - goal_info_get_goal_path(GoalInfo, GoalPath), - MatchingResult = matching_result(CellVar, ConsId, - ArgVars, ViaCellVars, GoalPath, - PotentialIntervals, InsertIntervals, - PotentialAnchors, InsertAnchors), - MatchingResults0 = StackOptInfo2 ^ matching_results, - MatchingResults = [MatchingResult | MatchingResults0], - IntervalInfo = IntervalInfo2, - StackOptInfo = StackOptInfo2 - ^ matching_results := MatchingResults - ). + PotentialAnchors, PotentialIntervals, !IntervalInfo, !StackOptInfo) :- + ( set__empty(ViaCellVars) -> + true + ; + set__to_sorted_list(PotentialIntervals, PotentialIntervalList), + set__to_sorted_list(PotentialAnchors, PotentialAnchorList), + list__foldl3(record_cell_var_for_interval(CellVar, ViaCellVars), + PotentialIntervalList, !IntervalInfo, !StackOptInfo, + set__init, InsertIntervals), + list__foldl3(add_anchor_inserts(Goal, ViaCellVars, InsertIntervals), + PotentialAnchorList, !IntervalInfo, !StackOptInfo, + set__init, InsertAnchors), + Goal = _ - GoalInfo, + goal_info_get_goal_path(GoalInfo, GoalPath), + MatchingResult = matching_result(CellVar, ConsId, + ArgVars, ViaCellVars, GoalPath, + PotentialIntervals, InsertIntervals, + PotentialAnchors, InsertAnchors), + MatchingResults0 = !.StackOptInfo ^ matching_results, + MatchingResults = [MatchingResult | MatchingResults0], + !:StackOptInfo = !.StackOptInfo ^ matching_results := MatchingResults + ). :- pred record_cell_var_for_interval(prog_var::in, set(prog_var)::in, - interval_id::in, interval_info::in, interval_info::out, - stack_opt_info::in, stack_opt_info::out, - set(interval_id)::in, set(interval_id)::out) is det. + interval_id::in, interval_info::in, interval_info::out, + stack_opt_info::in, stack_opt_info::out, + set(interval_id)::in, set(interval_id)::out) is det. record_cell_var_for_interval(CellVar, ViaCellVars, IntervalId, - !IntervalInfo, !StackOptInfo, - InsertIntervals0, InsertIntervals) :- - record_interval_vars(IntervalId, [CellVar], !IntervalInfo), - delete_interval_vars(IntervalId, ViaCellVars, DeletedVars, - !IntervalInfo), - ( set__non_empty(DeletedVars) -> - svset__insert(IntervalId, InsertIntervals0, InsertIntervals) - ; - InsertIntervals = InsertIntervals0 - ). + !IntervalInfo, !StackOptInfo, !InsertIntervals) :- + record_interval_vars(IntervalId, [CellVar], !IntervalInfo), + delete_interval_vars(IntervalId, ViaCellVars, DeletedVars, !IntervalInfo), + ( set__non_empty(DeletedVars) -> + svset__insert(IntervalId, !InsertIntervals) + ; + true + ). :- pred add_anchor_inserts(hlds_goal::in, set(prog_var)::in, - set(interval_id)::in, anchor::in, interval_info::in, - interval_info::out, stack_opt_info::in, stack_opt_info::out, - set(anchor)::in, set(anchor)::out) is det. + set(interval_id)::in, anchor::in, interval_info::in, + interval_info::out, stack_opt_info::in, stack_opt_info::out, + set(anchor)::in, set(anchor)::out) is det. add_anchor_inserts(Goal, ArgVarsViaCellVar, InsertIntervals, Anchor, - !IntervalInfo, !StackOptInfo, !InsertAnchors) :- - map__lookup(!.IntervalInfo ^ anchor_follow_map, Anchor, AnchorFollow), - AnchorFollow = _ - AnchorIntervals, - set__intersect(AnchorIntervals, InsertIntervals, - AnchorInsertIntervals), - ( set__non_empty(AnchorInsertIntervals) -> - Insert = insert_spec(Goal, ArgVarsViaCellVar), - InsertMap0 = !.StackOptInfo ^ left_anchor_inserts, - ( map__search(InsertMap0, Anchor, Inserts0) -> - Inserts = [Insert | Inserts0], - svmap__det_update(Anchor, Inserts, - InsertMap0, InsertMap) - ; - Inserts = [Insert], - svmap__det_insert(Anchor, Inserts, - InsertMap0, InsertMap) - ), - !:StackOptInfo = !.StackOptInfo - ^ left_anchor_inserts := InsertMap, - svset__insert(Anchor, !InsertAnchors) - ; - true - ). + !IntervalInfo, !StackOptInfo, !InsertAnchors) :- + map__lookup(!.IntervalInfo ^ anchor_follow_map, Anchor, AnchorFollow), + AnchorFollow = _ - AnchorIntervals, + set__intersect(AnchorIntervals, InsertIntervals, + AnchorInsertIntervals), + ( set__non_empty(AnchorInsertIntervals) -> + Insert = insert_spec(Goal, ArgVarsViaCellVar), + InsertMap0 = !.StackOptInfo ^ left_anchor_inserts, + ( map__search(InsertMap0, Anchor, Inserts0) -> + Inserts = [Insert | Inserts0], + svmap__det_update(Anchor, Inserts, InsertMap0, InsertMap) + ; + Inserts = [Insert], + svmap__det_insert(Anchor, Inserts, InsertMap0, InsertMap) + ), + !:StackOptInfo = !.StackOptInfo ^ left_anchor_inserts := InsertMap, + svset__insert(Anchor, !InsertAnchors) + ; + true + ). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- type current_segment_first_flush - ---> current_is_before_first_flush - ; current_is_after_first_flush. + ---> current_is_before_first_flush + ; current_is_after_first_flush. :- type path - ---> path( - flush_state :: current_segment_first_flush, - current_segment :: set(prog_var), - first_segment :: set(prog_var), - other_segments :: list(set(prog_var)), - flush_anchors :: set(anchor), - occurring_intervals :: set(interval_id) - ). + ---> path( + flush_state :: current_segment_first_flush, + current_segment :: set(prog_var), + first_segment :: set(prog_var), + other_segments :: list(set(prog_var)), + flush_anchors :: set(anchor), + occurring_intervals :: set(interval_id) + ). :- type all_paths - ---> all_paths( - paths_so_far :: set(path), - % The set of all paths so far. - stepped_over_model_non :: bool, - % Have we stepped over - % model_non goals? - used_after_scope :: set(prog_var) - % The vars which are known - % to be used after the - % deconstruction goes out of - % scope. - ). + ---> all_paths( + paths_so_far :: set(path), + % The set of all paths so far. + stepped_over_model_non :: bool, + % Have we stepped over + % model_non goals? + used_after_scope :: set(prog_var) + % The vars which are known to be used + % after the deconstruction goes out of + % scope. + ). :- pred extract_match_and_save_info(path::in, match_path_info::out, - set(anchor)::out, set(interval_id)::out) is det. + set(anchor)::out, set(interval_id)::out) is det. extract_match_and_save_info(Path0, MatchPathInfo, Anchors, Intervals) :- - Path = close_path(Path0), - FirstSegment = Path ^ first_segment, - OtherSegments = Path ^ other_segments, - MatchPathInfo = match_path_info(FirstSegment, OtherSegments), - Anchors = Path ^ flush_anchors, - Intervals = Path ^ occurring_intervals. + Path = close_path(Path0), + FirstSegment = Path ^ first_segment, + OtherSegments = Path ^ other_segments, + MatchPathInfo = match_path_info(FirstSegment, OtherSegments), + Anchors = Path ^ flush_anchors, + Intervals = Path ^ occurring_intervals. :- func close_path(path) = path. close_path(Path0) = Path :- - Path0 = path(FlushState, CurSegment, FirstSegment0, OtherSegments0, - FlushAnchors, IntervalIds), - ( FlushState = current_is_before_first_flush -> - require(set__empty(FirstSegment0), - "close_path: FirstSegment0 not empty"), - FirstSegment = CurSegment, - OtherSegments = OtherSegments0 - ; set__empty(CurSegment) -> - FirstSegment = FirstSegment0, - OtherSegments = OtherSegments0 - ; - FirstSegment = FirstSegment0, - OtherSegments = [CurSegment | OtherSegments0] - ), - Path = path(current_is_after_first_flush, set__init, - FirstSegment, OtherSegments, FlushAnchors, IntervalIds). + Path0 = path(FlushState, CurSegment, FirstSegment0, OtherSegments0, + FlushAnchors, IntervalIds), + ( FlushState = current_is_before_first_flush -> + require(set__empty(FirstSegment0), + "close_path: FirstSegment0 not empty"), + FirstSegment = CurSegment, + OtherSegments = OtherSegments0 + ; set__empty(CurSegment) -> + FirstSegment = FirstSegment0, + OtherSegments = OtherSegments0 + ; + FirstSegment = FirstSegment0, + OtherSegments = [CurSegment | OtherSegments0] + ), + Path = path(current_is_after_first_flush, set__init, + FirstSegment, OtherSegments, FlushAnchors, IntervalIds). :- func add_interval_to_path(interval_id, set(prog_var), path) = path. add_interval_to_path(IntervalId, Vars, !.Path) = !:Path :- - ( set__empty(Vars) -> - true - ; - CurSegment0 = !.Path ^ current_segment, - CurSegment = set__union(Vars, CurSegment0), - OccurringIntervals0 = !.Path ^ occurring_intervals, - svset__insert(IntervalId, - OccurringIntervals0, OccurringIntervals), - !:Path = !.Path ^ current_segment := CurSegment, - !:Path = !.Path ^ occurring_intervals := OccurringIntervals - ). + ( set__empty(Vars) -> + true + ; + CurSegment0 = !.Path ^ current_segment, + CurSegment = set__union(Vars, CurSegment0), + OccurringIntervals0 = !.Path ^ occurring_intervals, + svset__insert(IntervalId, OccurringIntervals0, OccurringIntervals), + !:Path = !.Path ^ current_segment := CurSegment, + !:Path = !.Path ^ occurring_intervals := OccurringIntervals + ). :- func add_anchor_to_path(anchor, path) = path. add_anchor_to_path(Anchor, !.Path) = !:Path :- - Anchors0 = !.Path ^ flush_anchors, - svset__insert(Anchor, Anchors0, Anchors), - !:Path = !.Path ^ flush_anchors := Anchors. + Anchors0 = !.Path ^ flush_anchors, + svset__insert(Anchor, Anchors0, Anchors), + !:Path = !.Path ^ flush_anchors := Anchors. :- func anchor_requires_close(interval_info, anchor) = bool. anchor_requires_close(_, proc_start) = no. anchor_requires_close(_, proc_end) = yes. anchor_requires_close(IntervalInfo, branch_start(_, GoalPath)) = - resume_save_status_requires_close(ResumeSaveStatus) :- - map__lookup(IntervalInfo ^ branch_resume_map, GoalPath, - ResumeSaveStatus). + resume_save_status_requires_close(ResumeSaveStatus) :- + map__lookup(IntervalInfo ^ branch_resume_map, GoalPath, ResumeSaveStatus). anchor_requires_close(_, cond_then(_)) = no. anchor_requires_close(_, branch_end(BranchConstruct, _)) = - ( BranchConstruct = neg -> - no - ; - yes - ). + ( BranchConstruct = neg -> + no + ; + yes + ). anchor_requires_close(_, call_site(_)) = yes. :- func resume_save_status_requires_close(resume_save_status) = bool. @@ -741,7 +710,7 @@ resume_save_status_requires_close(has_no_resume_save) = no. :- pred may_have_no_successor(anchor::in) is semidet. may_have_no_successor(Anchor) :- - may_have_no_successor(Anchor, yes). + may_have_no_successor(Anchor, yes). :- pred may_have_no_successor(anchor::in, bool::out) is det. @@ -750,12 +719,12 @@ may_have_no_successor(proc_end, yes). may_have_no_successor(branch_start(_, _), no). may_have_no_successor(cond_then(_), no). may_have_no_successor(branch_end(_, _), no). -may_have_no_successor(call_site(_), yes). % if the call cannot succeed +may_have_no_successor(call_site(_), yes). % if the call cannot succeed :- pred may_have_one_successor(anchor::in) is semidet. may_have_one_successor(Anchor) :- - may_have_one_successor(Anchor, yes). + may_have_one_successor(Anchor, yes). :- pred may_have_one_successor(anchor::in, bool::out) is det. @@ -769,18 +738,18 @@ may_have_one_successor(call_site(_), yes). :- pred may_have_more_successors(anchor::in) is semidet. may_have_more_successors(Anchor) :- - may_have_more_successors(Anchor, yes). + may_have_more_successors(Anchor, yes). :- pred may_have_more_successors(anchor::in, bool::out) is det. may_have_more_successors(proc_start, no). may_have_more_successors(proc_end, no). may_have_more_successors(branch_start(Type, _), MayHave) :- - ( Type = neg -> - MayHave = no - ; - MayHave = yes - ). + ( Type = neg -> + MayHave = no + ; + MayHave = yes + ). may_have_more_successors(cond_then(_), no). may_have_more_successors(branch_end(_, _), no). may_have_more_successors(call_site(_), no). @@ -788,239 +757,227 @@ may_have_more_successors(call_site(_), no). %-----------------------------------------------------------------------------% :- pred find_all_branches_from_cur_interval(set(prog_var)::in, - match_info::out, interval_info::in, stack_opt_info::in) is det. + match_info::out, interval_info::in, stack_opt_info::in) is det. find_all_branches_from_cur_interval(RelevantVars, MatchInfo, IntervalInfo, - StackOptInfo) :- - IntervalId = IntervalInfo ^ cur_interval, - map__lookup(IntervalInfo ^ interval_vars, IntervalId, IntervalVars), - IntervalRelevantVars = set__intersect(RelevantVars, IntervalVars), - Path0 = path(current_is_before_first_flush, IntervalRelevantVars, - set__init, [], set__init, set__init), - AllPaths0 = all_paths(set__make_singleton_set(Path0), no, set__init), - find_all_branches(RelevantVars, IntervalId, no, IntervalInfo, - StackOptInfo, AllPaths0, AllPaths), - AllPaths = all_paths(Paths, AfterModelNon, RelevantAfter), - set__to_sorted_list(Paths, PathList), - list__map3(extract_match_and_save_info, PathList, - MatchInputs, FlushAnchorSets, OccurringIntervalSets), - FlushAnchors = set__union_list(FlushAnchorSets), - OccurringIntervals = set__union_list(OccurringIntervalSets), - MatchInfo = match_info(MatchInputs, RelevantAfter, AfterModelNon, - FlushAnchors, OccurringIntervals). + StackOptInfo) :- + IntervalId = IntervalInfo ^ cur_interval, + map__lookup(IntervalInfo ^ interval_vars, IntervalId, IntervalVars), + IntervalRelevantVars = set__intersect(RelevantVars, IntervalVars), + Path0 = path(current_is_before_first_flush, IntervalRelevantVars, + set__init, [], set__init, set__init), + AllPaths0 = all_paths(set__make_singleton_set(Path0), no, set__init), + find_all_branches(RelevantVars, IntervalId, no, IntervalInfo, + StackOptInfo, AllPaths0, AllPaths), + AllPaths = all_paths(Paths, AfterModelNon, RelevantAfter), + set__to_sorted_list(Paths, PathList), + list__map3(extract_match_and_save_info, PathList, + MatchInputs, FlushAnchorSets, OccurringIntervalSets), + FlushAnchors = set__union_list(FlushAnchorSets), + OccurringIntervals = set__union_list(OccurringIntervalSets), + MatchInfo = match_info(MatchInputs, RelevantAfter, AfterModelNon, + FlushAnchors, OccurringIntervals). :- pred find_all_branches(set(prog_var)::in, interval_id::in, - maybe(anchor)::in, interval_info::in, stack_opt_info::in, - all_paths::in, all_paths::out) is det. + maybe(anchor)::in, interval_info::in, stack_opt_info::in, + all_paths::in, all_paths::out) is det. find_all_branches(RelevantVars, IntervalId, MaybeSearchAnchor0, - IntervalInfo, StackOptInfo, AllPaths0, AllPaths) :- - map__lookup(IntervalInfo ^ interval_end, IntervalId, End), - map__lookup(IntervalInfo ^ interval_succ, IntervalId, SuccessorIds), - ( - SuccessorIds = [], - require(may_have_no_successor(End), - "find_all_branches: unexpected no successor"), - % require(unify(MaybeSearchAnchor0, no), - % "find_all_branches: no successor while in search"), - % that test may fail if we come to a call that cannot succeed - AllPaths = AllPaths0 - ; - SuccessorIds = [SuccessorId | MoreSuccessorIds], - ( - MoreSuccessorIds = [], - require(may_have_one_successor(End), - "find_all_branches: unexpected one successor") - ; - MoreSuccessorIds = [_ | _], - require(may_have_more_successors(End), - "find_all_branches: unexpected more successors") - ), - ( - MaybeSearchAnchor0 = yes(SearchAnchor0), - End = SearchAnchor0 - -> - AllPaths0 = all_paths(Paths0, AfterModelNon, _), - AllPaths = all_paths(Paths0, AfterModelNon, set__init) - ; - End = branch_end(_, EndGoalPath), - map__lookup(IntervalInfo ^ branch_end_map, EndGoalPath, - BranchEndInfo), - OnStackAfterBranch = - BranchEndInfo ^ flushed_after_branch, - AccessedAfterBranch = - BranchEndInfo ^ accessed_after_branch, - NeededAfterBranch = set__union(OnStackAfterBranch, - AccessedAfterBranch), - RelevantAfter = set__intersect(RelevantVars, - NeededAfterBranch), - set__non_empty(RelevantAfter) - -> - AllPaths0 = all_paths(Paths0, AfterModelNon, _), - AllPaths = all_paths(Paths0, AfterModelNon, - RelevantAfter) - ; - find_all_branches_from(End, RelevantVars, - MaybeSearchAnchor0, IntervalInfo, StackOptInfo, - [SuccessorId | MoreSuccessorIds], - AllPaths0, AllPaths) - ) - ). + IntervalInfo, StackOptInfo, !AllPaths) :- + map__lookup(IntervalInfo ^ interval_end, IntervalId, End), + map__lookup(IntervalInfo ^ interval_succ, IntervalId, SuccessorIds), + ( + SuccessorIds = [], + require(may_have_no_successor(End), + "find_all_branches: unexpected no successor") + % require(unify(MaybeSearchAnchor0, no), + % "find_all_branches: no successor while in search"), + % that test may fail if we come to a call that cannot succeed + ; + SuccessorIds = [SuccessorId | MoreSuccessorIds], + ( + MoreSuccessorIds = [], + require(may_have_one_successor(End), + "find_all_branches: unexpected one successor") + ; + MoreSuccessorIds = [_ | _], + require(may_have_more_successors(End), + "find_all_branches: unexpected more successors") + ), + ( + MaybeSearchAnchor0 = yes(SearchAnchor0), + End = SearchAnchor0 + -> + !:AllPaths = !.AllPaths ^ used_after_scope := set__init + ; + End = branch_end(_, EndGoalPath), + map__lookup(IntervalInfo ^ branch_end_map, EndGoalPath, + BranchEndInfo), + OnStackAfterBranch = BranchEndInfo ^ flushed_after_branch, + AccessedAfterBranch = BranchEndInfo ^ accessed_after_branch, + NeededAfterBranch = set__union(OnStackAfterBranch, + AccessedAfterBranch), + RelevantAfter = set__intersect(RelevantVars, NeededAfterBranch), + set__non_empty(RelevantAfter) + -> + !:AllPaths = !.AllPaths ^ used_after_scope := RelevantAfter + ; + find_all_branches_from(End, RelevantVars, + MaybeSearchAnchor0, IntervalInfo, StackOptInfo, + [SuccessorId | MoreSuccessorIds], !AllPaths) + ) + ). :- pred find_all_branches_from(anchor::in, set(prog_var)::in, - maybe(anchor)::in, interval_info::in, stack_opt_info::in, - list(interval_id)::in, all_paths::in, all_paths::out) is det. + maybe(anchor)::in, interval_info::in, stack_opt_info::in, + list(interval_id)::in, all_paths::in, all_paths::out) is det. find_all_branches_from(End, RelevantVars, MaybeSearchAnchor0, IntervalInfo, - StackOptInfo, SuccessorIds, !AllPaths) :- - ( anchor_requires_close(IntervalInfo, End) = yes -> - Paths0 = !.AllPaths ^ paths_so_far, - Paths1 = set__map(close_path, Paths0), - !:AllPaths = !.AllPaths ^ paths_so_far := Paths1 - ; - true - ), - StackOptParams = StackOptInfo ^ stack_opt_params, - FullPath = StackOptParams ^ full_path, - ( - FullPath = yes, - End = branch_start(disj, EndGoalPath) - -> - MaybeSearchAnchor1 = yes(branch_end(disj, EndGoalPath)), - one_after_another(RelevantVars, MaybeSearchAnchor1, - IntervalInfo, StackOptInfo, SuccessorIds, !AllPaths), - map__lookup(IntervalInfo ^ branch_end_map, EndGoalPath, - BranchEndInfo), - ContinueId = BranchEndInfo ^ interval_after_branch, - apply_interval_find_all_branches(RelevantVars, - MaybeSearchAnchor0, IntervalInfo, StackOptInfo, - ContinueId, !AllPaths) - ; - FullPath = yes, - End = branch_start(ite, EndGoalPath) - -> - ( SuccessorIds = [ElseStartIdPrime, CondStartIdPrime] -> - ElseStartId = ElseStartIdPrime, - CondStartId = CondStartIdPrime - ; - error("find_all_branches_from: ite not else, cond") - ), - MaybeSearchAnchorCond = yes(cond_then(EndGoalPath)), - apply_interval_find_all_branches(RelevantVars, - MaybeSearchAnchorCond, IntervalInfo, StackOptInfo, - CondStartId, !AllPaths), - MaybeSearchAnchorEnd = yes(branch_end(ite, EndGoalPath)), - CondEndMap = IntervalInfo ^ cond_end_map, - map__lookup(CondEndMap, EndGoalPath, ThenStartId), - one_after_another(RelevantVars, MaybeSearchAnchorEnd, - IntervalInfo, StackOptInfo, [ThenStartId, ElseStartId], - !AllPaths), - map__lookup(IntervalInfo ^ branch_end_map, EndGoalPath, - BranchEndInfo), - ContinueId = BranchEndInfo ^ interval_after_branch, - apply_interval_find_all_branches(RelevantVars, - MaybeSearchAnchor0, IntervalInfo, StackOptInfo, - ContinueId, !AllPaths) - ; - End = branch_start(BranchType, EndGoalPath) - -> - MaybeSearchAnchor1 = yes(branch_end(BranchType, EndGoalPath)), - list__map(apply_interval_find_all_branches_map(RelevantVars, - MaybeSearchAnchor1, IntervalInfo, StackOptInfo, - !.AllPaths), - SuccessorIds, AllPathsList), - consolidate_after_join(AllPathsList, !:AllPaths), - map__lookup(IntervalInfo ^ branch_end_map, EndGoalPath, - BranchEndInfo), - ContinueId = BranchEndInfo ^ interval_after_branch, - apply_interval_find_all_branches(RelevantVars, - MaybeSearchAnchor0, IntervalInfo, StackOptInfo, - ContinueId, !AllPaths) - ; - ( SuccessorIds = [SuccessorId] -> - apply_interval_find_all_branches(RelevantVars, - MaybeSearchAnchor0, IntervalInfo, - StackOptInfo, SuccessorId, !AllPaths) - ; - error("more successor ids") - ) - ). + StackOptInfo, SuccessorIds, !AllPaths) :- + ( anchor_requires_close(IntervalInfo, End) = yes -> + Paths0 = !.AllPaths ^ paths_so_far, + Paths1 = set__map(close_path, Paths0), + !:AllPaths = !.AllPaths ^ paths_so_far := Paths1 + ; + true + ), + StackOptParams = StackOptInfo ^ stack_opt_params, + FullPath = StackOptParams ^ full_path, + ( + FullPath = yes, + End = branch_start(disj, EndGoalPath) + -> + MaybeSearchAnchor1 = yes(branch_end(disj, EndGoalPath)), + one_after_another(RelevantVars, MaybeSearchAnchor1, + IntervalInfo, StackOptInfo, SuccessorIds, !AllPaths), + map__lookup(IntervalInfo ^ branch_end_map, EndGoalPath, + BranchEndInfo), + ContinueId = BranchEndInfo ^ interval_after_branch, + apply_interval_find_all_branches(RelevantVars, + MaybeSearchAnchor0, IntervalInfo, StackOptInfo, + ContinueId, !AllPaths) + ; + FullPath = yes, + End = branch_start(ite, EndGoalPath) + -> + ( SuccessorIds = [ElseStartIdPrime, CondStartIdPrime] -> + ElseStartId = ElseStartIdPrime, + CondStartId = CondStartIdPrime + ; + error("find_all_branches_from: ite not else, cond") + ), + MaybeSearchAnchorCond = yes(cond_then(EndGoalPath)), + apply_interval_find_all_branches(RelevantVars, + MaybeSearchAnchorCond, IntervalInfo, StackOptInfo, + CondStartId, !AllPaths), + MaybeSearchAnchorEnd = yes(branch_end(ite, EndGoalPath)), + CondEndMap = IntervalInfo ^ cond_end_map, + map__lookup(CondEndMap, EndGoalPath, ThenStartId), + one_after_another(RelevantVars, MaybeSearchAnchorEnd, + IntervalInfo, StackOptInfo, [ThenStartId, ElseStartId], + !AllPaths), + map__lookup(IntervalInfo ^ branch_end_map, EndGoalPath, + BranchEndInfo), + ContinueId = BranchEndInfo ^ interval_after_branch, + apply_interval_find_all_branches(RelevantVars, + MaybeSearchAnchor0, IntervalInfo, StackOptInfo, + ContinueId, !AllPaths) + ; + End = branch_start(BranchType, EndGoalPath) + -> + MaybeSearchAnchor1 = yes(branch_end(BranchType, EndGoalPath)), + list__map(apply_interval_find_all_branches_map(RelevantVars, + MaybeSearchAnchor1, IntervalInfo, StackOptInfo, !.AllPaths), + SuccessorIds, AllPathsList), + consolidate_after_join(AllPathsList, !:AllPaths), + map__lookup(IntervalInfo ^ branch_end_map, EndGoalPath, BranchEndInfo), + ContinueId = BranchEndInfo ^ interval_after_branch, + apply_interval_find_all_branches(RelevantVars, + MaybeSearchAnchor0, IntervalInfo, StackOptInfo, + ContinueId, !AllPaths) + ; + ( SuccessorIds = [SuccessorId] -> + apply_interval_find_all_branches(RelevantVars, + MaybeSearchAnchor0, IntervalInfo, + StackOptInfo, SuccessorId, !AllPaths) + ; + error("more successor ids") + ) + ). :- pred one_after_another(set(prog_var)::in, maybe(anchor)::in, - interval_info::in, stack_opt_info::in, list(interval_id)::in, - all_paths::in, all_paths::out) is det. + interval_info::in, stack_opt_info::in, list(interval_id)::in, + all_paths::in, all_paths::out) is det. one_after_another(_, _, _, _, [], !AllPaths). one_after_another(RelevantVars, MaybeSearchAnchor1, IntervalInfo, StackOptInfo, - [SuccessorId | MoreSuccessorIds], !AllPaths) :- - apply_interval_find_all_branches(RelevantVars, MaybeSearchAnchor1, - IntervalInfo, StackOptInfo, SuccessorId, !AllPaths), - one_after_another(RelevantVars, MaybeSearchAnchor1, IntervalInfo, - StackOptInfo, MoreSuccessorIds, !AllPaths). - - % We need a version of apply_interval_find_all_branches with this - % argument order for use in higher order caode. + [SuccessorId | MoreSuccessorIds], !AllPaths) :- + apply_interval_find_all_branches(RelevantVars, MaybeSearchAnchor1, + IntervalInfo, StackOptInfo, SuccessorId, !AllPaths), + one_after_another(RelevantVars, MaybeSearchAnchor1, IntervalInfo, + StackOptInfo, MoreSuccessorIds, !AllPaths). + % We need a version of apply_interval_find_all_branches with this + % argument order for use in higher order caode. + % :- pred apply_interval_find_all_branches_map(set(prog_var)::in, - maybe(anchor)::in, interval_info::in, stack_opt_info::in, - all_paths::in, interval_id::in, all_paths::out) is det. + maybe(anchor)::in, interval_info::in, stack_opt_info::in, + all_paths::in, interval_id::in, all_paths::out) is det. apply_interval_find_all_branches_map(RelevantVars, MaybeSearchAnchor0, - IntervalInfo, StackOptInfo, !.AllPaths, IntervalId, - !:AllPaths) :- - apply_interval_find_all_branches(RelevantVars, MaybeSearchAnchor0, - IntervalInfo, StackOptInfo, IntervalId, !AllPaths). + IntervalInfo, StackOptInfo, !.AllPaths, IntervalId, + !:AllPaths) :- + apply_interval_find_all_branches(RelevantVars, MaybeSearchAnchor0, + IntervalInfo, StackOptInfo, IntervalId, !AllPaths). :- pred apply_interval_find_all_branches(set(prog_var)::in, - maybe(anchor)::in, interval_info::in, stack_opt_info::in, - interval_id::in, all_paths::in, all_paths::out) is det. + maybe(anchor)::in, interval_info::in, stack_opt_info::in, + interval_id::in, all_paths::in, all_paths::out) is det. apply_interval_find_all_branches(RelevantVars, MaybeSearchAnchor0, - IntervalInfo, StackOptInfo, IntervalId, !AllPaths) :- - map__lookup(IntervalInfo ^ interval_vars, IntervalId, IntervalVars), - RelevantIntervalVars = set__intersect(RelevantVars, IntervalVars), - !.AllPaths = all_paths(Paths0, AfterModelNon0, RelevantAfter), - Paths1 = set__map( - add_interval_to_path(IntervalId, RelevantIntervalVars), - Paths0), - map__lookup(IntervalInfo ^ interval_start, IntervalId, Start), - ( - % Check if intervals starting at Start use any RelevantVars. - ( Start = call_site(_) - ; Start = branch_end(_, _) - ; Start = branch_start(_, _) - ), - map__search(IntervalInfo ^ anchor_follow_map, Start, - StartInfo), - StartInfo = AnchorFollowVars - _, - set__intersect(RelevantVars, AnchorFollowVars, NeededVars), - set__non_empty(NeededVars) - -> - Paths2 = set__map(add_anchor_to_path(Start), Paths1) - ; - Paths2 = Paths1 - ), - ( set__member(Start, IntervalInfo ^ model_non_anchors) -> - AfterModelNon = yes - ; - AfterModelNon = AfterModelNon0 - ), - !:AllPaths = all_paths(Paths2, AfterModelNon, RelevantAfter), - find_all_branches(RelevantVars, IntervalId, - MaybeSearchAnchor0, IntervalInfo, StackOptInfo, !AllPaths). + IntervalInfo, StackOptInfo, IntervalId, !AllPaths) :- + map__lookup(IntervalInfo ^ interval_vars, IntervalId, IntervalVars), + RelevantIntervalVars = set__intersect(RelevantVars, IntervalVars), + !.AllPaths = all_paths(Paths0, AfterModelNon0, RelevantAfter), + Paths1 = set__map(add_interval_to_path(IntervalId, RelevantIntervalVars), + Paths0), + map__lookup(IntervalInfo ^ interval_start, IntervalId, Start), + ( + % Check if intervals starting at Start use any RelevantVars. + ( Start = call_site(_) + ; Start = branch_end(_, _) + ; Start = branch_start(_, _) + ), + map__search(IntervalInfo ^ anchor_follow_map, Start, StartInfo), + StartInfo = AnchorFollowVars - _, + set__intersect(RelevantVars, AnchorFollowVars, NeededVars), + set__non_empty(NeededVars) + -> + Paths2 = set__map(add_anchor_to_path(Start), Paths1) + ; + Paths2 = Paths1 + ), + ( set__member(Start, IntervalInfo ^ model_non_anchors) -> + AfterModelNon = yes + ; + AfterModelNon = AfterModelNon0 + ), + !:AllPaths = all_paths(Paths2, AfterModelNon, RelevantAfter), + find_all_branches(RelevantVars, IntervalId, + MaybeSearchAnchor0, IntervalInfo, StackOptInfo, !AllPaths). :- pred consolidate_after_join(list(all_paths)::in, all_paths::out) is det. consolidate_after_join([], _) :- - error("consolidate_after_join: no paths to join"). + error("consolidate_after_join: no paths to join"). consolidate_after_join([First | Rest], AllPaths) :- - PathsList = list__map(project_paths_from_all_paths, [First | Rest]), - Paths0 = set__union_list(PathsList), - Paths = compress_paths(Paths0), - AfterModelNonList = list__map(project_after_model_non_from_all_paths, - [First | Rest]), - bool__or_list(AfterModelNonList, AfterModelNon), - AllPaths = all_paths(Paths, AfterModelNon, set__init). + PathsList = list__map(project_paths_from_all_paths, [First | Rest]), + Paths0 = set__union_list(PathsList), + Paths = compress_paths(Paths0), + AfterModelNonList = list__map(project_after_model_non_from_all_paths, + [First | Rest]), + bool__or_list(AfterModelNonList, AfterModelNon), + AllPaths = all_paths(Paths, AfterModelNon, set__init). :- func project_paths_from_all_paths(all_paths) = set(path). @@ -1029,127 +986,121 @@ project_paths_from_all_paths(all_paths(Paths, _, _)) = Paths. :- func project_after_model_non_from_all_paths(all_paths) = bool. project_after_model_non_from_all_paths(all_paths(_, AfterModelNon, _)) = - AfterModelNon. + AfterModelNon. :- func compress_paths(set(path)) = set(path). compress_paths(Paths) = Paths. - % XXX should reduce the cardinality of Paths below a threshold. - % XXX should try to preserve the current segment. + % XXX should reduce the cardinality of Paths below a threshold. + % XXX should try to preserve the current segment. %-----------------------------------------------------------------------------% % This predicate can help debug the correctness of the transformation. :- pred maybe_write_progress_message(string::in, int::in, int::in, - proc_info::in, module_info::in, io::di, io::uo) is det. + proc_info::in, module_info::in, io::di, io::uo) is det. maybe_write_progress_message(Message, DebugStackOpt, PredIdInt, ProcInfo, - ModuleInfo, !IO) :- - ( DebugStackOpt = PredIdInt -> - io__write_string(Message, !IO), - io__write_string(":\n", !IO), - proc_info_goal(ProcInfo, Goal), - proc_info_varset(ProcInfo, VarSet), - hlds_out__write_goal(Goal, ModuleInfo, VarSet, yes, 0, "\n", - !IO), - io__write_string("\n", !IO) - ; - true - ). + ModuleInfo, !IO) :- + ( DebugStackOpt = PredIdInt -> + io__write_string(Message, !IO), + io__write_string(":\n", !IO), + proc_info_goal(ProcInfo, Goal), + proc_info_varset(ProcInfo, VarSet), + hlds_out__write_goal(Goal, ModuleInfo, VarSet, yes, 0, "\n", !IO), + io__write_string("\n", !IO) + ; + true + ). %-----------------------------------------------------------------------------% -% This predicate (along with dump_interval_info) can help debug the -% performance of the transformation. - -:- pred dump_stack_opt_info(stack_opt_info::in, io::di, io::uo) - is det. + % This predicate (along with dump_interval_info) can help debug the + % performance of the transformation. + % +:- pred dump_stack_opt_info(stack_opt_info::in, io::di, io::uo) is det. dump_stack_opt_info(StackOptInfo, !IO) :- - map__to_assoc_list(StackOptInfo ^ left_anchor_inserts, Inserts), - io__write_string("\nANCHOR INSERT:\n", !IO), - list__foldl(dump_anchor_inserts, Inserts, !IO), + map__to_assoc_list(StackOptInfo ^ left_anchor_inserts, Inserts), + io__write_string("\nANCHOR INSERT:\n", !IO), + list__foldl(dump_anchor_inserts, Inserts, !IO), - io__write_string("\nMATCHING RESULTS:\n", !IO), - list__foldl(dump_matching_result, - StackOptInfo ^ matching_results, !IO), - io__write_string("\n", !IO). + io__write_string("\nMATCHING RESULTS:\n", !IO), + list__foldl(dump_matching_result, StackOptInfo ^ matching_results, !IO), + io__write_string("\n", !IO). :- pred dump_anchor_inserts(pair(anchor, list(insert_spec))::in, - io::di, io::uo) is det. + io::di, io::uo) is det. dump_anchor_inserts(Anchor - InsertSpecs, !IO) :- - io__write_string("\ninsertions after ", !IO), - io__write(Anchor, !IO), - io__write_string(":\n", !IO), - list__foldl(dump_insert, InsertSpecs, !IO). + io__write_string("\ninsertions after ", !IO), + io__write(Anchor, !IO), + io__write_string(":\n", !IO), + list__foldl(dump_insert, InsertSpecs, !IO). :- pred dump_insert(insert_spec::in, io::di, io::uo) is det. dump_insert(insert_spec(Goal, Vars), !IO) :- - list__map(term__var_to_int, set__to_sorted_list(Vars), VarNums), - io__write_string("vars [", !IO), - write_int_list(VarNums, !IO), - io__write_string("]: ", !IO), - ( - Goal = unify(_, _, _, Unification, _) - _, - Unification = deconstruct(CellVar, ConsId, ArgVars, _,_,_) - -> - term__var_to_int(CellVar, CellVarNum), - io__write_int(CellVarNum, !IO), - io__write_string(" => ", !IO), - mercury_output_cons_id(ConsId, does_not_need_brackets, !IO), - io__write_string("(", !IO), - list__map(term__var_to_int, ArgVars, ArgVarNums), - write_int_list(ArgVarNums, !IO), - io__write_string(")\n", !IO) - ; - io__write_string("BAD INSERT GOAL\n", !IO) - ). + list__map(term__var_to_int, set__to_sorted_list(Vars), VarNums), + io__write_string("vars [", !IO), + write_int_list(VarNums, !IO), + io__write_string("]: ", !IO), + ( + Goal = unify(_, _, _, Unification, _) - _, + Unification = deconstruct(CellVar, ConsId, ArgVars, _,_,_) + -> + term__var_to_int(CellVar, CellVarNum), + io__write_int(CellVarNum, !IO), + io__write_string(" => ", !IO), + mercury_output_cons_id(ConsId, does_not_need_brackets, !IO), + io__write_string("(", !IO), + list__map(term__var_to_int, ArgVars, ArgVarNums), + write_int_list(ArgVarNums, !IO), + io__write_string(")\n", !IO) + ; + io__write_string("BAD INSERT GOAL\n", !IO) + ). :- pred dump_matching_result(matching_result::in, - io::di, io::uo) is det. + io::di, io::uo) is det. dump_matching_result(MatchingResult, !IO) :- - MatchingResult = matching_result(CellVar, ConsId, - ArgVars, ViaCellVars, GoalPath, - PotentialIntervals, InsertIntervals, - PotentialAnchors, InsertAnchors), - io__write_string("\nmatching result at ", !IO), - io__write(GoalPath, !IO), - io__write_string("\n", !IO), - term__var_to_int(CellVar, CellVarNum), - list__map(term__var_to_int, ArgVars, ArgVarNums), - list__map(term__var_to_int, set__to_sorted_list(ViaCellVars), - ViaCellVarNums), - io__write_int(CellVarNum, !IO), - io__write_string(" => ", !IO), - mercury_output_cons_id(ConsId, does_not_need_brackets, !IO), - io__write_string("(", !IO), - write_int_list(ArgVarNums, !IO), - io__write_string("): via cell ", !IO), - write_int_list(ViaCellVarNums, !IO), - io__write_string("\n", !IO), + MatchingResult = matching_result(CellVar, ConsId, ArgVars, ViaCellVars, + GoalPath, PotentialIntervals, InsertIntervals, + PotentialAnchors, InsertAnchors), + io__write_string("\nmatching result at ", !IO), + io__write(GoalPath, !IO), + io__write_string("\n", !IO), + term__var_to_int(CellVar, CellVarNum), + list__map(term__var_to_int, ArgVars, ArgVarNums), + list__map(term__var_to_int, set__to_sorted_list(ViaCellVars), + ViaCellVarNums), + io__write_int(CellVarNum, !IO), + io__write_string(" => ", !IO), + mercury_output_cons_id(ConsId, does_not_need_brackets, !IO), + io__write_string("(", !IO), + write_int_list(ArgVarNums, !IO), + io__write_string("): via cell ", !IO), + write_int_list(ViaCellVarNums, !IO), + io__write_string("\n", !IO), - io__write_string("potential intervals: ", !IO), - PotentialIntervalNums = list__map(interval_id_to_int, - set__to_sorted_list(PotentialIntervals)), - write_int_list(PotentialIntervalNums, !IO), - io__write_string("\n", !IO), - io__write_string("insert intervals: ", !IO), - InsertIntervalNums = list__map(interval_id_to_int, - set__to_sorted_list(InsertIntervals)), - write_int_list(InsertIntervalNums, !IO), - io__write_string("\n", !IO), + io__write_string("potential intervals: ", !IO), + PotentialIntervalNums = list__map(interval_id_to_int, + set__to_sorted_list(PotentialIntervals)), + write_int_list(PotentialIntervalNums, !IO), + io__write_string("\n", !IO), + io__write_string("insert intervals: ", !IO), + InsertIntervalNums = list__map(interval_id_to_int, + set__to_sorted_list(InsertIntervals)), + write_int_list(InsertIntervalNums, !IO), + io__write_string("\n", !IO), - io__write_string("potential anchors: ", !IO), - io__write_list(set__to_sorted_list(PotentialAnchors), " ", io__write, - !IO), - io__write_string("\n", !IO), - io__write_string("insert anchors: ", !IO), - io__write_list(set__to_sorted_list(InsertAnchors), " ", io__write, - !IO), - io__write_string("\n", !IO). + io__write_string("potential anchors: ", !IO), + io__write_list(set__to_sorted_list(PotentialAnchors), " ", io__write, !IO), + io__write_string("\n", !IO), + io__write_string("insert anchors: ", !IO), + io__write_list(set__to_sorted_list(InsertAnchors), " ", io__write, !IO), + io__write_string("\n", !IO). %-----------------------------------------------------------------------------% diff --git a/compiler/timestamp.m b/compiler/timestamp.m index 0d6416be2..134636fe5 100644 --- a/compiler/timestamp.m +++ b/compiler/timestamp.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 2001-2002, 2004-2005 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. @@ -15,36 +17,34 @@ :- import_module time. - % A `timestamp' is similar to a `time_t' except that - % timestamps are system independent. A timestamp string - % (obtained using time__timestamp_to_string) written on - % one system can be read on any other system. - % Comparison of values of type `timestamp' (via compare/3) - % is equivalent to comparison of the times represented. + % A `timestamp' is similar to a `time_t' except that timestamps are system + % independent. A timestamp string (obtained using timestamp_to_string) + % written on one system can be read on any other system. Comparison of + % values of type `timestamp' (via compare/3) is equivalent to comparison + % of the times represented. :- type timestamp. - % time_t_to_timestamp(Time) = Timestamp: - % Converts the calendar time value `Time' into a timestamp. - % Equivalent to `gm_time_to_timestamp(gmtime(Time))'. + % Converts the calendar time value `Time' into a timestamp. + % Equivalent to `gm_time_to_timestamp(gmtime(Time))'. + % :-func time_t_to_timestamp(time_t) = timestamp. - % timestamp_to_string(Timestamp) = String: - % Converts `Timestamp' into a string with format - % "yyyy-mm-dd hh:mm:ss", expressed as UTC. + % Converts a timestamp into a string with format "yyyy-mm-dd hh:mm:ss", + % expressed as UTC. + % :- func timestamp_to_string(timestamp) = string. - % string_to_timestamp(String) = Timestamp: - % Converts a string formatted as "yyyy-mm-dd hh:mm:ss", - % into a timestamp. Fails if the string does not have the - % correct format. + % Converts a string formatted as "yyyy-mm-dd hh:mm:ss", into a timestamp. + % Fails if the string does not have the correct format. + % :- func string_to_timestamp(string) = timestamp is semidet. - % oldest_timestamp = Timestamp: - % Return a timestamp which is older than any other timestamp. + % Return a timestamp which is older than any other timestamp. + % :- func oldest_timestamp = timestamp. - % newest_timestamp = Timestamp: - % Return a timestamp which is newer than any other timestamp. + % Return a timestamp which is newer than any other timestamp. + % :- func newest_timestamp = timestamp. %-----------------------------------------------------------------------------% @@ -55,13 +55,14 @@ :- import_module std_util. :- import_module string. - % A timestamp is a string formatted as "yyyy-mm-dd hh:mm:ss" - % representing a time expressed as UTC (Universal Coordinated Time). - % - % We use a no-tag type rather than an abstract equivalence type - % to avoid type errors with abstract equivalence types in the hlc - % back-end. -:- type timestamp ---> timestamp(string). + % A timestamp is a string formatted as "yyyy-mm-dd hh:mm:ss" + % representing a time expressed as UTC (Universal Coordinated Time). + % + % We use a no-tag type rather than an abstract equivalence type + % to avoid type errors with abstract equivalence types in the hlc + % back-end. +:- type timestamp + ---> timestamp(string). oldest_timestamp = timestamp("0000-00-00 00:00:00"). newest_timestamp = timestamp("9999-99-99 99:99:99"). @@ -71,108 +72,103 @@ time_t_to_timestamp(Time) = gmtime_to_timestamp(time__gmtime(Time)). :- func gmtime_to_timestamp(tm) = timestamp. gmtime_to_timestamp(tm(Year, Month, MD, Hrs, Min, Sec, YD, WD, DST)) = - timestamp(gmtime_to_timestamp_2(Year, Month, MD, Hrs, Min, Sec, - YD, WD, maybe_dst_to_int(DST))). + timestamp(gmtime_to_timestamp_2(Year, Month, MD, Hrs, Min, Sec, + YD, WD, maybe_dst_to_int(DST))). -:- func gmtime_to_timestamp_2(int, int, int, int, - int, int, int, int, int) = string. +:- func gmtime_to_timestamp_2(int, int, int, int, int, int, int, int, int) + = string. :- pragma foreign_decl("C", " - #include ""mercury_string.h"" - #include + #include ""mercury_string.h"" + #include "). :- pragma foreign_proc("C", - gmtime_to_timestamp_2(Yr::in, Mnt::in, MD::in, Hrs::in, Min::in, - Sec::in, YD::in, WD::in, N::in) = (Result::out), - [will_not_call_mercury, promise_pure], + gmtime_to_timestamp_2(Yr::in, Mnt::in, MD::in, Hrs::in, Min::in, + Sec::in, YD::in, WD::in, N::in) = (Result::out), + [will_not_call_mercury, promise_pure], "{ - int size; - struct tm t; + int size; + struct tm t; - t.tm_sec = Sec; - t.tm_min = Min; - t.tm_hour = Hrs; - t.tm_mon = Mnt; - t.tm_year = Yr; - t.tm_wday = WD; - t.tm_mday = MD; - t.tm_yday = YD; - t.tm_isdst = N; + t.tm_sec = Sec; + t.tm_min = Min; + t.tm_hour = Hrs; + t.tm_mon = Mnt; + t.tm_year = Yr; + t.tm_wday = WD; + t.tm_mday = MD; + t.tm_yday = YD; + t.tm_isdst = N; - size = sizeof ""yyyy-mm-dd hh:mm:ss""; - MR_allocate_aligned_string_msg(Result, size - 1, MR_PROC_LABEL); + size = sizeof ""yyyy-mm-dd hh:mm:ss""; + MR_allocate_aligned_string_msg(Result, size - 1, MR_PROC_LABEL); - strftime(Result, size, ""%Y-%m-%d %H:%M:%S"", &t); + strftime(Result, size, ""%Y-%m-%d %H:%M:%S"", &t); }"). :- pragma foreign_proc("C#", - gmtime_to_timestamp_2(Yr::in, Mnt::in, MD::in, Hrs::in, Min::in, - Sec::in, _YD::in, _WD::in, _N::in) = (Result::out), - [will_not_call_mercury, promise_pure], + gmtime_to_timestamp_2(Yr::in, Mnt::in, MD::in, Hrs::in, Min::in, + Sec::in, _YD::in, _WD::in, _N::in) = (Result::out), + [will_not_call_mercury, promise_pure], "{ - System.DateTime t; - t = new System.DateTime(Yr + 1900, Mnt + 1, MD, Hrs, Min, Sec); + System.DateTime t; + t = new System.DateTime(Yr + 1900, Mnt + 1, MD, Hrs, Min, Sec); - string format_str = ""yyyy-MM-dd hh:mm:ss""; - Result = t.ToString(format_str); + string format_str = ""yyyy-MM-dd hh:mm:ss""; + Result = t.ToString(format_str); }"). :- func maybe_dst_to_int(maybe(dst)) = int. maybe_dst_to_int(M) = N :- - ( M = yes(DST), DST = daylight_time, - N = 1 - ; M = yes(DST), DST = standard_time, - N = 0 - ; M = no, - N = -1 - ). + ( M = yes(DST), DST = daylight_time, + N = 1 + ; M = yes(DST), DST = standard_time, + N = 0 + ; M = no, + N = -1 + ). timestamp_to_string(timestamp(Timestamp)) = Timestamp. string_to_timestamp(Timestamp) = timestamp(Timestamp) :- - % The if-then-else here is to force order of evaluation -- - % we need to ensure that the length check occurs before the - % calls to unsafe_undex to avoid dereferencing invalid pointers. - ( - string__length(Timestamp) `with_type` int = - string__length("yyyy-mm-dd hh:mm:ss") - -> - string__to_int(string__unsafe_substring(Timestamp, 0, 4), _), + % The if-then-else here is to force order of evaluation -- + % we need to ensure that the length check occurs before the + % calls to unsafe_undex to avoid dereferencing invalid pointers. + ( + string__length(Timestamp) : int = string__length("yyyy-mm-dd hh:mm:ss") + -> + string__to_int(string__unsafe_substring(Timestamp, 0, 4), _), - string__unsafe_index(Timestamp, 4, '-'), + string__unsafe_index(Timestamp, 4, '-'), - string__to_int(string__unsafe_substring(Timestamp, 5, 2), - Month), - Month >= 1, - Month =< 12, + string__to_int(string__unsafe_substring(Timestamp, 5, 2), Month), + Month >= 1, + Month =< 12, - string__unsafe_index(Timestamp, 7, '-'), + string__unsafe_index(Timestamp, 7, '-'), - string__to_int(string__unsafe_substring(Timestamp, 8, 2), Day), - Day >= 1, - Day =< 31, + string__to_int(string__unsafe_substring(Timestamp, 8, 2), Day), + Day >= 1, + Day =< 31, - string__unsafe_index(Timestamp, 10, ' '), + string__unsafe_index(Timestamp, 10, ' '), - string__to_int(string__unsafe_substring(Timestamp, 11, 2), - Hour), - Hour >= 0, - Hour =< 23, + string__to_int(string__unsafe_substring(Timestamp, 11, 2), Hour), + Hour >= 0, + Hour =< 23, - string__unsafe_index(Timestamp, 13, ':'), + string__unsafe_index(Timestamp, 13, ':'), - string__to_int(string__unsafe_substring(Timestamp, 14, 2), - Minute), - Minute >= 0, - Minute =< 59, + string__to_int(string__unsafe_substring(Timestamp, 14, 2), Minute), + Minute >= 0, + Minute =< 59, - string__unsafe_index(Timestamp, 16, ':'), + string__unsafe_index(Timestamp, 16, ':'), - string__to_int(string__unsafe_substring(Timestamp, 17, 2), - Second), - Second >= 0, - Second =< 61 % Seconds 60 and 61 are for leap seconds. - ; - fail - ). + string__to_int(string__unsafe_substring(Timestamp, 17, 2), Second), + Second >= 0, + Second =< 61 % Seconds 60 and 61 are for leap seconds. + ; + fail + ). diff --git a/compiler/top_level.m b/compiler/top_level.m index adff41b1c..6a6adab5a 100644 --- a/compiler/top_level.m +++ b/compiler/top_level.m @@ -1,43 +1,44 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 2002-2004 The University of Melbourne. +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% +% Copyright (C) 2002-2005 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. %-----------------------------------------------------------------------------% % -% This package contains the top-level stuff that uses all the -% other packages. In particular it contains the module mercury_compile.m, -% which defines main/2, and which invokes all the other parts of the -% Mercury compiler. -% +% This package contains the top-level stuff that uses all the other packages. +% In particular it contains the module mercury_compile.m, which defines main/2, +% and which invokes all the other parts of the Mercury compiler. :- module top_level. :- interface. -% the front-end phases +% The front-end phases. :- import_module check_hlds. :- import_module hlds. :- import_module mode_robdd. :- import_module parse_tree. :- import_module transform_hlds. -% back-ends that we currently use or plan to use +% Back-ends that we currently use or plan to use. :- import_module aditi_backend. :- import_module ll_backend. :- import_module ml_backend. -% incomplete back-ends +% Incomplete back-ends. :- import_module bytecode_backend. -% misc utilities +% Misc utilities. :- import_module backend_libs. :- import_module libs. :- include_module mercury_compile. % XXX It would be nicer to define `main' in top_level.mercury_compile, -% rather than defining it here. But that doesn't work with the -% Mercury compiler's .NET back-end, which assumes that main is defined -% in the program's top-level module. +% rather than defining it here. But that doesn't work with the Mercury +% compiler's .NET back-end, which assumes that main is defined in the program's +% top-level module. + :- use_module io. :- pred main(io.state::di, io.state::uo) is det. @@ -45,7 +46,8 @@ :- use_module top_level.mercury_compile. -main --> top_level.mercury_compile.real_main. +main(!IO) :- + top_level.mercury_compile.real_main(!IO). :- end_module top_level. diff --git a/compiler/trans_opt.m b/compiler/trans_opt.m index 72d1f4b7c..31a92443a 100644 --- a/compiler/trans_opt.m +++ b/compiler/trans_opt.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 1997-2005 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. @@ -7,39 +9,38 @@ % file: trans_opt.m % main author: crs % -% Transitive intermodule optimization allows the compiler to do -% intermodule optimization that depends on other .trans_opt files. In -% comparison to .opt files, .trans_opt files allow much more accurate -% optimization to occur, but at the cost of an increased number of -% compilations required. The fact that a .trans_opt file may depend on -% other .trans_opt files introduces the possibility of circular -% dependencies occuring. These circular dependencies would occur if the -% data in A.trans_opt depended on the data in B.trans_opt being correct, -% and vice-versa. +% Transitive intermodule optimization allows the compiler to do intermodule +% optimization that depends on other .trans_opt files. In comparison to .opt +% files, .trans_opt files allow much more accurate optimization to occur, +% but at the cost of an increased number of compilations required. The fact +% that a .trans_opt file may depend on other .trans_opt files introduces +% the possibility of circular dependencies occuring. These circular +% dependencies would occur if the data in A.trans_opt depended on the data +% in B.trans_opt being correct, and vice versa. % % The following system is used to ensure that circular dependencies cannot % occur: -% When mmake .depend is run, mmc calculates a suitable -% ordering. This ordering is then used to create each of the .d -% files. This allows make to ensure that all necessary trans_opt -% files are up to date before creating any other trans_opt files. -% This same information is used by mmc to decide which trans_opt -% files may be imported when creating another .trans_opt file. By -% observing the ordering decided upon when mmake module.depend was -% run, any circularities which may have been created are avoided. +% +% When mmake .depend is run, mmc calculates a suitable ordering. +% This ordering is then used to create each of the .d files. This allows +% make to ensure that all necessary trans_opt files are up to date before +% creating any other trans_opt files. This same information is used by mmc +% to decide which trans_opt files may be imported when creating another +% .trans_opt file. By observing the ordering decided upon when mmake +% module.depend was run, any circularities which may have been created +% are avoided. % % This module writes out the interface for transitive intermodule optimization. % The .trans_opt file includes: -% :- pragma termination_info declarations for all exported preds -% :- pragma exceptions declartions for all exported preds +% :- pragma termination_info declarations for all exported preds +% :- pragma exceptions declartions for all exported preds % All these items should be module qualified. % Constructors should be explicitly type qualified. % -% Note that the .trans_opt file does not (yet) include clauses, -% `pragma c_code' declarations, or any of the other information -% that would be needed for inlining or other optimizations; -% currently it is only used for termination analysis and -% exception analysis. +% Note that the .trans_opt file does not (yet) include clauses, `pragma +% foreign_proc' declarations, or any of the other information that would be +% needed for inlining or other optimizations; currently it is only used +% for termination analysis and exception analysis. % % This module also contains predicates to read in the .trans_opt files. % @@ -59,14 +60,18 @@ :- import_module io. :- import_module list. + % Open the file ".trans_opt.tmp", and write out the + % declarations. + % :- pred trans_opt__write_optfile(module_info::in, io::di, io::uo) is det. - % trans_opt__grab_optfiles(ModuleList, !ModuleImports, Error, !IO): - % Add the items from each of the modules in ModuleList.trans_opt to - % the items in ModuleImports. + % trans_opt__grab_optfiles(ModuleList, !ModuleImports, Error, !IO): + % + % Add the items from each of the modules in ModuleList.trans_opt to + % the items in ModuleImports. + % :- pred trans_opt__grab_optfiles(list(module_name)::in, - module_imports::in, module_imports::out, bool::out, io::di, io::uo) - is det. + module_imports::in, module_imports::out, bool::out, io::di, io::uo) is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -97,59 +102,54 @@ %-----------------------------------------------------------------------------% -% Open the file ".trans_opt.tmp", and write out the -% declarations. - trans_opt__write_optfile(Module, !IO) :- - module_info_get_name(Module, ModuleName), - module_name_to_file_name(ModuleName, ".trans_opt.tmp", yes, TmpOptName, - !IO), - io__open_output(TmpOptName, Result, !IO), - ( - Result = error(Error), - io__error_message(Error, Msg), - io__progname_base("trans_opt.m", ProgName, !IO), - io__write_string(ProgName, !IO), - io__write_string( - ": cannot open transitive optimisation file `", !IO), - io__write_string(TmpOptName, !IO), - io__write_string("' \n", !IO), - io__write_string(ProgName, !IO), - io__write_string(": for output: ", !IO), - io__write_string(Msg, !IO), - io__nl(!IO), - io__set_exit_status(1, !IO) - ; - Result = ok(Stream), - io__set_output_stream(Stream, OldStream, !IO), - module_info_get_name(Module, ModName), - io__write_string(":- module ", !IO), - mercury_output_bracketed_sym_name(ModName, !IO), - io__write_string(".\n", !IO), + module_info_get_name(Module, ModuleName), + module_name_to_file_name(ModuleName, ".trans_opt.tmp", yes, TmpOptName, + !IO), + io__open_output(TmpOptName, Result, !IO), + ( + Result = error(Error), + io__error_message(Error, Msg), + io__progname_base("trans_opt.m", ProgName, !IO), + io__write_string(ProgName, !IO), + io__write_string( + ": cannot open transitive optimisation file `", !IO), + io__write_string(TmpOptName, !IO), + io__write_string("' \n", !IO), + io__write_string(ProgName, !IO), + io__write_string(": for output: ", !IO), + io__write_string(Msg, !IO), + io__nl(!IO), + io__set_exit_status(1, !IO) + ; + Result = ok(Stream), + io__set_output_stream(Stream, OldStream, !IO), + module_info_get_name(Module, ModName), + io__write_string(":- module ", !IO), + mercury_output_bracketed_sym_name(ModName, !IO), + io__write_string(".\n", !IO), - % All predicates to write global items into the .trans_opt - % file should go here. + % All predicates to write global items into the .trans_opt + % file should go here. - module_info_predids(Module, PredIds), - list__foldl(termination__write_pred_termination_info(Module), - PredIds, !IO), - list__foldl(term_constr_main.output_pred_termination2_info(Module), - PredIds, !IO), - - module_info_get_exception_info(Module, ExceptionInfo), - list__foldl( - exception_analysis__write_pragma_exceptions(Module, - ExceptionInfo), - PredIds, !IO), - - io__set_output_stream(OldStream, _, !IO), - io__close_output(Stream, !IO), + module_info_predids(Module, PredIds), + list__foldl(termination__write_pred_termination_info(Module), + PredIds, !IO), + list__foldl(term_constr_main.output_pred_termination2_info(Module), + PredIds, !IO), - module_name_to_file_name(ModuleName, ".trans_opt", no, - OptName, !IO), - update_interface(OptName, !IO), - touch_interface_datestamp(ModuleName, ".trans_opt_date", !IO) - ). + module_info_get_exception_info(Module, ExceptionInfo), + list__foldl( + exception_analysis__write_pragma_exceptions(Module, ExceptionInfo), + PredIds, !IO), + + io__set_output_stream(OldStream, _, !IO), + io__close_output(Stream, !IO), + + module_name_to_file_name(ModuleName, ".trans_opt", no, OptName, !IO), + update_interface(OptName, !IO), + touch_interface_datestamp(ModuleName, ".trans_opt_date", !IO) + ). %-----------------------------------------------------------------------------% % @@ -157,44 +157,44 @@ trans_opt__write_optfile(Module, !IO) :- % trans_opt__grab_optfiles(TransOptDeps, !Module, FoundError, !IO) :- - globals__io_lookup_bool_option(verbose, Verbose, !IO), - maybe_write_string(Verbose, "% Reading .trans_opt files..\n", !IO), - maybe_flush_output(Verbose, !IO), + globals__io_lookup_bool_option(verbose, Verbose, !IO), + maybe_write_string(Verbose, "% Reading .trans_opt files..\n", !IO), + maybe_flush_output(Verbose, !IO), - read_trans_opt_files(TransOptDeps, [], OptItems, no, FoundError, !IO), + read_trans_opt_files(TransOptDeps, [], OptItems, no, FoundError, !IO), - append_pseudo_decl(opt_imported, !Module), - module_imports_get_items(!.Module, Items0), - list__append(Items0, OptItems, Items), - module_imports_set_items(Items, !Module), - module_imports_set_error(no_module_errors, !Module), + append_pseudo_decl(opt_imported, !Module), + module_imports_get_items(!.Module, Items0), + list__append(Items0, OptItems, Items), + module_imports_set_items(Items, !Module), + module_imports_set_error(no_module_errors, !Module), - maybe_write_string(Verbose, "% Done.\n", !IO). + maybe_write_string(Verbose, "% Done.\n", !IO). :- pred read_trans_opt_files(list(module_name)::in, item_list::in, - item_list::out, bool::in, bool::out, io::di, io::uo) is det. + item_list::out, bool::in, bool::out, io::di, io::uo) is det. read_trans_opt_files([], !Items, !Error, !IO). read_trans_opt_files([Import | Imports], !Items, !Error, !IO) :- - globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO), - maybe_write_string(VeryVerbose, - "% Reading transitive optimization interface for module", !IO), - maybe_write_string(VeryVerbose, " `", !IO), - mdbcomp__prim_data__sym_name_to_string(Import, ImportString), - maybe_write_string(VeryVerbose, ImportString, !IO), - maybe_write_string(VeryVerbose, "'... ", !IO), - maybe_flush_output(VeryVerbose, !IO), + globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO), + maybe_write_string(VeryVerbose, + "% Reading transitive optimization interface for module", !IO), + maybe_write_string(VeryVerbose, " `", !IO), + mdbcomp__prim_data__sym_name_to_string(Import, ImportString), + maybe_write_string(VeryVerbose, ImportString, !IO), + maybe_write_string(VeryVerbose, "'... ", !IO), + maybe_flush_output(VeryVerbose, !IO), - module_name_to_search_file_name(Import, ".trans_opt", FileName, !IO), - prog_io__read_opt_file(FileName, Import, - ModuleError, Messages, NewItems, !IO), + module_name_to_search_file_name(Import, ".trans_opt", FileName, !IO), + prog_io__read_opt_file(FileName, Import, + ModuleError, Messages, NewItems, !IO), - maybe_write_string(VeryVerbose, " done.\n", !IO), + maybe_write_string(VeryVerbose, " done.\n", !IO), - intermod__update_error_status(trans_opt, FileName, ModuleError, - Messages, !Error, !IO), - list__append(!.Items, NewItems, !:Items), - read_trans_opt_files(Imports, !Items, !Error, !IO). + intermod__update_error_status(trans_opt, FileName, ModuleError, + Messages, !Error, !IO), + list__append(!.Items, NewItems, !:Items), + read_trans_opt_files(Imports, !Items, !Error, !IO). %-----------------------------------------------------------------------------% :- end_module trans_opt. diff --git a/compiler/transform.m b/compiler/transform.m index 19872c490..391be56c8 100644 --- a/compiler/transform.m +++ b/compiler/transform.m @@ -1,31 +1,34 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 1995-1998, 2003-2005 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: transform.m % Main author: bromage. % % This module defines the primitive operations that may be performed -% on a logic program. These include: +% on a logic program. These include: % -% - unfold (NYI) -% Replaces a goal with its possible expansions. +% - unfold (NYI) +% Replaces a goal with its possible expansions. % -% - fold (NYI) -% Opposite of unfold (not surprisingly). +% - fold (NYI) +% Opposite of unfold (not surprisingly). % -% - definition (NYI) -% Define a new predicate with a given goal. +% - definition (NYI) +% Define a new predicate with a given goal. % -% - identity (NYI) -% Apply an identity (such as the associative law for -% addition) to a goal. +% - identity (NYI) +% Apply an identity (such as the associative law for addition) to a goal. % % These operations form the basis of most high-level transformations. % -% Also included is a conjunction rescheduler. Useful just in case +% Also included is a conjunction rescheduler. Useful just in case % your transformer upset the ordering in a conjunction. +% %-----------------------------------------------------------------------------% :- module transform_hlds__transform. @@ -36,8 +39,8 @@ :- import_module list. -:- pred transform__reschedule_conj(list(hlds_goal)::in, list(hlds_goal)::out, - mode_info::in, mode_info::out) is det. +:- pred reschedule_conj(list(hlds_goal)::in, list(hlds_goal)::out, + mode_info::in, mode_info::out) is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -58,24 +61,26 @@ %-----------------------------------------------------------------------------% -transform__reschedule_conj([], [], !ModeInfo). -transform__reschedule_conj([Goal0 | Goals0], Goals, !ModeInfo) :- - mode_info_get_instmap(!.ModeInfo, InstMap0), - mode_info_get_delay_info(!.ModeInfo, DelayInfo0), +reschedule_conj([], [], !ModeInfo). +reschedule_conj([Goal0 | Goals0], Goals, !ModeInfo) :- + mode_info_get_instmap(!.ModeInfo, InstMap0), + mode_info_get_delay_info(!.ModeInfo, DelayInfo0), - delay_info__wakeup_goals(WokenGoals, DelayInfo0, DelayInfo1), - mode_info_set_delay_info(DelayInfo1, !ModeInfo), - ( WokenGoals \= [] -> - list__append(WokenGoals, [Goal0 | Goals0], Goals1), - transform__reschedule_conj(Goals1, Goals, !ModeInfo) - ; - Goal0 = _Goal0Goal - Goal0Info, - goal_info_get_instmap_delta(Goal0Info, InstMapDelta), - instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap1), - mode_info_set_instmap(InstMap1, !ModeInfo), - transform__reschedule_conj(Goals0, Goals1, !ModeInfo), - Goals = [Goal0 | Goals1] - ). + delay_info__wakeup_goals(WokenGoals, DelayInfo0, DelayInfo1), + mode_info_set_delay_info(DelayInfo1, !ModeInfo), + ( + WokenGoals = [_ | _], + list__append(WokenGoals, [Goal0 | Goals0], Goals1), + reschedule_conj(Goals1, Goals, !ModeInfo) + ; + WokenGoals = [], + Goal0 = _Goal0Goal - Goal0Info, + goal_info_get_instmap_delta(Goal0Info, InstMapDelta), + instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap1), + mode_info_set_instmap(InstMap1, !ModeInfo), + reschedule_conj(Goals0, Goals1, !ModeInfo), + Goals = [Goal0 | Goals1] + ). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% diff --git a/compiler/tree.m b/compiler/tree.m index 79b90fb34..e900acc17 100644 --- a/compiler/tree.m +++ b/compiler/tree.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 1993-2001, 2003-2005 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. @@ -23,10 +25,10 @@ :- import_module list. :- type tree(T) - ---> empty - ; node(T) - ; tree(tree(T), tree(T)) - ; tree_list(list(tree(T))). + ---> empty + ; node(T) + ; tree(tree(T), tree(T)) + ; tree_list(list(tree(T))). :- func tree.flatten(tree(T)) = list(T). :- pred tree.flatten(tree(T)::in, list(T)::out) is det. @@ -38,77 +40,78 @@ :- pred tree.tree_of_lists_is_empty(tree(list(T))::in) is semidet. :- pred tree.foldl(pred(T, A, A)::in(pred(in, in, out) is det), tree(T)::in, - A::in, A::out) is det. + A::in, A::out) is det. :- func tree.map(func(T) = U, tree(T)) = tree(U). :- pred tree.map(pred(T, U)::in(pred(in, out) is det), - tree(T)::in, tree(U)::out) is det. + tree(T)::in, tree(U)::out) is det. :- pred tree.map_foldl(pred(T, U, A, A)::in(pred(in, out, in, out) is det), - tree(T)::in, tree(U)::out, A::in, A::out) is det. + tree(T)::in, tree(U)::out, A::in, A::out) is det. :- pred tree.map_foldl2( - pred(T, U, A, A, B, B)::in(pred(in, out, in, out, in, out) is det), - tree(T)::in, tree(U)::out, A::in, A::out, B::in, B::out) is det. + pred(T, U, A, A, B, B)::in(pred(in, out, in, out, in, out) is det), + tree(T)::in, tree(U)::out, A::in, A::out, B::in, B::out) is det. %-----------------------------------------------------------------------------% :- implementation. tree.flatten(T) = L :- - tree.flatten(T, L). + tree.flatten(T, L). tree.flatten(T, L) :- - tree.flatten_2(T, [], L). + tree.flatten_2(T, [], L). - % flatten_2(T, !Flat) is true iff !:Flat is the list that results from - % traversing T left-to-right depth-first, and then appending !.Flat. + % flatten_2(T, !Flat) is true iff !:Flat is the list that results from + % traversing T left-to-right depth-first, and then appending !.Flat. + % :- pred tree.flatten_2(tree(T)::in, list(T)::in, list(T)::out) is det. tree.flatten_2(empty, !Flat). tree.flatten_2(node(Item), !Flat) :- - !:Flat = [Item | !.Flat]. + !:Flat = [Item | !.Flat]. tree.flatten_2(tree(T1, T2), !Flat) :- - tree.flatten_2(T2, !Flat), - tree.flatten_2(T1, !Flat). + tree.flatten_2(T2, !Flat), + tree.flatten_2(T1, !Flat). tree.flatten_2(tree_list(List), !Flat) :- - tree.flatten_list(List, !Flat). + tree.flatten_list(List, !Flat). - % flatten_list(List, !Flat) is true iff !:Flat is the list that results - % from traversing List left-to-right depth-first, and then appending - % !.Flat. -:- pred tree.flatten_list(list(tree(T))::in, list(T)::in, list(T)::out) - is det. + % flatten_list(List, !Flat) is true iff !:Flat is the list that results + % from traversing List left-to-right depth-first, and then appending + % !.Flat. + % +:- pred tree.flatten_list(list(tree(T))::in, list(T)::in, list(T)::out) is det. tree.flatten_list([], !Flat). tree.flatten_list([Head | Tail], !Flat) :- - tree.flatten_list(Tail, !Flat), - tree.flatten_2(Head, !Flat). + tree.flatten_list(Tail, !Flat), + tree.flatten_2(Head, !Flat). %-----------------------------------------------------------------------------% tree.is_empty(T) :- - tree.is_empty(T) = yes. + tree.is_empty(T) = yes. tree.is_empty(empty) = yes. tree.is_empty(node(_)) = no. tree.is_empty(tree(Left, Right)) = - ( tree.is_empty(Left) = no -> - no - ; - tree.is_empty(Right) - ). + ( tree.is_empty(Left) = no -> + no + ; + tree.is_empty(Right) + ). tree.is_empty(tree_list(List)) = tree.list_is_empty(List). :- func tree.list_is_empty(list(tree(T))) = bool. tree.list_is_empty([]) = yes. tree.list_is_empty([Head | Tail]) = - ( tree.is_empty(Head) = no -> - no - ; - tree.list_is_empty(Tail) - ). + ( tree.is_empty(Head) = no -> + no + ; + tree.list_is_empty(Tail) + ). %-----------------------------------------------------------------------------% @@ -117,40 +120,40 @@ tree.list_is_empty([Head | Tail]) = % and the signatures of their helpers must therefore be different too. tree.tree_of_lists_is_empty(T) :- - tree.tree_of_lists_is_empty(T) = yes. + tree.tree_of_lists_is_empty(T) = yes. tree.tree_of_lists_is_empty(empty) = yes. tree.tree_of_lists_is_empty(node([])) = yes. tree.tree_of_lists_is_empty(node([_ | _])) = no. tree.tree_of_lists_is_empty(tree(Left, Right)) = - ( tree.tree_of_lists_is_empty(Left) = no -> - no - ; - tree.is_empty(Right) - ). + ( tree.tree_of_lists_is_empty(Left) = no -> + no + ; + tree.is_empty(Right) + ). tree.tree_of_lists_is_empty(tree_list(List)) = - tree.list_tree_of_lists_is_empty(List). + tree.list_tree_of_lists_is_empty(List). :- func tree.list_tree_of_lists_is_empty(list(tree(list(T)))) = bool. tree.list_tree_of_lists_is_empty([]) = yes. tree.list_tree_of_lists_is_empty([Head | Tail]) = - ( tree.tree_of_lists_is_empty(Head) = no -> - no - ; - tree.list_tree_of_lists_is_empty(Tail) - ). + ( tree.tree_of_lists_is_empty(Head) = no -> + no + ; + tree.list_tree_of_lists_is_empty(Tail) + ). %-----------------------------------------------------------------------------% tree.foldl(_P, empty, !A). tree.foldl(P, node(Node), !A) :- - P(Node, !A). + P(Node, !A). tree.foldl(P, tree(Left, Right), !A) :- - tree.foldl(P, Left, !A), - tree.foldl(P, Right, !A). + tree.foldl(P, Left, !A), + tree.foldl(P, Right, !A). tree.foldl(P, tree_list(List), !A) :- - list.foldl(tree.foldl(P), List, !A). + list.foldl(tree.foldl(P), List, !A). tree.map(_F, empty) = empty. tree.map(F, node(T)) = node(F(T)). @@ -159,29 +162,29 @@ tree.map(F, tree_list(L)) = tree_list(list.map(tree.map(F), L)). tree.map(_P, empty, empty). tree.map(P, node(Node0), node(Node)) :- - P(Node0, Node). + P(Node0, Node). tree.map(P, tree(Left0, Right0), tree(Left, Right)) :- - tree.map(P, Left0, Left), - tree.map(P, Right0, Right). + tree.map(P, Left0, Left), + tree.map(P, Right0, Right). tree.map(P, tree_list(List0), tree_list(List)) :- - list.map(tree.map(P), List0, List). + list.map(tree.map(P), List0, List). tree.map_foldl(_P, empty, empty, !A). tree.map_foldl(P, node(Node0), node(Node), !A) :- - P(Node0, Node, !A). + P(Node0, Node, !A). tree.map_foldl(P, tree(Left0, Right0), tree(Left, Right), !A) :- - tree.map_foldl(P, Left0, Left, !A), - tree.map_foldl(P, Right0, Right, !A). + tree.map_foldl(P, Left0, Left, !A), + tree.map_foldl(P, Right0, Right, !A). tree.map_foldl(P, tree_list(List0), tree_list(List), !A) :- - list.map_foldl(tree.map_foldl(P), List0, List, !A). + list.map_foldl(tree.map_foldl(P), List0, List, !A). tree.map_foldl2(_P, empty, empty, !A, !B). tree.map_foldl2(P, node(Node0), node(Node), !A, !B) :- - P(Node0, Node, !A, !B). + P(Node0, Node, !A, !B). tree.map_foldl2(P, tree(Left0, Right0), tree(Left, Right), !A, !B) :- - tree.map_foldl2(P, Left0, Left, !A, !B), - tree.map_foldl2(P, Right0, Right, !A, !B). + tree.map_foldl2(P, Left0, Left, !A, !B), + tree.map_foldl2(P, Right0, Right, !A, !B). tree.map_foldl2(P, tree_list(List0), tree_list(List), !A, !B) :- - list.map_foldl2(tree.map_foldl2(P), List0, List, !A, !B). + list.map_foldl2(tree.map_foldl2(P), List0, List, !A, !B). %-----------------------------------------------------------------------------% diff --git a/compiler/tupling.m b/compiler/tupling.m index f8c396d5c..3da50aef7 100644 --- a/compiler/tupling.m +++ b/compiler/tupling.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 2005 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. @@ -89,7 +91,7 @@ :- import_module io. :- pred tuple_arguments(module_info::in, module_info::out, io::di, io::uo) - is det. + is det. %-----------------------------------------------------------------------------% @@ -150,462 +152,450 @@ % tuple_arguments(!ModuleInfo, !IO) :- - module_info_get_globals(!.ModuleInfo, Globals), - globals__lookup_string_option(Globals, - tuple_trace_counts_file, TraceCountsFile), - ( TraceCountsFile = "" -> - report_warning("Warning: --tuple requires " ++ - "--tuple-trace-counts-file to work.\n", !IO) - ; - read_trace_counts_source(no, try_single_first, TraceCountsFile, - Result, !IO), - ( - Result = list_ok(_, TraceCounts), - tuple_arguments_2(!ModuleInfo, TraceCounts, !IO) - ; - Result = list_error_message(Message), - warn_trace_counts_error(TraceCountsFile, Message, !IO) - ) - ). + module_info_get_globals(!.ModuleInfo, Globals), + globals__lookup_string_option(Globals, + tuple_trace_counts_file, TraceCountsFile), + ( TraceCountsFile = "" -> + report_warning("Warning: --tuple requires " ++ + "--tuple-trace-counts-file to work.\n", !IO) + ; + read_trace_counts_source(no, try_single_first, TraceCountsFile, + Result, !IO), + ( + Result = list_ok(_, TraceCounts), + tuple_arguments_2(!ModuleInfo, TraceCounts, !IO) + ; + Result = list_error_message(Message), + warn_trace_counts_error(TraceCountsFile, Message, !IO) + ) + ). :- pred tuple_arguments_2(module_info::in, module_info::out, trace_counts::in, - io::di, io::uo) is det. + io::di, io::uo) is det. tuple_arguments_2(!ModuleInfo, TraceCounts0, !IO) :- - module_info_get_globals(!.ModuleInfo, Globals), - % We use the same cost options as for the stack optimisation. - globals__lookup_int_option(Globals, - optimize_saved_vars_cell_cv_load_cost, CellVarLoadCost), - globals__lookup_int_option(Globals, - optimize_saved_vars_cell_cv_store_cost, CellVarStoreCost), - globals__lookup_int_option(Globals, - optimize_saved_vars_cell_fv_load_cost, FieldVarLoadCost), - globals__lookup_int_option(Globals, - optimize_saved_vars_cell_fv_store_cost, FieldVarStoreCost), - globals__lookup_int_option(Globals, - tuple_costs_ratio, CostsRatio), - globals__lookup_int_option(Globals, - tuple_min_args, MinArgsToTuple), - % These are the costs for untupled variables. We just assume it is - % the lesser of the cell and field variable costs (usually the field - % variable costs should be smaller). - NormalVarStoreCost = min(CellVarStoreCost, FieldVarStoreCost), - NormalVarLoadCost = min(CellVarLoadCost, FieldVarLoadCost), - TuningParams = tuning_params( - NormalVarLoadCost, NormalVarStoreCost, - CellVarLoadCost, CellVarStoreCost, - FieldVarLoadCost, FieldVarStoreCost, - CostsRatio, MinArgsToTuple), + module_info_get_globals(!.ModuleInfo, Globals), + % We use the same cost options as for the stack optimisation. + globals__lookup_int_option(Globals, + optimize_saved_vars_cell_cv_load_cost, CellVarLoadCost), + globals__lookup_int_option(Globals, + optimize_saved_vars_cell_cv_store_cost, CellVarStoreCost), + globals__lookup_int_option(Globals, + optimize_saved_vars_cell_fv_load_cost, FieldVarLoadCost), + globals__lookup_int_option(Globals, + optimize_saved_vars_cell_fv_store_cost, FieldVarStoreCost), + globals__lookup_int_option(Globals, + tuple_costs_ratio, CostsRatio), + globals__lookup_int_option(Globals, + tuple_min_args, MinArgsToTuple), + % These are the costs for untupled variables. We just assume it is + % the lesser of the cell and field variable costs (usually the field + % variable costs should be smaller). + NormalVarStoreCost = min(CellVarStoreCost, FieldVarStoreCost), + NormalVarLoadCost = min(CellVarLoadCost, FieldVarLoadCost), + TuningParams = tuning_params( + NormalVarLoadCost, NormalVarStoreCost, + CellVarLoadCost, CellVarStoreCost, + FieldVarLoadCost, FieldVarStoreCost, + CostsRatio, MinArgsToTuple), - module_info_get_name(!.ModuleInfo, ModuleName), - restrict_trace_counts_to_module(ModuleName, TraceCounts0, TraceCounts), + module_info_get_name(!.ModuleInfo, ModuleName), + restrict_trace_counts_to_module(ModuleName, TraceCounts0, TraceCounts), - module_info_ensure_dependency_info(!ModuleInfo), - module_info_dependency_info(!.ModuleInfo, DepInfo), - hlds_dependency_info_get_dependency_graph(DepInfo, DepGraph), - hlds_dependency_info_get_dependency_ordering(DepInfo, SCCs), + module_info_ensure_dependency_info(!ModuleInfo), + module_info_dependency_info(!.ModuleInfo, DepInfo), + hlds_dependency_info_get_dependency_graph(DepInfo, DepGraph), + hlds_dependency_info_get_dependency_ordering(DepInfo, SCCs), - % Add transformed versions of procedures that we think would be - % beneficial. - list__foldl4(maybe_tuple_scc(TraceCounts, TuningParams, DepGraph), - SCCs, !ModuleInfo, counter__init(0), _, - map__init, TransformMap, !IO), + % Add transformed versions of procedures that we think would be + % beneficial. + list__foldl4(maybe_tuple_scc(TraceCounts, TuningParams, DepGraph), + SCCs, !ModuleInfo, counter__init(0), _, + map__init, TransformMap, !IO), - % Update the callers of the original procedures to call their - % transformed versions instead. Do the same for the transformed - % procedures themselves. - list__foldl(fix_calls_in_procs(TransformMap), SCCs, !ModuleInfo), - fix_calls_in_transformed_procs(TransformMap, !ModuleInfo). + % Update the callers of the original procedures to call their + % transformed versions instead. Do the same for the transformed + % procedures themselves. + list__foldl(fix_calls_in_procs(TransformMap), SCCs, !ModuleInfo), + fix_calls_in_transformed_procs(TransformMap, !ModuleInfo). :- pred warn_trace_counts_error(string::in, string::in, io::di, io::uo) is det. warn_trace_counts_error(TraceCountsFile, Reason, !IO) :- - string__format( - "Warning: unable to read trace count summary from %s (%s)\n", - [s(TraceCountsFile), s(Reason)], Message), - report_warning(Message, !IO). + string__format( + "Warning: unable to read trace count summary from %s (%s)\n", + [s(TraceCountsFile), s(Reason)], Message), + report_warning(Message, !IO). %-----------------------------------------------------------------------------% - % This predicate can be used in place of maybe_tuple_scc to evaluate - % and transform each procedure of an SCC individually. This is to - % mimic the behaviour from an earlier version of this file. - % It's currently unused but might be useful for debugging. - % + % This predicate can be used in place of maybe_tuple_scc to evaluate + % and transform each procedure of an SCC individually. This is to mimic + % the behaviour from an earlier version of this file. It's currently + % unused but might be useful for debugging. + % :- pred maybe_tuple_scc_individual_procs(trace_counts::in, tuning_params::in, - dependency_graph::in, list(pred_proc_id)::in, - module_info::in, module_info::out, counter::in, counter::out, - transform_map::in, transform_map::out, io::di, io::uo) is det. + dependency_graph::in, list(pred_proc_id)::in, + module_info::in, module_info::out, counter::in, counter::out, + transform_map::in, transform_map::out, io::di, io::uo) is det. maybe_tuple_scc_individual_procs(_TraceCounts, _TuningParams, _DepGraph, - [], !ModuleInfo, !Counter, !TransformMap, !IO). + [], !ModuleInfo, !Counter, !TransformMap, !IO). maybe_tuple_scc_individual_procs(TraceCounts, TuningParams, DepGraph, - [Proc | Procs], !ModuleInfo, !Counter, !TransformMap, !IO) :- - maybe_tuple_scc(TraceCounts, TuningParams, DepGraph, - [Proc], !ModuleInfo, !Counter, !TransformMap, !IO), - maybe_tuple_scc_individual_procs(TraceCounts, TuningParams, DepGraph, - Procs, !ModuleInfo, !Counter, !TransformMap, !IO). + [Proc | Procs], !ModuleInfo, !Counter, !TransformMap, !IO) :- + maybe_tuple_scc(TraceCounts, TuningParams, DepGraph, + [Proc], !ModuleInfo, !Counter, !TransformMap, !IO), + maybe_tuple_scc_individual_procs(TraceCounts, TuningParams, DepGraph, + Procs, !ModuleInfo, !Counter, !TransformMap, !IO). :- pred maybe_tuple_scc(trace_counts::in, tuning_params::in, - dependency_graph::in, list(pred_proc_id)::in(bound([ground | ground])), - module_info::in, module_info::out, counter::in, counter::out, - transform_map::in, transform_map::out, io::di, io::uo) is det. + dependency_graph::in, list(pred_proc_id)::in(bound([ground | ground])), + module_info::in, module_info::out, counter::in, counter::out, + transform_map::in, transform_map::out, io::di, io::uo) is det. maybe_tuple_scc(TraceCounts, TuningParams, DepGraph, SCC, - !ModuleInfo, !Counter, !TransformMap, !IO) :- - module_info_get_globals(!.ModuleInfo, Globals), - globals__lookup_bool_option(Globals, very_verbose, VeryVerbose), - ( - VeryVerbose = yes, - io.write_string("% Considering tupling in ", !IO), - list__foldl((pred(PredProcId::in, IO0::di, IO::uo) is det :- - PredProcId = proc(PredId, ProcId), - hlds_out__write_pred_proc_id(!.ModuleInfo, - PredId, ProcId, IO0, IO)), - SCC, !IO), - io.write_string("\n", !IO) - ; - VeryVerbose = no - ), - ( scc_has_local_callers(SCC, DepGraph) -> - ( SCC = [SingleProc] -> - candidate_headvars_of_proc(!.ModuleInfo, SingleProc, - CandidateHeadVars) - ; - common_candidate_headvars_of_procs(!.ModuleInfo, SCC, - CandidateHeadVars) - ), - MinArgsToTuple = TuningParams ^ min_args_to_tuple, - ( list__length(CandidateHeadVars) < MinArgsToTuple -> - ( - VeryVerbose = yes, - io__write_string( - "% Too few candidate headvars\n", !IO) - ; - VeryVerbose = no - ) - ; - maybe_tuple_scc_2(TraceCounts, TuningParams, - SCC, CandidateHeadVars, !ModuleInfo, - !Counter, !TransformMap, !IO, VeryVerbose) - ) - ; - % No need to work on this SCC if there are no callers to it - % within this module. - % - % XXX: if part of the SCC is exported then we might want - % to look at it, for intermodule tupling. - ( - VeryVerbose = yes, - io__write_string("% SCC has no local callers\n", !IO) - ; - VeryVerbose = no - ) - ). + !ModuleInfo, !Counter, !TransformMap, !IO) :- + module_info_get_globals(!.ModuleInfo, Globals), + globals__lookup_bool_option(Globals, very_verbose, VeryVerbose), + ( + VeryVerbose = yes, + io.write_string("% Considering tupling in ", !IO), + list__foldl((pred(PredProcId::in, IO0::di, IO::uo) is det :- + PredProcId = proc(PredId, ProcId), + hlds_out__write_pred_proc_id(!.ModuleInfo, + PredId, ProcId, IO0, IO)), + SCC, !IO), + io.write_string("\n", !IO) + ; + VeryVerbose = no + ), + ( scc_has_local_callers(SCC, DepGraph) -> + ( SCC = [SingleProc] -> + candidate_headvars_of_proc(!.ModuleInfo, SingleProc, + CandidateHeadVars) + ; + common_candidate_headvars_of_procs(!.ModuleInfo, SCC, + CandidateHeadVars) + ), + MinArgsToTuple = TuningParams ^ min_args_to_tuple, + ( list__length(CandidateHeadVars) < MinArgsToTuple -> + ( + VeryVerbose = yes, + io__write_string("% Too few candidate headvars\n", !IO) + ; + VeryVerbose = no + ) + ; + maybe_tuple_scc_2(TraceCounts, TuningParams, + SCC, CandidateHeadVars, !ModuleInfo, + !Counter, !TransformMap, !IO, VeryVerbose) + ) + ; + % No need to work on this SCC if there are no callers to it + % within this module. + % + % XXX: If part of the SCC is exported then we might want + % to look at it, for intermodule tupling. + ( + VeryVerbose = yes, + io__write_string("% SCC has no local callers\n", !IO) + ; + VeryVerbose = no + ) + ). :- pred scc_has_local_callers(list(pred_proc_id)::in, dependency_graph::in) - is semidet. + is semidet. scc_has_local_callers(CalleeProcs, DepGraph) :- - some [CalleeProc] ( - CalleeProc `list.member` CalleeProcs, - proc_has_local_callers(CalleeProc, DepGraph) - ). + some [CalleeProc] ( + CalleeProc `list.member` CalleeProcs, + proc_has_local_callers(CalleeProc, DepGraph) + ). :- pred proc_has_local_callers(pred_proc_id::in, dependency_graph::in) - is semidet. + is semidet. proc_has_local_callers(CalleeProc, DepGraph) :- - relation__lookup_element(DepGraph, CalleeProc, CalleeKey), - relation__lookup_to(DepGraph, CalleeKey, CallingKeys), - not set__empty(CallingKeys). + relation__lookup_element(DepGraph, CalleeProc, CalleeKey), + relation__lookup_to(DepGraph, CalleeKey, CallingKeys), + not set__empty(CallingKeys). %-----------------------------------------------------------------------------% :- pred maybe_tuple_scc_2(trace_counts::in, tuning_params::in, - list(pred_proc_id)::in, candidate_headvars::in, - module_info::in, module_info::out, counter::in, counter::out, - transform_map::in, transform_map::out, io::di, io::uo, bool::in) - is det. + list(pred_proc_id)::in, candidate_headvars::in, + module_info::in, module_info::out, counter::in, counter::out, + transform_map::in, transform_map::out, io::di, io::uo, bool::in) is det. maybe_tuple_scc_2(TraceCounts, TuningParams, PredProcIds, CandidateHeadVars, - !ModuleInfo, !Counter, !TransformMap, !IO, VeryVerbose) :- - list__foldl2(prepare_proc_for_counting, PredProcIds, !ModuleInfo, !IO), - % Count the average number of loads/stores without any transformation. - count_load_stores_for_scc(TraceCounts, TuningParams, !.ModuleInfo, - map__init, PredProcIds, CostsWithoutTupling), - ( - VeryVerbose = yes, - CostsWithoutTupling = costs(LoadsWoTupling, StoresWoTupling), - io.format("%% SCC costs without tupling = {%g, %g}\n", - [f(LoadsWoTupling), f(StoresWoTupling)], !IO) - ; - VeryVerbose = no - ), - ( CostsWithoutTupling = costs(0.0, 0.0) -> - % Don't bother continuing. - true - ; - maybe_tuple_scc_3(TraceCounts, TuningParams, PredProcIds, - CandidateHeadVars, CostsWithoutTupling, - !ModuleInfo, !Counter, !TransformMap, !IO, - VeryVerbose) - ). + !ModuleInfo, !Counter, !TransformMap, !IO, VeryVerbose) :- + list__foldl2(prepare_proc_for_counting, PredProcIds, !ModuleInfo, !IO), + % Count the average number of loads/stores without any transformation. + count_load_stores_for_scc(TraceCounts, TuningParams, !.ModuleInfo, + map__init, PredProcIds, CostsWithoutTupling), + ( + VeryVerbose = yes, + CostsWithoutTupling = costs(LoadsWoTupling, StoresWoTupling), + io.format("%% SCC costs without tupling = {%g, %g}\n", + [f(LoadsWoTupling), f(StoresWoTupling)], !IO) + ; + VeryVerbose = no + ), + ( CostsWithoutTupling = costs(0.0, 0.0) -> + % Don't bother continuing. + true + ; + maybe_tuple_scc_3(TraceCounts, TuningParams, PredProcIds, + CandidateHeadVars, CostsWithoutTupling, + !ModuleInfo, !Counter, !TransformMap, !IO, VeryVerbose) + ). :- pred maybe_tuple_scc_3(trace_counts::in, tuning_params::in, - list(pred_proc_id)::in, candidate_headvars::in, costs::in, - module_info::in, module_info::out, counter::in, counter::out, - transform_map::in, transform_map::out, io::di, io::uo, bool::in) - is det. + list(pred_proc_id)::in, candidate_headvars::in, costs::in, + module_info::in, module_info::out, counter::in, counter::out, + transform_map::in, transform_map::out, io::di, io::uo, bool::in) is det. maybe_tuple_scc_3(TraceCounts, TuningParams, PredProcIds, CandidateHeadVars, - CostsWithoutTupling, - !ModuleInfo, !Counter, !TransformMap, !IO, VeryVerbose) :- - find_best_tupling_scheme(TraceCounts, TuningParams, !.ModuleInfo, - PredProcIds, CandidateHeadVars, MaybeBestScheme), - ( - MaybeBestScheme = no - ; - MaybeBestScheme = yes(CostsWithTupling-TuplingScheme), - CostsWithTupling = costs(LoadsWithTupling, StoresWithTupling), - ( - VeryVerbose = yes, - io.format("%% SCC costs with tupling = {%g, %g}\n", - [f(LoadsWithTupling), f(StoresWithTupling)], - !IO) - ; - VeryVerbose = no - ), - ( - should_use_tupling_scheme(TuningParams, - CostsWithoutTupling, CostsWithTupling) - -> - ( - VeryVerbose = yes, - io.print("% Proceeding with tupling\n", !IO) - ; - VeryVerbose = no - ), - add_transformed_procs(TuplingScheme, - !ModuleInfo, !Counter, !TransformMap) - ; - true - ) - ). + CostsWithoutTupling, + !ModuleInfo, !Counter, !TransformMap, !IO, VeryVerbose) :- + find_best_tupling_scheme(TraceCounts, TuningParams, !.ModuleInfo, + PredProcIds, CandidateHeadVars, MaybeBestScheme), + ( + MaybeBestScheme = no + ; + MaybeBestScheme = yes(CostsWithTupling-TuplingScheme), + CostsWithTupling = costs(LoadsWithTupling, StoresWithTupling), + ( + VeryVerbose = yes, + io.format("%% SCC costs with tupling = {%g, %g}\n", + [f(LoadsWithTupling), f(StoresWithTupling)], !IO) + ; + VeryVerbose = no + ), + ( + should_use_tupling_scheme(TuningParams, + CostsWithoutTupling, CostsWithTupling) + -> + ( + VeryVerbose = yes, + io.print("% Proceeding with tupling\n", !IO) + ; + VeryVerbose = no + ), + add_transformed_procs(TuplingScheme, + !ModuleInfo, !Counter, !TransformMap) + ; + true + ) + ). :- pred should_use_tupling_scheme(tuning_params::in, costs::in, costs::in) - is semidet. + is semidet. should_use_tupling_scheme(TuningParams, - costs(LoadsWithoutTupling, StoresWithoutTupling), - costs(LoadsWithTupling, StoresWithTupling)) :- - CostsRatio = float(TuningParams ^ costs_ratio), - TotalWithoutTupling = LoadsWithoutTupling + StoresWithoutTupling, - TotalWithTupling = LoadsWithTupling + StoresWithTupling, - ( TotalWithTupling = 0.0 -> - TotalWithoutTupling > 0.0 - ; - (TotalWithoutTupling * 100.0 / TotalWithTupling) >= CostsRatio - ). + costs(LoadsWithoutTupling, StoresWithoutTupling), + costs(LoadsWithTupling, StoresWithTupling)) :- + CostsRatio = float(TuningParams ^ costs_ratio), + TotalWithoutTupling = LoadsWithoutTupling + StoresWithoutTupling, + TotalWithTupling = LoadsWithTupling + StoresWithTupling, + ( TotalWithTupling = 0.0 -> + TotalWithoutTupling > 0.0 + ; + (TotalWithoutTupling * 100.0 / TotalWithTupling) >= CostsRatio + ). %-----------------------------------------------------------------------------% - % The "candidate headvars" of a procedure are the input arguments of - % a procedure that we are considering to pass to the procedure as a - % tuple. - % - % The "common" candidate headvars of an SCC (of more than one - % procedure) are the input arguments that, when passed as a tuple, we - % hope can be reused in calls to other procedures in the same SCC. - % The heuristic used to find candidates is to look for input arguments - % which have the same name in more than one procedure in the SCC. - % - % For each candidate, the name is put in an association list along - % with a mappping to the actual variable within each procedure (if - % that procedure has an input variable of the given name). The order - % of the elements in the association list is important later on, - % since we only try tupling contiguous runs of the candidate - % variables. - % - :- type candidate_headvars == assoc_list(string, candidate_headvar_origins). :- type candidate_headvar_origins == map(pred_proc_id, prog_var). + % The "candidate headvars" of a procedure are the input arguments of + % a procedure that we are considering to pass to the procedure as a + % tuple. + % + % The "common" candidate headvars of an SCC (of more than one + % procedure) are the input arguments that, when passed as a tuple, we + % hope can be reused in calls to other procedures in the same SCC. + % The heuristic used to find candidates is to look for input arguments + % which have the same name in more than one procedure in the SCC. + % + % For each candidate, the name is put in an association list along + % with a mappping to the actual variable within each procedure (if + % that procedure has an input variable of the given name). The order + % of the elements in the association list is important later on, + % since we only try tupling contiguous runs of the candidate variables. + % :- pred candidate_headvars_of_proc(module_info::in, pred_proc_id::in, - candidate_headvars::out) is det. + candidate_headvars::out) is det. candidate_headvars_of_proc(ModuleInfo, PredProcId @ proc(PredId, ProcId), - CandidateHeadVars) :- - module_info_pred_proc_info(ModuleInfo, PredId, ProcId, _, ProcInfo), - proc_info_varset(ProcInfo, VarSet), - proc_info_vartypes(ProcInfo, VarTypes), - proc_info_headvars(ProcInfo, HeadVars), - proc_info_argmodes(ProcInfo, ArgModes), - CandidateHeadVars = list__filter_map_corresponding( - candidate_headvars_of_proc_2(PredProcId, VarSet, VarTypes, - ModuleInfo), - HeadVars, ArgModes). + CandidateHeadVars) :- + module_info_pred_proc_info(ModuleInfo, PredId, ProcId, _, ProcInfo), + proc_info_varset(ProcInfo, VarSet), + proc_info_vartypes(ProcInfo, VarTypes), + proc_info_headvars(ProcInfo, HeadVars), + proc_info_argmodes(ProcInfo, ArgModes), + CandidateHeadVars = list__filter_map_corresponding( + candidate_headvars_of_proc_2(PredProcId, VarSet, VarTypes, ModuleInfo), + HeadVars, ArgModes). :- func candidate_headvars_of_proc_2(pred_proc_id, prog_varset, vartypes, - module_info, prog_var, (mode)) - = pair(string, candidate_headvar_origins) is semidet. + module_info, prog_var, (mode)) + = pair(string, candidate_headvar_origins) is semidet. candidate_headvars_of_proc_2(PredProcId, VarSet, VarTypes, ModuleInfo, - HeadVar, ArgMode) = (Name - Origins) :- - % We only tuple input arguments. - mode_is_input(ModuleInfo, ArgMode), - % Don't touch introduced typeinfo arguments. - map__lookup(VarTypes, HeadVar, Type), - not is_introduced_type_info_type(Type), - varset__search_name(VarSet, HeadVar, Name), - map__det_insert(map__init, PredProcId, HeadVar, Origins). + HeadVar, ArgMode) = (Name - Origins) :- + % We only tuple input arguments. + mode_is_input(ModuleInfo, ArgMode), + % Don't touch introduced typeinfo arguments. + map__lookup(VarTypes, HeadVar, Type), + not is_introduced_type_info_type(Type), + varset__search_name(VarSet, HeadVar, Name), + map__det_insert(map__init, PredProcId, HeadVar, Origins). :- pred common_candidate_headvars_of_procs(module_info::in, - list(pred_proc_id)::in, candidate_headvars::out) is det. + list(pred_proc_id)::in, candidate_headvars::out) is det. common_candidate_headvars_of_procs(ModuleInfo, PredProcIds, - CandidateHeadVars) :- - list__map(candidate_headvars_of_proc(ModuleInfo), - PredProcIds, ListsOfCandidates), - list__condense(ListsOfCandidates, FlatListOfCandidates), - multi_map__from_flat_assoc_list(FlatListOfCandidates, - CandidatesMultiMap), - map__foldl(common_candidate_headvars_of_procs_2, - CandidatesMultiMap, - [], CandidateHeadVars). + CandidateHeadVars) :- + list__map(candidate_headvars_of_proc(ModuleInfo), + PredProcIds, ListsOfCandidates), + list__condense(ListsOfCandidates, FlatListOfCandidates), + multi_map__from_flat_assoc_list(FlatListOfCandidates, CandidatesMultiMap), + map__foldl(common_candidate_headvars_of_procs_2, CandidatesMultiMap, + [], CandidateHeadVars). :- pred common_candidate_headvars_of_procs_2( - string::in, list(candidate_headvar_origins)::in, - candidate_headvars::in, candidate_headvars::out) is det. + string::in, list(candidate_headvar_origins)::in, + candidate_headvars::in, candidate_headvars::out) is det. common_candidate_headvars_of_procs_2(HeadVarName, ListOfOrigins, - CandidateHeadVars0, CandidateHeadVars) :- - % Only include this variable in the list of candidates if - % there are two or more procedures in the SCC with head - % variables having the same name. - ( ListOfOrigins = [_, _ | _] -> - list__foldl(map__merge, ListOfOrigins, map__init, Origins), - CandidateHeadVars = CandidateHeadVars0 ++ - [HeadVarName - Origins] - ; - CandidateHeadVars = CandidateHeadVars0 - ). + CandidateHeadVars0, CandidateHeadVars) :- + % Only include this variable in the list of candidates if there are two + % or more procedures in the SCC with head variables having the same name. + ( ListOfOrigins = [_, _ | _] -> + list__foldl(map__merge, ListOfOrigins, map__init, Origins), + CandidateHeadVars = CandidateHeadVars0 ++ [HeadVarName - Origins] + ; + CandidateHeadVars = CandidateHeadVars0 + ). %-----------------------------------------------------------------------------% - % This is a mapping from the id of a procedure to the proposed - % tupling that would be performed on the procedure's input arguments. - % + % This is a mapping from the id of a procedure to the proposed + % tupling that would be performed on the procedure's input arguments. + % :- type tupling_scheme == map(pred_proc_id, tupling_proposal). :- type tupling_proposal - ---> no_tupling - ; tupling( - cell_var :: prog_var, - field_vars :: prog_vars, - field_var_arg_pos :: assoc_list(prog_var, int) - ). + ---> no_tupling + ; tupling( + cell_var :: prog_var, + field_vars :: prog_vars, + field_var_arg_pos :: assoc_list(prog_var, int) + ). :- pred find_best_tupling_scheme(trace_counts::in, tuning_params::in, - module_info::in, list(pred_proc_id)::in, candidate_headvars::in, - maybe(pair(costs, tupling_scheme))::out) is det. + module_info::in, list(pred_proc_id)::in, candidate_headvars::in, + maybe(pair(costs, tupling_scheme))::out) is det. find_best_tupling_scheme(TraceCounts, TuningParams, ModuleInfo, - PredProcIds, CandidateHeadVars, MaybeBestScheme) :- - MinArgsToTuple = TuningParams ^ min_args_to_tuple, - fold_over_list_runs(find_best_tupling_scheme_2(TraceCounts, - TuningParams, ModuleInfo, PredProcIds), - CandidateHeadVars, MinArgsToTuple, - no, MaybeBestScheme). + PredProcIds, CandidateHeadVars, MaybeBestScheme) :- + MinArgsToTuple = TuningParams ^ min_args_to_tuple, + fold_over_list_runs( + find_best_tupling_scheme_2(TraceCounts, TuningParams, + ModuleInfo, PredProcIds), + CandidateHeadVars, MinArgsToTuple, + no, MaybeBestScheme). :- pred find_best_tupling_scheme_2(trace_counts::in, tuning_params::in, - module_info::in, list(pred_proc_id)::in, candidate_headvars::in, - maybe(pair(costs, tupling_scheme))::in, - maybe(pair(costs, tupling_scheme))::out) is det. + module_info::in, list(pred_proc_id)::in, candidate_headvars::in, + maybe(pair(costs, tupling_scheme))::in, + maybe(pair(costs, tupling_scheme))::out) is det. find_best_tupling_scheme_2(TraceCounts, TuningParams, ModuleInfo, - PredProcIds, CandidateHeadVars, - MaybeBestScheme0, MaybeBestScheme) :- - MinArgsToTuple = TuningParams ^ min_args_to_tuple, - list__map(make_tupling_proposal(ModuleInfo, CandidateHeadVars, - MinArgsToTuple), - PredProcIds, TuplingProposals), - map__from_corresponding_lists(PredProcIds, TuplingProposals, - TuplingScheme), - count_load_stores_for_scc(TraceCounts, TuningParams, - ModuleInfo, TuplingScheme, PredProcIds, Costs), - ( - ( - MaybeBestScheme0 = no - ; - MaybeBestScheme0 = yes(PrevCosts - _), - less_total_cost(Costs, PrevCosts) - ) - -> - MaybeBestScheme = yes(Costs - TuplingScheme) - ; - MaybeBestScheme = MaybeBestScheme0 - ). + PredProcIds, CandidateHeadVars, + MaybeBestScheme0, MaybeBestScheme) :- + MinArgsToTuple = TuningParams ^ min_args_to_tuple, + list__map( + make_tupling_proposal(ModuleInfo, CandidateHeadVars, MinArgsToTuple), + PredProcIds, TuplingProposals), + map__from_corresponding_lists(PredProcIds, TuplingProposals, + TuplingScheme), + count_load_stores_for_scc(TraceCounts, TuningParams, ModuleInfo, + TuplingScheme, PredProcIds, Costs), + ( + ( + MaybeBestScheme0 = no + ; + MaybeBestScheme0 = yes(PrevCosts - _), + less_total_cost(Costs, PrevCosts) + ) + -> + MaybeBestScheme = yes(Costs - TuplingScheme) + ; + MaybeBestScheme = MaybeBestScheme0 + ). :- pred make_tupling_proposal(module_info::in, candidate_headvars::in, - int::in, pred_proc_id::in, tupling_proposal::out) is det. + int::in, pred_proc_id::in, tupling_proposal::out) is det. make_tupling_proposal(ModuleInfo, CandidateHeadVars, MinArgsToTuple, - PredProcId @ proc(PredId, ProcId), TuplingProposal) :- - module_info_pred_proc_info(ModuleInfo, PredId, ProcId, _, ProcInfo), - proc_info_varset(ProcInfo, VarSet), - proc_info_headvars(ProcInfo, HeadVars), - FieldVarArgPos = list__filter_map( - (func(_ - Annotation) = (Var - Pos) is semidet :- - map__search(Annotation, PredProcId, Var), - list__nth_member_search(HeadVars, Var, Pos)), - CandidateHeadVars), - ( list__length(FieldVarArgPos) < MinArgsToTuple -> - TuplingProposal = no_tupling - ; - % We need a new variable to act as the cell variable while - % counting loads/stores for a proposed tupling, but we don't - % add that variable to the varset permanently. - varset__new_named_var(VarSet, "DummyCellVar", DummyCellVar, _), - FieldVars = assoc_list__keys(FieldVarArgPos), - TuplingProposal = tupling(DummyCellVar, FieldVars, - FieldVarArgPos) - ). + PredProcId @ proc(PredId, ProcId), TuplingProposal) :- + module_info_pred_proc_info(ModuleInfo, PredId, ProcId, _, ProcInfo), + proc_info_varset(ProcInfo, VarSet), + proc_info_headvars(ProcInfo, HeadVars), + FieldVarArgPos = list__filter_map( + (func(_ - Annotation) = (Var - Pos) is semidet :- + map__search(Annotation, PredProcId, Var), + list__nth_member_search(HeadVars, Var, Pos)), + CandidateHeadVars), + ( list__length(FieldVarArgPos) < MinArgsToTuple -> + TuplingProposal = no_tupling + ; + % We need a new variable to act as the cell variable while + % counting loads/stores for a proposed tupling, but we don't + % add that variable to the varset permanently. + varset__new_named_var(VarSet, "DummyCellVar", DummyCellVar, _), + FieldVars = assoc_list__keys(FieldVarArgPos), + TuplingProposal = tupling(DummyCellVar, FieldVars, FieldVarArgPos) + ). :- pred less_total_cost(costs::in, costs::in) is semidet. less_total_cost(costs(LoadsA, StoresA), costs(LoadsB, StoresB)) :- - TotalA = LoadsA + StoresA, - TotalB = LoadsB + StoresB, - TotalA < TotalB. + TotalA = LoadsA + StoresA, + TotalB = LoadsB + StoresB, + TotalA < TotalB. %-----------------------------------------------------------------------------% - % fold_over_list_runs(Pred, List, MinRunLength, !Acc) - % Call Pred for each consecutive run of elements in List of a length - % greater or equal to MinRunLength, threading an accumulator through - % it. - % + % fold_over_list_runs(Pred, List, MinRunLength, !Acc): + % + % Call Pred for each consecutive run of elements in List of a length + % greater or equal to MinRunLength, threading an accumulator through it. + % :- pred fold_over_list_runs(pred(list(L), A, A)::in(pred(in, in, out) is det), - list(L)::in, int::in, A::in, A::out) is det. + list(L)::in, int::in, A::in, A::out) is det. fold_over_list_runs(_, [], _, !Acc). fold_over_list_runs(Pred, List @ [_ | Tail], MinLength, !Acc) :- - fold_over_list_runs_2(Pred, List, MinLength, !Acc), - fold_over_list_runs(Pred, Tail, MinLength, !Acc). + fold_over_list_runs_2(Pred, List, MinLength, !Acc), + fold_over_list_runs(Pred, Tail, MinLength, !Acc). :- pred fold_over_list_runs_2( - pred(list(L), A, A)::in(pred(in, in, out) is det), - list(L)::in, int::in, A::in, A::out) is det. + pred(list(L), A, A)::in(pred(in, in, out) is det), + list(L)::in, int::in, A::in, A::out) is det. fold_over_list_runs_2(Pred, List, Length, !Acc) :- - ( list__take(Length, List, Front) -> - Pred(Front, !Acc), - fold_over_list_runs_2(Pred, List, Length+1, !Acc) - ; - true - ). + ( list__take(Length, List, Front) -> + Pred(Front, !Acc), + fold_over_list_runs_2(Pred, List, Length+1, !Acc) + ; + true + ). %-----------------------------------------------------------------------------% % @@ -613,199 +603,196 @@ fold_over_list_runs_2(Pred, List, Length, !Acc) :- % :- pred add_transformed_procs(tupling_scheme::in, module_info::in, - module_info::out, counter::in, counter::out, transform_map::in, - transform_map::out) is det. + module_info::out, counter::in, counter::out, transform_map::in, + transform_map::out) is det. add_transformed_procs(TuplingScheme, !ModuleInfo, !Counter, !TransformMap) :- - map__foldl3(add_transformed_proc, TuplingScheme, - !ModuleInfo, !Counter, !TransformMap). + map__foldl3(add_transformed_proc, TuplingScheme, + !ModuleInfo, !Counter, !TransformMap). :- pred add_transformed_proc(pred_proc_id::in, tupling_proposal::in, - module_info::in, module_info::out, counter::in, counter::out, - transform_map::in, transform_map::out) is det. + module_info::in, module_info::out, counter::in, counter::out, + transform_map::in, transform_map::out) is det. add_transformed_proc(PredProcId, tupling(_, FieldVars, _), - !ModuleInfo, !Counter, !TransformMap) :- - PredProcId = proc(PredId, ProcId), - some [!ProcInfo] ( - module_info_pred_proc_info(!.ModuleInfo, - PredId, ProcId, PredInfo, !:ProcInfo), + !ModuleInfo, !Counter, !TransformMap) :- + PredProcId = proc(PredId, ProcId), + some [!ProcInfo] ( + module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId, + PredInfo, !:ProcInfo), - % Build up information about intervals and which - % variables are needed in each interval. - build_interval_info(!.ModuleInfo, !.ProcInfo, IntervalInfo), + % Build up information about intervals and which variables + % are needed in each interval. + build_interval_info(!.ModuleInfo, !.ProcInfo, IntervalInfo), - % Create the cell variable. - list__length(FieldVars, TupleArity), - proc_info_vartypes(!.ProcInfo, VarTypes), - list__map(map__lookup(VarTypes), FieldVars, TupleArgTypes), - construct_type(unqualified("{}") - TupleArity, TupleArgTypes, - TupleConsType), - proc_info_create_var_from_type(TupleConsType, - yes("TuplingCellVar"), CellVar, !ProcInfo), + % Create the cell variable. + list__length(FieldVars, TupleArity), + proc_info_vartypes(!.ProcInfo, VarTypes), + list__map(map__lookup(VarTypes), FieldVars, TupleArgTypes), + construct_type(unqualified("{}") - TupleArity, TupleArgTypes, + TupleConsType), + proc_info_create_var_from_type(TupleConsType, + yes("TuplingCellVar"), CellVar, !ProcInfo), - % Get the argument positions of the parameters to be tupled. - proc_info_headvars(!.ProcInfo, HeadVars), - list__map(nth_member_lookup(HeadVars), FieldVars, ArgsToTuple), + % Get the argument positions of the parameters to be tupled. + proc_info_headvars(!.ProcInfo, HeadVars), + list__map(nth_member_lookup(HeadVars), FieldVars, ArgsToTuple), - % Build an insertion map of where the deconstruction - % unifications are needed. - build_insert_map(CellVar, FieldVars, IntervalInfo, InsertMap), + % Build an insertion map of where the deconstruction + % unifications are needed. + build_insert_map(CellVar, FieldVars, IntervalInfo, InsertMap), - % Make a transformed version of the procedure and add it to - % the module. - make_transformed_proc(CellVar, FieldVars, InsertMap, - !ProcInfo), - recompute_instmap_delta_proc(yes, !ProcInfo, !ModuleInfo), - counter__allocate(Num, !Counter), - create_aux_pred(PredId, ProcId, PredInfo, !.ProcInfo, Num, - AuxPredProcId, CallAux, !ModuleInfo), + % Make a transformed version of the procedure and add it to + % the module. + make_transformed_proc(CellVar, FieldVars, InsertMap, !ProcInfo), + recompute_instmap_delta_proc(yes, !ProcInfo, !ModuleInfo), + counter__allocate(Num, !Counter), + create_aux_pred(PredId, ProcId, PredInfo, !.ProcInfo, Num, + AuxPredProcId, CallAux, !ModuleInfo), - % Add an entry to the transform map for the new procedure. - TransformedProc = transformed_proc(AuxPredProcId, - TupleConsType, ArgsToTuple, CallAux), - svmap__det_insert(PredProcId, TransformedProc, !TransformMap) - ). + % Add an entry to the transform map for the new procedure. + TransformedProc = transformed_proc(AuxPredProcId, TupleConsType, + ArgsToTuple, CallAux), + svmap__det_insert(PredProcId, TransformedProc, !TransformMap) + ). add_transformed_proc(_, no_tupling, !ModuleInfo, !TransformMap, !Counter). %-----------------------------------------------------------------------------% :- pred make_transformed_proc(prog_var::in, prog_vars::in, insert_map::in, - proc_info::in, proc_info::out) is det. + proc_info::in, proc_info::out) is det. make_transformed_proc(CellVar, FieldVarsList, InsertMap, !ProcInfo) :- - % Modify the procedure's formal parameters. - proc_info_headvars(!.ProcInfo, HeadVars0), - proc_info_argmodes(!.ProcInfo, ArgModes0), - HeadVarsAndModes = list__filter_map_corresponding( - (func(Var, Mode) = (Var - Mode) is semidet :- - not Var `list.member` FieldVarsList), - HeadVars0, ArgModes0), - assoc_list__keys_and_values(HeadVarsAndModes, HeadVars, ArgModes), - proc_info_set_headvars(HeadVars ++ [CellVar], !ProcInfo), - proc_info_set_argmodes(ArgModes ++ [in_mode], !ProcInfo), + % Modify the procedure's formal parameters. + proc_info_headvars(!.ProcInfo, HeadVars0), + proc_info_argmodes(!.ProcInfo, ArgModes0), + HeadVarsAndModes = list__filter_map_corresponding( + (func(Var, Mode) = (Var - Mode) is semidet :- + not Var `list.member` FieldVarsList), + HeadVars0, ArgModes0), + assoc_list__keys_and_values(HeadVarsAndModes, HeadVars, ArgModes), + proc_info_set_headvars(HeadVars ++ [CellVar], !ProcInfo), + proc_info_set_argmodes(ArgModes ++ [in_mode], !ProcInfo), - % Insert the necessary deconstruction unifications. - proc_info_goal(!.ProcInfo, Goal0), - proc_info_vartypes(!.ProcInfo, VarTypes0), - proc_info_varset(!.ProcInfo, VarSet0), - % XXX: I haven't checked if adding this feature has any effect. - MaybeGoalFeature = yes(tuple_opt), - record_decisions_in_goal(Goal0, Goal1, VarSet0, VarSet1, - VarTypes0, VarTypes1, map__init, RenameMapA, InsertMap, - MaybeGoalFeature), + % Insert the necessary deconstruction unifications. + proc_info_goal(!.ProcInfo, Goal0), + proc_info_vartypes(!.ProcInfo, VarTypes0), + proc_info_varset(!.ProcInfo, VarSet0), + % XXX: I haven't checked if adding this feature has any effect. + MaybeGoalFeature = yes(tuple_opt), + record_decisions_in_goal(Goal0, Goal1, VarSet0, VarSet1, + VarTypes0, VarTypes1, map__init, RenameMapA, InsertMap, + MaybeGoalFeature), - % In some cases some of the field variables need to be available at - % the very beginning of the procedure. The required deconstructions - % for those variables won't show up in the insert map. To handle this - % we just to insert a deconstruction unification at the start of the - % procedure and let a simplification pass remove it later if not - % required. - % - % We could make build_insert_map add such required unifications - % to the insert map, but record_decisions_in_goal would need to be - % modified as well. - % - deconstruct_tuple(CellVar, FieldVarsList, ProcStartDeconstruct), - ProcStartInsert = insert_spec(ProcStartDeconstruct, - set__from_list(FieldVarsList)), - insert_proc_start_deconstruction(Goal1, Goal2, - VarSet1, VarSet, VarTypes1, VarTypes, - RenameMapB, ProcStartInsert), - rename_vars_in_goal(RenameMapB, Goal2, Goal3), + % In some cases some of the field variables need to be available at + % the very beginning of the procedure. The required deconstructions + % for those variables won't show up in the insert map. To handle this + % we just to insert a deconstruction unification at the start of the + % procedure and let a simplification pass remove it later if not required. + % + % We could make build_insert_map add such required unifications to the + % insert map, but record_decisions_in_goal would need to be modified + % as well. + % + deconstruct_tuple(CellVar, FieldVarsList, ProcStartDeconstruct), + ProcStartInsert = insert_spec(ProcStartDeconstruct, + set__from_list(FieldVarsList)), + insert_proc_start_deconstruction(Goal1, Goal2, + VarSet1, VarSet, VarTypes1, VarTypes, + RenameMapB, ProcStartInsert), + rename_vars_in_goal(RenameMapB, Goal2, Goal3), - map__merge(RenameMapA, RenameMapB, RenameMap), - apply_headvar_correction(set__from_list(HeadVars), RenameMap, - Goal3, Goal), - proc_info_set_goal(Goal, !ProcInfo), - proc_info_set_varset(VarSet, !ProcInfo), - proc_info_set_vartypes(VarTypes, !ProcInfo), - requantify_proc(!ProcInfo). + map__merge(RenameMapA, RenameMapB, RenameMap), + apply_headvar_correction(set__from_list(HeadVars), RenameMap, Goal3, Goal), + proc_info_set_goal(Goal, !ProcInfo), + proc_info_set_varset(VarSet, !ProcInfo), + proc_info_set_vartypes(VarTypes, !ProcInfo), + requantify_proc(!ProcInfo). :- pred insert_proc_start_deconstruction(hlds_goal::in, hlds_goal::out, - prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, - rename_map::out, insert_spec::in) is det. + prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, + rename_map::out, insert_spec::in) is det. -insert_proc_start_deconstruction(Goal0, Goal, - !VarSet, !VarTypes, VarRename, Insert) :- - % The tuple_opt feature is not used for this goal as we do - % want other transformations to remove it if possible. - make_inserted_goal(!VarSet, !VarTypes, map__init, VarRename, - Insert, no, InsertGoal), - Goal0 = _ - GoalInfo, - conj_list_to_goal([InsertGoal, Goal0], GoalInfo, Goal). +insert_proc_start_deconstruction(Goal0, Goal, !VarSet, !VarTypes, + VarRename, Insert) :- + % The tuple_opt feature is not used for this goal as we do want + % other transformations to remove it if possible. + make_inserted_goal(!VarSet, !VarTypes, map__init, VarRename, + Insert, no, InsertGoal), + Goal0 = _ - GoalInfo, + conj_list_to_goal([InsertGoal, Goal0], GoalInfo, Goal). %-----------------------------------------------------------------------------% - % This predicate makes a new version of the given procedure in a - % module. Amongst other things the new procedure is given a new - % pred_id and proc_id, a new name and a new goal. - % - % CallAux is an output variable, which is unified with a goal that - % can be used as a template for constructing calls to the newly - % created procedure. - % - % See also create_aux_pred in loop_inv.m. - % + % This predicate makes a new version of the given procedure in a module. + % Amongst other things the new procedure is given a new pred_id and + % proc_id, a new name and a new goal. + % + % CallAux is an output variable, which is unified with a goal that + % can be used as a template for constructing calls to the newly + % created procedure. + % + % See also create_aux_pred in loop_inv.m. + % :- pred create_aux_pred(pred_id::in, proc_id::in, pred_info::in, - proc_info::in, int::in, pred_proc_id::out, hlds_goal::out, - module_info::in, module_info::out) is det. + proc_info::in, int::in, pred_proc_id::out, hlds_goal::out, + module_info::in, module_info::out) is det. create_aux_pred(PredId, ProcId, PredInfo, ProcInfo, Counter, - AuxPredProcId, CallAux, ModuleInfo0, ModuleInfo) :- - module_info_get_name(ModuleInfo0, ModuleName), + AuxPredProcId, CallAux, ModuleInfo0, ModuleInfo) :- + module_info_get_name(ModuleInfo0, ModuleName), - proc_info_headvars(ProcInfo, AuxHeadVars), - proc_info_goal(ProcInfo, Goal @ (_GoalExpr - GoalInfo)), - proc_info_get_initial_instmap(ProcInfo, ModuleInfo0, - InitialAuxInstMap), - pred_info_typevarset(PredInfo, TVarSet), - proc_info_vartypes(ProcInfo, VarTypes), - pred_info_get_class_context(PredInfo, ClassContext), - proc_info_rtti_varmaps(ProcInfo, RttiVarMaps), - proc_info_varset(ProcInfo, VarSet), - proc_info_inst_varset(ProcInfo, InstVarSet), - pred_info_get_markers(PredInfo, Markers), - pred_info_get_aditi_owner(PredInfo, Owner), - pred_info_get_origin(PredInfo, OrigOrigin), + proc_info_headvars(ProcInfo, AuxHeadVars), + proc_info_goal(ProcInfo, Goal @ (_GoalExpr - GoalInfo)), + proc_info_get_initial_instmap(ProcInfo, ModuleInfo0, + InitialAuxInstMap), + pred_info_typevarset(PredInfo, TVarSet), + proc_info_vartypes(ProcInfo, VarTypes), + pred_info_get_class_context(PredInfo, ClassContext), + proc_info_rtti_varmaps(ProcInfo, RttiVarMaps), + proc_info_varset(ProcInfo, VarSet), + proc_info_inst_varset(ProcInfo, InstVarSet), + pred_info_get_markers(PredInfo, Markers), + pred_info_get_aditi_owner(PredInfo, Owner), + pred_info_get_origin(PredInfo, OrigOrigin), - PredName = pred_info_name(PredInfo), - PredOrFunc = pred_info_is_pred_or_func(PredInfo), - goal_info_get_context(GoalInfo, Context), - term__context_line(Context, Line), - proc_id_to_int(ProcId, ProcNo), - AuxNamePrefix = string__format("tupling_%d", [i(ProcNo)]), - make_pred_name_with_context(ModuleName, AuxNamePrefix, - PredOrFunc, PredName, Line, Counter, AuxPredSymName), - ( - AuxPredSymName = unqualified(AuxPredName) - ; - AuxPredSymName = qualified(_ModuleSpecifier, AuxPredName) - ), + PredName = pred_info_name(PredInfo), + PredOrFunc = pred_info_is_pred_or_func(PredInfo), + goal_info_get_context(GoalInfo, Context), + term__context_line(Context, Line), + proc_id_to_int(ProcId, ProcNo), + AuxNamePrefix = string__format("tupling_%d", [i(ProcNo)]), + make_pred_name_with_context(ModuleName, AuxNamePrefix, + PredOrFunc, PredName, Line, Counter, AuxPredSymName), + ( + AuxPredSymName = unqualified(AuxPredName) + ; + AuxPredSymName = qualified(_ModuleSpecifier, AuxPredName) + ), - Origin = transformed(tuple(ProcNo), OrigOrigin, PredId), - hlds_pred__define_new_pred( - Origin, % in - Goal, % in - CallAux, % out - AuxHeadVars, % in - _ExtraArgs, % out - InitialAuxInstMap, % in - AuxPredName, % in - TVarSet, % in - VarTypes, % in - ClassContext, % in - RttiVarMaps, % in - VarSet, % in - InstVarSet, % in - Markers, % in - Owner, % in - address_is_not_taken, % in - ModuleInfo0, - ModuleInfo, - AuxPredProcId - ). + Origin = transformed(tuple(ProcNo), OrigOrigin, PredId), + hlds_pred__define_new_pred( + Origin, % in + Goal, % in + CallAux, % out + AuxHeadVars, % in + _ExtraArgs, % out + InitialAuxInstMap, % in + AuxPredName, % in + TVarSet, % in + VarTypes, % in + ClassContext, % in + RttiVarMaps, % in + VarSet, % in + InstVarSet, % in + Markers, % in + Owner, % in + address_is_not_taken, % in + ModuleInfo0, + ModuleInfo, + AuxPredProcId + ). %-----------------------------------------------------------------------------% % @@ -813,683 +800,671 @@ create_aux_pred(PredId, ProcId, PredInfo, ProcInfo, Counter, % :- type count_info - ---> count_info( - count_info_pred_proc_id :: pred_proc_id, - % Which procedure is being counted. - count_info_proc :: proc_info, - count_info_module :: module_info, - count_info_proc_counts :: proc_trace_counts, - count_info_params :: tuning_params, - tupling_scheme :: tupling_scheme - ). + ---> count_info( + count_info_pred_proc_id :: pred_proc_id, + % Which procedure is being counted. + count_info_proc :: proc_info, + count_info_module :: module_info, + count_info_proc_counts :: proc_trace_counts, + count_info_params :: tuning_params, + tupling_scheme :: tupling_scheme + ). :- type tuning_params - ---> tuning_params( - normal_var_load_cost :: int, - normal_var_store_cost :: int, - cell_var_load_cost :: int, - cell_var_store_cost :: int, - field_var_load_cost :: int, - field_var_store_cost :: int, - costs_ratio :: int, - min_args_to_tuple :: int - ). + ---> tuning_params( + normal_var_load_cost :: int, + normal_var_store_cost :: int, + cell_var_load_cost :: int, + cell_var_store_cost :: int, + field_var_load_cost :: int, + field_var_store_cost :: int, + costs_ratio :: int, + min_args_to_tuple :: int + ). :- type count_state - ---> count_state( - reg_vars :: set(prog_var), - stack_vars :: set(prog_var), - load_costs :: float, - store_costs :: float - ). + ---> count_state( + reg_vars :: set(prog_var), + stack_vars :: set(prog_var), + load_costs :: float, + store_costs :: float + ). :- type costs - ---> costs( - avg_loads :: float, - avg_stores :: float - ). + ---> costs( + avg_loads :: float, + avg_stores :: float + ). :- func get_tupling_proposal(count_info, pred_proc_id) = tupling_proposal - is det. + is det. get_tupling_proposal(CountInfo, PredProcId) = TuplingProposal :- - ( map__search(CountInfo ^ tupling_scheme, PredProcId, Probe) -> - TuplingProposal = Probe - ; - TuplingProposal = no_tupling - ). + ( map__search(CountInfo ^ tupling_scheme, PredProcId, Probe) -> + TuplingProposal = Probe + ; + TuplingProposal = no_tupling + ). :- func get_own_tupling_proposal(count_info) = tupling_proposal is det. get_own_tupling_proposal(CountInfo) = - get_tupling_proposal(CountInfo, CountInfo ^ count_info_pred_proc_id). + get_tupling_proposal(CountInfo, CountInfo ^ count_info_pred_proc_id). %-----------------------------------------------------------------------------% - % Collect all the information for a procedure that is required for - % the count_load_stores_in_proc predicate to work. - % + % Collect all the information for a procedure that is required for + % the count_load_stores_in_proc predicate to work. + % :- pred prepare_proc_for_counting(pred_proc_id::in, - module_info::in, module_info::out, io::di, io::uo) is det. + module_info::in, module_info::out, io::di, io::uo) is det. prepare_proc_for_counting(PredProcId, !ModuleInfo, !IO) :- - PredProcId = proc(PredId, ProcId), - some [!ProcInfo] ( - module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId, - PredInfo, !:ProcInfo), - pred_info_arg_types(PredInfo, ArgTypes), - generate_proc_arg_info(ArgTypes, !.ModuleInfo, !ProcInfo), + PredProcId = proc(PredId, ProcId), + some [!ProcInfo] ( + module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId, + PredInfo, !:ProcInfo), + pred_info_arg_types(PredInfo, ArgTypes), + generate_proc_arg_info(ArgTypes, !.ModuleInfo, !ProcInfo), - detect_liveness_proc(PredId, ProcId, !.ModuleInfo, !ProcInfo, - !IO), - initial_liveness(!.ProcInfo, PredId, !.ModuleInfo, Liveness0), - module_info_get_globals(!.ModuleInfo, Globals), - body_should_use_typeinfo_liveness(PredInfo, Globals, - TypeInfoLiveness), - globals__lookup_bool_option(Globals, - opt_no_return_calls, OptNoReturnCalls), - AllocData = alloc_data(!.ModuleInfo, !.ProcInfo, - TypeInfoLiveness, OptNoReturnCalls), - goal_path__fill_slots(!.ModuleInfo, !ProcInfo), - proc_info_goal(!.ProcInfo, Goal0), - OptTupleAlloc0 = opt_tuple_alloc, - set__init(FailVars), - set__init(NondetLiveness0), - build_live_sets_in_goal(Goal0, Goal, FailVars, - AllocData, OptTupleAlloc0, _OptTupleAlloc, - Liveness0, _Liveness, - NondetLiveness0, _NondetLiveness), - proc_info_set_goal(Goal, !ProcInfo), + detect_liveness_proc(PredId, ProcId, !.ModuleInfo, !ProcInfo, !IO), + initial_liveness(!.ProcInfo, PredId, !.ModuleInfo, Liveness0), + module_info_get_globals(!.ModuleInfo, Globals), + body_should_use_typeinfo_liveness(PredInfo, Globals, + TypeInfoLiveness), + globals__lookup_bool_option(Globals, + opt_no_return_calls, OptNoReturnCalls), + AllocData = alloc_data(!.ModuleInfo, !.ProcInfo, + TypeInfoLiveness, OptNoReturnCalls), + goal_path__fill_slots(!.ModuleInfo, !ProcInfo), + proc_info_goal(!.ProcInfo, Goal0), + OptTupleAlloc0 = opt_tuple_alloc, + set__init(FailVars), + set__init(NondetLiveness0), + build_live_sets_in_goal(Goal0, Goal, FailVars, AllocData, + OptTupleAlloc0, _OptTupleAlloc, Liveness0, _Liveness, + NondetLiveness0, _NondetLiveness), + proc_info_set_goal(Goal, !ProcInfo), - module_info_set_pred_proc_info(PredId, ProcId, - PredInfo, !.ProcInfo, !ModuleInfo) - ). + module_info_set_pred_proc_info(PredId, ProcId, + PredInfo, !.ProcInfo, !ModuleInfo) + ). %-----------------------------------------------------------------------------% % The opt_tuple_alloc structure is constructed by live_vars.m. As far as I can % tell we don't need such a thing for this module so we just define some stubs. -:- type opt_tuple_alloc ---> opt_tuple_alloc. +:- type opt_tuple_alloc + ---> opt_tuple_alloc. :- instance stack_alloc_info(opt_tuple_alloc) where [ - pred(at_call_site/4) is opt_at_call_site, - pred(at_resume_site/4) is opt_at_resume_site, - pred(at_par_conj/4) is opt_at_par_conj + pred(at_call_site/4) is opt_at_call_site, + pred(at_resume_site/4) is opt_at_resume_site, + pred(at_par_conj/4) is opt_at_par_conj ]. :- pred opt_at_call_site(need_across_call::in, hlds_goal_info::in, - opt_tuple_alloc::in, opt_tuple_alloc::out) is det. + opt_tuple_alloc::in, opt_tuple_alloc::out) is det. opt_at_call_site(_NeedAtCall, _GoalInfo, StackAlloc, StackAlloc). :- pred opt_at_resume_site(need_in_resume::in, hlds_goal_info::in, - opt_tuple_alloc::in, opt_tuple_alloc::out) is det. + opt_tuple_alloc::in, opt_tuple_alloc::out) is det. opt_at_resume_site(_NeedAtResume, _GoalInfo, StackAlloc, StackAlloc). :- pred opt_at_par_conj(need_in_par_conj::in, hlds_goal_info::in, - opt_tuple_alloc::in, opt_tuple_alloc::out) is det. + opt_tuple_alloc::in, opt_tuple_alloc::out) is det. opt_at_par_conj(_NeedParConj, _GoalInfo, StackAlloc, StackAlloc). %-----------------------------------------------------------------------------% :- pred count_load_stores_for_scc(trace_counts::in, tuning_params::in, - module_info::in, tupling_scheme::in, list(pred_proc_id)::in, - costs::out) is det. + module_info::in, tupling_scheme::in, list(pred_proc_id)::in, costs::out) + is det. count_load_stores_for_scc(TraceCounts, TuningParams, ModuleInfo, - TuplingScheme, PredProcIds, costs(Loads, Stores)) :- - list__foldl2(count_load_stores_for_scc_2(TraceCounts, - TuningParams, ModuleInfo, TuplingScheme), - PredProcIds, - 0.0, Loads, 0.0, Stores). + TuplingScheme, PredProcIds, costs(Loads, Stores)) :- + list__foldl2(count_load_stores_for_scc_2(TraceCounts, + TuningParams, ModuleInfo, TuplingScheme), + PredProcIds, 0.0, Loads, 0.0, Stores). :- pred count_load_stores_for_scc_2(trace_counts::in, tuning_params::in, - module_info::in, tupling_scheme::in, pred_proc_id::in, - float::in, float::out, float::in, float::out) is det. + module_info::in, tupling_scheme::in, pred_proc_id::in, + float::in, float::out, float::in, float::out) is det. count_load_stores_for_scc_2(TraceCounts, TuningParams, ModuleInfo, - TuplingScheme, PredProcId, !Loads, !Stores) :- - PredProcId = proc(PredId, ProcId), - module_info_pred_proc_info(ModuleInfo, PredId, ProcId, - PredInfo, ProcInfo), - % XXX: Different declaring vs defining modules not handled. - ProcLabel = proc(pred_info_module(PredInfo), - pred_info_is_pred_or_func(PredInfo), - pred_info_module(PredInfo), - pred_info_name(PredInfo), - pred_info_orig_arity(PredInfo), - proc_id_to_int(ProcId)), - pred_info_context(PredInfo, Context), - Context = context(FileName, _), - ProcLabelAndFile = proc_label_and_filename(ProcLabel, FileName), - ( get_proc_counts(TraceCounts, ProcLabelAndFile, yes(ProcCounts)) -> - count_load_stores_in_proc(count_info(PredProcId, ProcInfo, - ModuleInfo, ProcCounts, TuningParams, TuplingScheme), - ProcLoads, ProcStores), - % XXX: There is a problem somewhere causing CALL and EXIT - % events not to show up for some procedures in trace count - % files. The weighting of the procedure's costs is disabled. - % However, if working, it still wouldn't be ideal as we don't - % know how many of the calls to the procedure came from within - % or without the SCC. - /*get_proc_calls(ProcCounts, Weight),*/ - Weight = 1, - !:Loads = !.Loads + float(Weight) * ProcLoads, - !:Stores = !.Stores + float(Weight) * ProcStores - ; - true - ). + TuplingScheme, PredProcId, !Loads, !Stores) :- + PredProcId = proc(PredId, ProcId), + module_info_pred_proc_info(ModuleInfo, PredId, ProcId, + PredInfo, ProcInfo), + % XXX: Different declaring vs defining modules not handled. + ProcLabel = proc(pred_info_module(PredInfo), + pred_info_is_pred_or_func(PredInfo), + pred_info_module(PredInfo), + pred_info_name(PredInfo), + pred_info_orig_arity(PredInfo), + proc_id_to_int(ProcId)), + pred_info_context(PredInfo, Context), + Context = context(FileName, _), + ProcLabelAndFile = proc_label_and_filename(ProcLabel, FileName), + ( get_proc_counts(TraceCounts, ProcLabelAndFile, yes(ProcCounts)) -> + count_load_stores_in_proc(count_info(PredProcId, ProcInfo, + ModuleInfo, ProcCounts, TuningParams, TuplingScheme), + ProcLoads, ProcStores), + % XXX: There is a problem somewhere causing CALL and EXIT + % events not to show up for some procedures in trace count files. + % The weighting of the procedure's costs is disabled. + % However, if working, it still wouldn't be ideal as we don't + % know how many of the calls to the procedure came from within + % or without the SCC. + % get_proc_calls(ProcCounts, Weight), + Weight = 1, + !:Loads = !.Loads + float(Weight) * ProcLoads, + !:Stores = !.Stores + float(Weight) * ProcStores + ; + true + ). %-----------------------------------------------------------------------------% :- pred count_load_stores_in_proc(count_info::in, float::out, float::out) - is det. + is det. count_load_stores_in_proc(CountInfo, Loads, Stores) :- - proc(PredId, _) = CountInfo ^ count_info_pred_proc_id, - ProcInfo = CountInfo ^ count_info_proc, - ModuleInfo = CountInfo ^ count_info_module, - initial_liveness(ProcInfo, PredId, ModuleInfo, InitialLiveness), - CountState0 = count_state(InitialLiveness, set__init, 0.0, 0.0), - proc_info_goal(ProcInfo, Goal), - count_load_stores_in_goal(Goal, CountInfo, CountState0, CountState1), - arg_info__partition_proc_args(ProcInfo, ModuleInfo, _, OutputArgs, _), - cls_require_in_regs(CountInfo, set__to_sorted_list(OutputArgs), - CountState1, CountState), - CountState = count_state(_, _, Loads, Stores). + proc(PredId, _) = CountInfo ^ count_info_pred_proc_id, + ProcInfo = CountInfo ^ count_info_proc, + ModuleInfo = CountInfo ^ count_info_module, + initial_liveness(ProcInfo, PredId, ModuleInfo, InitialLiveness), + CountState0 = count_state(InitialLiveness, set__init, 0.0, 0.0), + proc_info_goal(ProcInfo, Goal), + count_load_stores_in_goal(Goal, CountInfo, CountState0, CountState1), + arg_info__partition_proc_args(ProcInfo, ModuleInfo, _, OutputArgs, _), + cls_require_in_regs(CountInfo, set__to_sorted_list(OutputArgs), + CountState1, CountState), + CountState = count_state(_, _, Loads, Stores). %-----------------------------------------------------------------------------% - % This code is based on interval__build_interval_info_in_goal. + % This code is based on interval__build_interval_info_in_goal. :- pred count_load_stores_in_goal(hlds_goal::in, count_info::in, - count_state::in, count_state::out) is det. + count_state::in, count_state::out) is det. count_load_stores_in_goal(Goal - GoalInfo, CountInfo, !CountState) :- - Goal = foreign_proc(_Attributes, PredId, ProcId, Args, ExtraArgs, - _PragmaCode), - ModuleInfo = CountInfo ^ count_info_module, - module_info_pred_proc_info(ModuleInfo, PredId, ProcId, - _PredInfo, ProcInfo), - ArgVars = list__map(foreign_arg_var, Args), - ExtraVars = list__map(foreign_arg_var, ExtraArgs), - CallingProcInfo = CountInfo ^ count_info_proc, - proc_info_vartypes(CallingProcInfo, VarTypes), - arg_info__partition_proc_call_args(ProcInfo, VarTypes, - ModuleInfo, ArgVars, InputArgVarSet, OutputArgVarSet, _), - set__to_sorted_list(InputArgVarSet, InputArgVars), - list__append(InputArgVars, ExtraVars, InputVars), - ( - goal_info_maybe_get_maybe_need_across_call(GoalInfo, - MaybeNeedAcrossCall), - MaybeNeedAcrossCall = yes(_) - -> - count_load_stores_for_call(CountInfo, InputVars, - OutputArgVarSet, MaybeNeedAcrossCall, GoalInfo, - !CountState) - ; - cls_require_in_regs(CountInfo, InputVars, !CountState), - cls_clobber_regs(OutputArgVarSet, !CountState) - ). + Goal = foreign_proc(_Attributes, PredId, ProcId, Args, ExtraArgs, + _PragmaCode), + ModuleInfo = CountInfo ^ count_info_module, + module_info_pred_proc_info(ModuleInfo, PredId, ProcId, + _PredInfo, ProcInfo), + ArgVars = list__map(foreign_arg_var, Args), + ExtraVars = list__map(foreign_arg_var, ExtraArgs), + CallingProcInfo = CountInfo ^ count_info_proc, + proc_info_vartypes(CallingProcInfo, VarTypes), + arg_info__partition_proc_call_args(ProcInfo, VarTypes, + ModuleInfo, ArgVars, InputArgVarSet, OutputArgVarSet, _), + set__to_sorted_list(InputArgVarSet, InputArgVars), + list__append(InputArgVars, ExtraVars, InputVars), + ( + goal_info_maybe_get_maybe_need_across_call(GoalInfo, + MaybeNeedAcrossCall), + MaybeNeedAcrossCall = yes(_) + -> + count_load_stores_for_call(CountInfo, InputVars, OutputArgVarSet, + MaybeNeedAcrossCall, GoalInfo, !CountState) + ; + cls_require_in_regs(CountInfo, InputVars, !CountState), + cls_clobber_regs(OutputArgVarSet, !CountState) + ). count_load_stores_in_goal(Goal - GoalInfo, CountInfo, !CountState) :- - Goal = generic_call(GenericCall, ArgVars, ArgModes, _Detism), - ProcInfo = CountInfo ^ count_info_proc, - ModuleInfo = CountInfo ^ count_info_module, - goal_info_get_maybe_need_across_call(GoalInfo, MaybeNeedAcrossCall), - proc_info_vartypes(ProcInfo, VarTypes), - list__map(map__lookup(VarTypes), ArgVars, ArgTypes), - arg_info__compute_in_and_out_vars(ModuleInfo, ArgVars, - ArgModes, ArgTypes, InputArgs, OutputArgs), + Goal = generic_call(GenericCall, ArgVars, ArgModes, _Detism), + ProcInfo = CountInfo ^ count_info_proc, + ModuleInfo = CountInfo ^ count_info_module, + goal_info_get_maybe_need_across_call(GoalInfo, MaybeNeedAcrossCall), + proc_info_vartypes(ProcInfo, VarTypes), + list__map(map__lookup(VarTypes), ArgVars, ArgTypes), + arg_info__compute_in_and_out_vars(ModuleInfo, ArgVars, + ArgModes, ArgTypes, InputArgs, OutputArgs), - % Casts are generated inline. - ( GenericCall = cast(_) -> - cls_require_in_regs(CountInfo, InputArgs, !CountState), - cls_put_in_regs(OutputArgs, !CountState) - ; - module_info_get_globals(ModuleInfo, Globals), - call_gen__generic_call_info(Globals, GenericCall, - length(InputArgs), _, GenericVarsArgInfos, _, _), - assoc_list__keys(GenericVarsArgInfos, GenericVars), - list__append(GenericVars, InputArgs, Inputs), - set__list_to_set(OutputArgs, Outputs), - count_load_stores_for_call(CountInfo, Inputs, Outputs, - MaybeNeedAcrossCall, GoalInfo, !CountState) - ). + % Casts are generated inline. + ( GenericCall = cast(_) -> + cls_require_in_regs(CountInfo, InputArgs, !CountState), + cls_put_in_regs(OutputArgs, !CountState) + ; + module_info_get_globals(ModuleInfo, Globals), + call_gen__generic_call_info(Globals, GenericCall, + length(InputArgs), _, GenericVarsArgInfos, _, _), + assoc_list__keys(GenericVarsArgInfos, GenericVars), + list__append(GenericVars, InputArgs, Inputs), + set__list_to_set(OutputArgs, Outputs), + count_load_stores_for_call(CountInfo, Inputs, Outputs, + MaybeNeedAcrossCall, GoalInfo, !CountState) + ). count_load_stores_in_goal(Goal - GoalInfo, CountInfo, !CountState) :- - Goal = call(PredId, ProcId, _, Builtin, _, _), - ( - Builtin = not_builtin, - TuplingProposal = get_tupling_proposal(CountInfo, - proc(PredId, ProcId)), - TuplingProposal = tupling(_, _, _) - -> - count_load_stores_in_call_to_tupled(Goal - GoalInfo, - CountInfo, TuplingProposal, !CountState) - ; - count_load_stores_in_call_to_not_tupled(Goal - GoalInfo, - CountInfo, !CountState) - ). + Goal = call(PredId, ProcId, _, Builtin, _, _), + ( + Builtin = not_builtin, + TuplingProposal = get_tupling_proposal(CountInfo, + proc(PredId, ProcId)), + TuplingProposal = tupling(_, _, _) + -> + count_load_stores_in_call_to_tupled(Goal - GoalInfo, + CountInfo, TuplingProposal, !CountState) + ; + count_load_stores_in_call_to_not_tupled(Goal - GoalInfo, + CountInfo, !CountState) + ). count_load_stores_in_goal(Goal - _GoalInfo, CountInfo, !CountState) :- - Goal = unify(_, _, _, Unification, _), - ( - Unification = construct(CellVar, _ConsId, ArgVars, _ArgModes, - _HowToConstruct, _, _), - cls_require_in_regs(CountInfo, ArgVars, !CountState), - cls_put_in_regs([CellVar], !CountState) - ; - Unification = deconstruct(CellVar, _ConsId, ArgVars, - _ArgModes, _, _), - cls_put_in_regs_via_deconstruct(CountInfo, CellVar, ArgVars, - !CountState) - ; - Unification = assign(ToVar, FromVar), - cls_require_in_reg(CountInfo, FromVar, !CountState), - cls_put_in_regs([ToVar], !CountState) - ; - Unification = simple_test(Var1, Var2), - cls_require_in_regs(CountInfo, [Var1, Var2], !CountState) - ; - Unification = complicated_unify(_, _, _), - unexpected(this_file, - "count_load_stores_in_goal: complicated_unify") - ). + Goal = unify(_, _, _, Unification, _), + ( + Unification = construct(CellVar, _ConsId, ArgVars, _ArgModes, + _HowToConstruct, _, _), + cls_require_in_regs(CountInfo, ArgVars, !CountState), + cls_put_in_regs([CellVar], !CountState) + ; + Unification = deconstruct(CellVar, _ConsId, ArgVars, _ArgModes, _, _), + cls_put_in_regs_via_deconstruct(CountInfo, CellVar, ArgVars, + !CountState) + ; + Unification = assign(ToVar, FromVar), + cls_require_in_reg(CountInfo, FromVar, !CountState), + cls_put_in_regs([ToVar], !CountState) + ; + Unification = simple_test(Var1, Var2), + cls_require_in_regs(CountInfo, [Var1, Var2], !CountState) + ; + Unification = complicated_unify(_, _, _), + unexpected(this_file, "count_load_stores_in_goal: complicated_unify") + ). count_load_stores_in_goal(scope(_Reason, Goal) - _GoalInfo, CountInfo, - !CountState) :- - count_load_stores_in_goal(Goal, CountInfo, !CountState). + !CountState) :- + count_load_stores_in_goal(Goal, CountInfo, !CountState). count_load_stores_in_goal(conj(Goals) - _GoalInfo, CountInfo, !CountState) :- - count_load_stores_in_conj(Goals, CountInfo, !CountState). + count_load_stores_in_conj(Goals, CountInfo, !CountState). count_load_stores_in_goal(par_conj(_) - _, _, !_) :- - sorry(this_file, "tupling with parallel conjunctions"). + sorry(this_file, "tupling with parallel conjunctions"). count_load_stores_in_goal(disj(Goals) - _GoalInfo, CountInfo, !CountState) :- - count_load_stores_in_disj(Goals, CountInfo, !CountState). + count_load_stores_in_disj(Goals, CountInfo, !CountState). count_load_stores_in_goal(switch(_Var, _Det, Cases) - _GoalInfo, CountInfo, - !CountState) :- - count_load_stores_in_cases(Cases, CountInfo, !CountState). + !CountState) :- + count_load_stores_in_cases(Cases, CountInfo, !CountState). count_load_stores_in_goal(not(Goal) - _GoalInfo, CountInfo, !CountState) :- - goal_info_get_resume_point(snd(Goal), ResumePoint), - ( - ResumePoint = resume_point(LiveVars, _ResumeLocs), - cls_require_flushed(CountInfo, LiveVars, !CountState) - ; - ResumePoint = no_resume_point, - unexpected(this_file, - "count_load_stores_in_goal: no_resume_point for not") - ), - count_load_stores_in_goal(Goal, CountInfo, !CountState). + goal_info_get_resume_point(snd(Goal), ResumePoint), + ( + ResumePoint = resume_point(LiveVars, _ResumeLocs), + cls_require_flushed(CountInfo, LiveVars, !CountState) + ; + ResumePoint = no_resume_point, + unexpected(this_file, + "count_load_stores_in_goal: no_resume_point for not") + ), + count_load_stores_in_goal(Goal, CountInfo, !CountState). count_load_stores_in_goal(if_then_else(_, Cond, Then, Else) - _GoalInfo, - CountInfo, !CountState) :- - goal_info_get_resume_point(snd(Cond), ResumePoint), - ( - ResumePoint = resume_point(LiveVars, _ResumeLocs), - cls_require_flushed(CountInfo, LiveVars, !CountState), - count_load_stores_in_goal(Cond, CountInfo, !CountState), + CountInfo, !CountState) :- + goal_info_get_resume_point(snd(Cond), ResumePoint), + ( + ResumePoint = resume_point(LiveVars, _ResumeLocs), + cls_require_flushed(CountInfo, LiveVars, !CountState), + count_load_stores_in_goal(Cond, CountInfo, !CountState), - reset_count_state_counts(!.CountState, ResetCountInfo), - count_load_stores_in_goal(Then, CountInfo, - ResetCountInfo, ThenCountInfo), - count_load_stores_in_goal(Else, CountInfo, - ResetCountInfo, ElseCountInfo), + reset_count_state_counts(!.CountState, ResetCountInfo), + count_load_stores_in_goal(Then, CountInfo, + ResetCountInfo, ThenCountInfo), + count_load_stores_in_goal(Else, CountInfo, + ResetCountInfo, ElseCountInfo), - ProcCounts = CountInfo ^ count_info_proc_counts, - goal_info_get_goal_path(snd(Then), ThenGoalPath), - goal_info_get_goal_path(snd(Else), ElseGoalPath), - get_ite_relative_frequencies(ProcCounts, - ThenGoalPath, ElseGoalPath, - ThenRelFreq, ElseRelFreq), + ProcCounts = CountInfo ^ count_info_proc_counts, + goal_info_get_goal_path(snd(Then), ThenGoalPath), + goal_info_get_goal_path(snd(Else), ElseGoalPath), + get_ite_relative_frequencies(ProcCounts, + ThenGoalPath, ElseGoalPath, + ThenRelFreq, ElseRelFreq), - add_branch_costs(ThenCountInfo, ThenRelFreq, !CountState), - add_branch_costs(ElseCountInfo, ElseRelFreq, !CountState) - ; - ResumePoint = no_resume_point, - unexpected(this_file, - "count_load_stores_in_goal: " ++ - "no_resume_point for if_then_else") - ). + add_branch_costs(ThenCountInfo, ThenRelFreq, !CountState), + add_branch_costs(ElseCountInfo, ElseRelFreq, !CountState) + ; + ResumePoint = no_resume_point, + unexpected(this_file, + "count_load_stores_in_goal: no_resume_point for if_then_else") + ). count_load_stores_in_goal(shorthand(_) - _, _, !_) :- - unexpected(this_file, - "count_load_stores_in_goal: unexpected shorthand"). + unexpected(this_file, + "count_load_stores_in_goal: unexpected shorthand"). %-----------------------------------------------------------------------------% :- inst call_goal_expr - == bound(call(ground, ground, ground, ground, ground, ground)). + == bound(call(ground, ground, ground, ground, ground, ground)). :- mode in_call_goal - == in(pair(call_goal_expr, ground)). + == in(pair(call_goal_expr, ground)). :- pred count_load_stores_in_call_to_tupled(hlds_goal::in_call_goal, - count_info::in, - tupling_proposal::in(bound(tupling(ground, ground, ground))), - count_state::in, count_state::out) is det. + count_info::in, + tupling_proposal::in(bound(tupling(ground, ground, ground))), + count_state::in, count_state::out) is det. count_load_stores_in_call_to_tupled(Goal - GoalInfo, CountInfo, - CalleeTuplingProposal, !CountState) :- - Goal = call(CalleePredId, CalleeProcId, ArgVars, _, _, _), - CalleeTuplingProposal = tupling(CellVar, FieldVars, FieldVarArgPos), - ModuleInfo = CountInfo ^ count_info_module, - module_info_pred_proc_info(ModuleInfo, CalleePredId, CalleeProcId, - _, CalleeProcInfo), - CallingProcInfo = CountInfo ^ count_info_proc, - proc_info_vartypes(CallingProcInfo, VarTypes), - arg_info__partition_proc_call_args(CalleeProcInfo, VarTypes, - ModuleInfo, ArgVars, InputArgs0, Outputs, _), - ( - % If the caller is a tupled procedure, and every field - % variable of the tuple appears as an input argument to the - % callee AND every such argument is in a position matching - % the field variable's position in the tupling proposal, then - % the cell var of the caller can be reused as the call var - % for the callee. - % - % TODO: If we kept track of the aliases of field variables, - % then they could be checked also. - get_own_tupling_proposal(CountInfo) = tupling(_, _, _), - all [Var] Var `list.member` FieldVars => ( - Var `set.member` InputArgs0, - assoc_list__search(FieldVarArgPos, Var, Pos), - list__nth_member_search(ArgVars, Var, Pos) - ) - -> - % In this case, the cell var is not being used to - % access field variables, so it should not incur - % the cell var cost. - cls_require_normal_var_in_reg(CountInfo, CellVar, - !CountState), - set__delete_list(InputArgs0, FieldVars, InputArgs) - ; - % The cell var cannot be used for the callee, so we - % must add the cost of constructing a new tuple. - TuplingParams = CountInfo ^ count_info_params, - CellVarStoreCost = float(TuplingParams ^ cell_var_store_cost), - !:CountState = (!.CountState ^ store_costs := - (!.CountState ^ store_costs + CellVarStoreCost)), - InputArgs = InputArgs0 - ), - set__to_sorted_list(InputArgs, Inputs), - goal_info_get_maybe_need_across_call(GoalInfo, MaybeNeedAcrossCall), - count_load_stores_for_call(CountInfo, Inputs, Outputs, - MaybeNeedAcrossCall, GoalInfo, !CountState). + CalleeTuplingProposal, !CountState) :- + Goal = call(CalleePredId, CalleeProcId, ArgVars, _, _, _), + CalleeTuplingProposal = tupling(CellVar, FieldVars, FieldVarArgPos), + ModuleInfo = CountInfo ^ count_info_module, + module_info_pred_proc_info(ModuleInfo, CalleePredId, CalleeProcId, + _, CalleeProcInfo), + CallingProcInfo = CountInfo ^ count_info_proc, + proc_info_vartypes(CallingProcInfo, VarTypes), + arg_info__partition_proc_call_args(CalleeProcInfo, VarTypes, + ModuleInfo, ArgVars, InputArgs0, Outputs, _), + ( + % If the caller is a tupled procedure, and every field variable + % of the tuple appears as an input argument to the callee AND + % every such argument is in a position matching the field variable's + % position in the tupling proposal, then the cell var of the caller + % can be reused as the call var for the callee. + % + % TODO: If we kept track of the aliases of field variables, + % then they could be checked also. + get_own_tupling_proposal(CountInfo) = tupling(_, _, _), + all [Var] Var `list.member` FieldVars => ( + Var `set.member` InputArgs0, + assoc_list__search(FieldVarArgPos, Var, Pos), + list__nth_member_search(ArgVars, Var, Pos) + ) + -> + % In this case, the cell var is not being used to access field + % variables, so it should not incur the cell var cost. + cls_require_normal_var_in_reg(CountInfo, CellVar, !CountState), + set__delete_list(InputArgs0, FieldVars, InputArgs) + ; + % The cell var cannot be used for the callee, so we must add + % the cost of constructing a new tuple. + TuplingParams = CountInfo ^ count_info_params, + CellVarStoreCost = float(TuplingParams ^ cell_var_store_cost), + !:CountState = (!.CountState ^ store_costs := + (!.CountState ^ store_costs + CellVarStoreCost)), + InputArgs = InputArgs0 + ), + set__to_sorted_list(InputArgs, Inputs), + goal_info_get_maybe_need_across_call(GoalInfo, MaybeNeedAcrossCall), + count_load_stores_for_call(CountInfo, Inputs, Outputs, + MaybeNeedAcrossCall, GoalInfo, !CountState). :- pred count_load_stores_in_call_to_not_tupled(hlds_goal::in_call_goal, - count_info::in, count_state::in, count_state::out) is det. + count_info::in, count_state::in, count_state::out) is det. count_load_stores_in_call_to_not_tupled(Goal - GoalInfo, CountInfo, - !CountState) :- - Goal = call(PredId, ProcId, ArgVars, Builtin, _, _), - ModuleInfo = CountInfo ^ count_info_module, - module_info_pred_proc_info(ModuleInfo, PredId, ProcId, - _PredInfo, CalleeProcInfo), - ProcInfo = CountInfo ^ count_info_proc, - proc_info_vartypes(ProcInfo, VarTypes), - arg_info__partition_proc_call_args(CalleeProcInfo, VarTypes, - ModuleInfo, ArgVars, InputArgs, Outputs, _), - set__to_sorted_list(InputArgs, Inputs), - ( Builtin = inline_builtin -> - cls_require_in_regs(CountInfo, Inputs, !CountState), - cls_put_in_regs(set__to_sorted_list(Outputs), !CountState) - ; - goal_info_get_maybe_need_across_call(GoalInfo, - MaybeNeedAcrossCall), - count_load_stores_for_call(CountInfo, Inputs, Outputs, - MaybeNeedAcrossCall, GoalInfo, !CountState) - ). + !CountState) :- + Goal = call(PredId, ProcId, ArgVars, Builtin, _, _), + ModuleInfo = CountInfo ^ count_info_module, + module_info_pred_proc_info(ModuleInfo, PredId, ProcId, + _PredInfo, CalleeProcInfo), + ProcInfo = CountInfo ^ count_info_proc, + proc_info_vartypes(ProcInfo, VarTypes), + arg_info__partition_proc_call_args(CalleeProcInfo, VarTypes, + ModuleInfo, ArgVars, InputArgs, Outputs, _), + set__to_sorted_list(InputArgs, Inputs), + ( Builtin = inline_builtin -> + cls_require_in_regs(CountInfo, Inputs, !CountState), + cls_put_in_regs(set__to_sorted_list(Outputs), !CountState) + ; + goal_info_get_maybe_need_across_call(GoalInfo, + MaybeNeedAcrossCall), + count_load_stores_for_call(CountInfo, Inputs, Outputs, + MaybeNeedAcrossCall, GoalInfo, !CountState) + ). :- pred count_load_stores_for_call(count_info::in, prog_vars::in, - set(prog_var)::in, maybe(need_across_call)::in, - hlds_goal_info::in, count_state::in, count_state::out) is det. + set(prog_var)::in, maybe(need_across_call)::in, + hlds_goal_info::in, count_state::in, count_state::out) is det. count_load_stores_for_call(CountInfo, Inputs, Outputs, MaybeNeedAcrossCall, - _GoalInfo, !CountState) :- - cls_require_in_regs(CountInfo, Inputs, !CountState), - ( - MaybeNeedAcrossCall = yes(NeedAcrossCall), - NeedAcrossCall = need_across_call(ForwardVars, - ResumeVars, NondetLiveVars), - AllVars = set__union_list([ForwardVars, ResumeVars, - NondetLiveVars]), - cls_require_flushed(CountInfo, AllVars, !CountState), - cls_clobber_regs(Outputs, !CountState) - ; - MaybeNeedAcrossCall = no, - unexpected(this_file, - "count_load_stores_for_call: no need across call") - ). + _GoalInfo, !CountState) :- + cls_require_in_regs(CountInfo, Inputs, !CountState), + ( + MaybeNeedAcrossCall = yes(NeedAcrossCall), + NeedAcrossCall = need_across_call(ForwardVars, + ResumeVars, NondetLiveVars), + AllVars = set__union_list([ForwardVars, ResumeVars, NondetLiveVars]), + cls_require_flushed(CountInfo, AllVars, !CountState), + cls_clobber_regs(Outputs, !CountState) + ; + MaybeNeedAcrossCall = no, + unexpected(this_file, + "count_load_stores_for_call: no need across call") + ). %-----------------------------------------------------------------------------% :- pred count_load_stores_in_conj(hlds_goals::in, count_info::in, - count_state::in, count_state::out) is det. + count_state::in, count_state::out) is det. count_load_stores_in_conj([], _CountInfo, !CountState). count_load_stores_in_conj([Goal | Goals], CountInfo, !CountState) :- - count_load_stores_in_goal(Goal, CountInfo, !CountState), - count_load_stores_in_conj(Goals, CountInfo, !CountState). + count_load_stores_in_goal(Goal, CountInfo, !CountState), + count_load_stores_in_conj(Goals, CountInfo, !CountState). :- pred count_load_stores_in_disj(hlds_goals::in, count_info::in, - count_state::in, count_state::out) is det. + count_state::in, count_state::out) is det. count_load_stores_in_disj([], _CountInfo, !CountState). count_load_stores_in_disj([Goal | Goals], CountInfo, !CountState) :- - GoalInfo = snd(Goal), - goal_info_get_resume_point(GoalInfo, ResumePoint), - ( - ResumePoint = resume_point(LiveVars, _ResumeLocs), - cls_require_flushed(CountInfo, LiveVars, !CountState) - ; - ResumePoint = no_resume_point - ), - reset_count_state_counts(!.CountState, BranchCountState0), - count_load_stores_in_goal(Goal, CountInfo, - BranchCountState0, BranchCountState), - ProcCounts = CountInfo ^ count_info_proc_counts, - goal_info_get_goal_path(GoalInfo, GoalPath), - get_disjunct_relative_frequency(ProcCounts, GoalPath, RelFreq), - add_branch_costs(BranchCountState, RelFreq, !CountState), - count_load_stores_in_disj(Goals, CountInfo, !CountState). + GoalInfo = snd(Goal), + goal_info_get_resume_point(GoalInfo, ResumePoint), + ( + ResumePoint = resume_point(LiveVars, _ResumeLocs), + cls_require_flushed(CountInfo, LiveVars, !CountState) + ; + ResumePoint = no_resume_point + ), + reset_count_state_counts(!.CountState, BranchCountState0), + count_load_stores_in_goal(Goal, CountInfo, + BranchCountState0, BranchCountState), + ProcCounts = CountInfo ^ count_info_proc_counts, + goal_info_get_goal_path(GoalInfo, GoalPath), + get_disjunct_relative_frequency(ProcCounts, GoalPath, RelFreq), + add_branch_costs(BranchCountState, RelFreq, !CountState), + count_load_stores_in_disj(Goals, CountInfo, !CountState). :- pred count_load_stores_in_cases(list(case)::in, count_info::in, - count_state::in, count_state::out) is det. + count_state::in, count_state::out) is det. count_load_stores_in_cases([], _CountInfo, !CountState). count_load_stores_in_cases([Case | Cases], CountInfo, !CountState) :- - Case = case(_ConsId, Goal), - GoalInfo = snd(Goal), - goal_info_get_resume_point(GoalInfo, ResumePoint), - ( - ResumePoint = resume_point(LiveVars, _ResumeLocs), - cls_require_flushed(CountInfo, LiveVars, !CountState) - ; - ResumePoint = no_resume_point - ), - reset_count_state_counts(!.CountState, BranchCountState0), - count_load_stores_in_goal(Goal, CountInfo, BranchCountState0, - BranchCountState), - ProcCounts = CountInfo ^ count_info_proc_counts, - goal_info_get_goal_path(GoalInfo, GoalPath), - get_case_relative_frequency(ProcCounts, GoalPath, RelFreq), - add_branch_costs(BranchCountState, RelFreq, !CountState), - count_load_stores_in_cases(Cases, CountInfo, !CountState). + Case = case(_ConsId, Goal), + GoalInfo = snd(Goal), + goal_info_get_resume_point(GoalInfo, ResumePoint), + ( + ResumePoint = resume_point(LiveVars, _ResumeLocs), + cls_require_flushed(CountInfo, LiveVars, !CountState) + ; + ResumePoint = no_resume_point + ), + reset_count_state_counts(!.CountState, BranchCountState0), + count_load_stores_in_goal(Goal, CountInfo, BranchCountState0, + BranchCountState), + ProcCounts = CountInfo ^ count_info_proc_counts, + goal_info_get_goal_path(GoalInfo, GoalPath), + get_case_relative_frequency(ProcCounts, GoalPath, RelFreq), + add_branch_costs(BranchCountState, RelFreq, !CountState), + count_load_stores_in_cases(Cases, CountInfo, !CountState). %-----------------------------------------------------------------------------% - % Make the values of the given variables available in registers. - % + % Make the values of the given variables available in registers. + % :- pred cls_require_in_regs(count_info::in, prog_vars::in, count_state::in, - count_state::out) is det. + count_state::out) is det. cls_require_in_regs(CountInfo, Vars, !CountState) :- - list__foldl(cls_require_in_reg(CountInfo), Vars, !CountState). + list__foldl(cls_require_in_reg(CountInfo), Vars, !CountState). :- pred cls_require_in_reg(count_info::in, prog_var::in, count_state::in, - count_state::out) is det. + count_state::out) is det. cls_require_in_reg(CountInfo, Var, !CountState) :- - ( - TuplingProposal = get_own_tupling_proposal(CountInfo), - TuplingProposal = tupling(_, FieldVars, _), - Var `list.member` FieldVars - -> - cls_require_field_var_in_reg(CountInfo, TuplingProposal, - Var, !CountState) - ; - cls_require_normal_var_in_reg(CountInfo, Var, !CountState) - ). + ( + TuplingProposal = get_own_tupling_proposal(CountInfo), + TuplingProposal = tupling(_, FieldVars, _), + Var `list.member` FieldVars + -> + cls_require_field_var_in_reg(CountInfo, TuplingProposal, + Var, !CountState) + ; + cls_require_normal_var_in_reg(CountInfo, Var, !CountState) + ). :- pred cls_require_normal_var_in_reg(count_info::in, prog_var::in, - count_state::in, count_state::out) is det. + count_state::in, count_state::out) is det. cls_require_normal_var_in_reg(CountInfo, Var, !CountState) :- - TuningParams = CountInfo ^ count_info_params, - NormalLoadCost = TuningParams ^ normal_var_load_cost, - cls_require_var_in_reg_with_cost(NormalLoadCost, Var, !CountState). + TuningParams = CountInfo ^ count_info_params, + NormalLoadCost = TuningParams ^ normal_var_load_cost, + cls_require_var_in_reg_with_cost(NormalLoadCost, Var, !CountState). :- pred cls_require_field_var_in_reg(count_info::in, - tupling_proposal::in(bound(tupling(ground, ground, ground))), - prog_var::in, count_state::in, count_state::out) is det. + tupling_proposal::in(bound(tupling(ground, ground, ground))), + prog_var::in, count_state::in, count_state::out) is det. cls_require_field_var_in_reg(CountInfo, TuplingProposal, FieldVar, - CountState0, CountState) :- - CountState0 = count_state(RegVars0, StackVars, Loads0, Stores), - ( FieldVar `set.member` RegVars0 -> - CountState = CountState0 - ; - TuplingProposal = tupling(CellVar, _, _), - TuningParams = CountInfo ^ count_info_params, - CvLoadCost = float(TuningParams ^ cell_var_load_cost), - FvLoadCost = float(TuningParams ^ field_var_load_cost), - ( CellVar `set.member` RegVars0 -> - RegVars = RegVars0 `insert` FieldVar, - Loads = Loads0 + FvLoadCost - ; - RegVars = RegVars0 `insert_list` [CellVar, FieldVar], - Loads = Loads0 + CvLoadCost + FvLoadCost - ), - CountState = count_state(RegVars, StackVars, Loads, Stores) - ). + CountState0, CountState) :- + CountState0 = count_state(RegVars0, StackVars, Loads0, Stores), + ( FieldVar `set.member` RegVars0 -> + CountState = CountState0 + ; + TuplingProposal = tupling(CellVar, _, _), + TuningParams = CountInfo ^ count_info_params, + CvLoadCost = float(TuningParams ^ cell_var_load_cost), + FvLoadCost = float(TuningParams ^ field_var_load_cost), + ( CellVar `set.member` RegVars0 -> + RegVars = RegVars0 `insert` FieldVar, + Loads = Loads0 + FvLoadCost + ; + RegVars = RegVars0 `insert_list` [CellVar, FieldVar], + Loads = Loads0 + CvLoadCost + FvLoadCost + ), + CountState = count_state(RegVars, StackVars, Loads, Stores) + ). :- pred cls_require_var_in_reg_with_cost(int::in, prog_var::in, - count_state::in, count_state::out) is det. + count_state::in, count_state::out) is det. cls_require_var_in_reg_with_cost(LoadCost, Var, CountState0, CountState) :- - CountState0 = count_state(RegVars0, StackVars, Loads0, Stores), - ( Var `set.member` RegVars0 -> - CountState = CountState0 - ; - RegVars = RegVars0 `insert` Var, - Loads = Loads0 + float(LoadCost), - CountState = count_state(RegVars, StackVars, Loads, Stores) - ). + CountState0 = count_state(RegVars0, StackVars, Loads0, Stores), + ( Var `set.member` RegVars0 -> + CountState = CountState0 + ; + RegVars = RegVars0 `insert` Var, + Loads = Loads0 + float(LoadCost), + CountState = count_state(RegVars, StackVars, Loads, Stores) + ). - % Put the values of the given variables into registers. - % + % Put the values of the given variables into registers. + % :- pred cls_put_in_regs(prog_vars::in, count_state::in, count_state::out) - is det. + is det. cls_put_in_regs(Vars, State0, State) :- - RegVars0 = (State0 ^ reg_vars), - State = (State0 ^ reg_vars := RegVars0 `insert_list` Vars). + RegVars0 = (State0 ^ reg_vars), + State = (State0 ^ reg_vars := RegVars0 `insert_list` Vars). :- pred cls_put_in_regs_via_deconstruct(count_info::in, prog_var::in, - prog_vars::in, count_state::in, count_state::out) is det. + prog_vars::in, count_state::in, count_state::out) is det. cls_put_in_regs_via_deconstruct(CountInfo, - DeconstructCellVar, DeconstructFieldVars, !State) :- - TuningParams = CountInfo ^ count_info_params, - CvLoadCost = TuningParams ^ cell_var_load_cost, - FvLoadCost = TuningParams ^ field_var_load_cost, - TuplingProposal = get_own_tupling_proposal(CountInfo), - ( - TuplingProposal = no_tupling, - cls_require_var_in_reg_with_cost(CvLoadCost, - DeconstructCellVar, !State), - list__foldl(cls_require_var_in_reg_with_cost(FvLoadCost), - DeconstructFieldVars, !State) - ; - TuplingProposal = tupling(_, TupleFieldVars, _), - VarsToLoad = set__difference( - set__from_list(DeconstructFieldVars), - set__from_list(TupleFieldVars)), - ( set__non_empty(VarsToLoad) -> - cls_require_var_in_reg_with_cost(CvLoadCost, - DeconstructCellVar, !State), - set__fold(cls_require_var_in_reg_with_cost(FvLoadCost), - VarsToLoad, !State) - ; - % All the variables generated by this deconstruction - % can be obtained from the proposed tupling, so the - % deconstruction can be ignored. The costs of loading - % those variables from the tuple will be counted as - % they come. - true - ) - ). + DeconstructCellVar, DeconstructFieldVars, !State) :- + TuningParams = CountInfo ^ count_info_params, + CvLoadCost = TuningParams ^ cell_var_load_cost, + FvLoadCost = TuningParams ^ field_var_load_cost, + TuplingProposal = get_own_tupling_proposal(CountInfo), + ( + TuplingProposal = no_tupling, + cls_require_var_in_reg_with_cost(CvLoadCost, + DeconstructCellVar, !State), + list__foldl(cls_require_var_in_reg_with_cost(FvLoadCost), + DeconstructFieldVars, !State) + ; + TuplingProposal = tupling(_, TupleFieldVars, _), + VarsToLoad = set__difference( + set__from_list(DeconstructFieldVars), + set__from_list(TupleFieldVars)), + ( set__non_empty(VarsToLoad) -> + cls_require_var_in_reg_with_cost(CvLoadCost, DeconstructCellVar, + !State), + set__fold(cls_require_var_in_reg_with_cost(FvLoadCost), VarsToLoad, + !State) + ; + % All the variables generated by this deconstruction can be + % obtained from the proposed tupling, so the deconstruction + % can be ignored. The costs of loading those variables from + % the tuple will be counted as they come. + true + ) + ). %-----------------------------------------------------------------------------% - % Copy the given variables to the stack, if they have not been copied - % previously. - % + % Copy the given variables to the stack, if they have not been copied + % previously. + % :- pred cls_require_flushed(count_info::in, set(prog_var)::in, - count_state::in, count_state::out) is det. + count_state::in, count_state::out) is det. cls_require_flushed(CountInfo, Vars, !CountState) :- - TuplingProposal = get_own_tupling_proposal(CountInfo), - TuningParams = CountInfo ^ count_info_params, - set__fold(cls_require_flushed_2(TuplingProposal, TuningParams), - Vars, !CountState). + TuplingProposal = get_own_tupling_proposal(CountInfo), + TuningParams = CountInfo ^ count_info_params, + set__fold(cls_require_flushed_2(TuplingProposal, TuningParams), + Vars, !CountState). :- pred cls_require_flushed_2(tupling_proposal::in, tuning_params::in, - prog_var::in, count_state::in, count_state::out) is det. + prog_var::in, count_state::in, count_state::out) is det. cls_require_flushed_2(no_tupling, TuningParams, Var, !CountState) :- - StoreCost = TuningParams ^ normal_var_store_cost, - cls_require_flushed_with_cost(StoreCost, Var, !CountState). + StoreCost = TuningParams ^ normal_var_store_cost, + cls_require_flushed_with_cost(StoreCost, Var, !CountState). cls_require_flushed_2(tupling(CellVar, FieldVars, _), TuningParams, Var, - !CountState) :- - ( Var `list.member` FieldVars -> - FvStoreCost = TuningParams ^ field_var_store_cost, - cls_require_flushed_with_cost(FvStoreCost, CellVar, - !CountState) - ; - StoreCost = TuningParams ^ normal_var_store_cost, - cls_require_flushed_with_cost(StoreCost, Var, !CountState) - ). + !CountState) :- + ( list.member(Var, FieldVars) -> + FvStoreCost = TuningParams ^ field_var_store_cost, + cls_require_flushed_with_cost(FvStoreCost, CellVar, !CountState) + ; + StoreCost = TuningParams ^ normal_var_store_cost, + cls_require_flushed_with_cost(StoreCost, Var, !CountState) + ). :- pred cls_require_flushed_with_cost(int::in, prog_var::in, count_state::in, - count_state::out) is det. + count_state::out) is det. cls_require_flushed_with_cost(StoreCost, Var, - count_state(RegVars, StackVars0, Loads, Stores0), - count_state(RegVars, StackVars, Loads, Stores)) :- - ( Var `set.member` StackVars0 -> - StackVars = StackVars0, - Stores = Stores0 - ; - StackVars = StackVars0 `insert` Var, - Stores = Stores0 + float(StoreCost) - ). + count_state(RegVars, StackVars0, Loads, Stores0), + count_state(RegVars, StackVars, Loads, Stores)) :- + ( set.member(Var, StackVars0) -> + StackVars = StackVars0, + Stores = Stores0 + ; + StackVars = StackVars0 `insert` Var, + Stores = Stores0 + float(StoreCost) + ). %-----------------------------------------------------------------------------% - % Clear out the contents of the registers and replace them with the - % values of the given variables. - % + % Clear out the contents of the registers and replace them with the + % values of the given variables. + % :- pred cls_clobber_regs(set(prog_var)::in, count_state::in, count_state::out) - is det. + is det. cls_clobber_regs(NewVars, CountState0, CountState0 ^ reg_vars := NewVars). @@ -1497,20 +1472,20 @@ cls_clobber_regs(NewVars, CountState0, CountState0 ^ reg_vars := NewVars). :- pred reset_count_state_counts(count_state::in, count_state::out) is det. -reset_count_state_counts(CountState0, CountState) :- - CountState = ((CountState0 - ^ load_costs := 0.0) - ^ store_costs := 0.0). +reset_count_state_counts(!CountState) :- + !:CountState = !.CountState ^ load_costs := 0.0, + !:CountState = !.CountState ^ store_costs := 0.0. :- pred add_branch_costs(count_state::in, float::in, - count_state::in, count_state::out) is det. + count_state::in, count_state::out) is det. -add_branch_costs(BranchState, Weight, CountState0, CountState) :- - BranchState = count_state(_, _, BranchLoads, BranchStores), - CountState0 = count_state(_, _, Loads0, Stores0), - CountState = ((CountState0 - ^ load_costs := Loads0 + Weight * BranchLoads) - ^ store_costs := Stores0 + Weight * BranchStores). +add_branch_costs(BranchState, Weight, !CountState) :- + BranchState = count_state(_, _, BranchLoads, BranchStores), + !.CountState = count_state(_, _, Loads0, Stores0), + !:CountState = !.CountState ^ load_costs + := Loads0 + Weight * BranchLoads, + !:CountState = !.CountState ^ store_costs + := Stores0 + Weight * BranchStores. %-----------------------------------------------------------------------------% % @@ -1518,342 +1493,332 @@ add_branch_costs(BranchState, Weight, CountState0, CountState) :- % :- pred build_interval_info(module_info::in, proc_info::in, interval_info::out) - is det. + is det. build_interval_info(ModuleInfo, ProcInfo, IntervalInfo) :- - proc_info_goal(ProcInfo, Goal), - proc_info_vartypes(ProcInfo, VarTypes), - arg_info__partition_proc_args(ProcInfo, ModuleInfo, - _InputArgs, OutputArgs, _UnusedArgs), - Counter0 = counter__init(1), - counter__allocate(CurInterval, Counter0, Counter), - CurIntervalId = interval_id(CurInterval), - EndMap = map__det_insert(map__init, CurIntervalId, proc_end), - StartMap = map__init, - SuccMap = map__det_insert(map__init, CurIntervalId, []), - VarsMap = map__det_insert(map__init, CurIntervalId, OutputArgs), - IntParams = interval_params(ModuleInfo, VarTypes, no), - IntervalInfo0 = interval_info(IntParams, set__init, - OutputArgs, map__init, map__init, map__init, - CurIntervalId, Counter, - set__make_singleton_set(CurIntervalId), - map__init, set__init, StartMap, EndMap, - SuccMap, VarsMap, map__init), - build_interval_info_in_goal(Goal, IntervalInfo0, IntervalInfo, - unit, _). + proc_info_goal(ProcInfo, Goal), + proc_info_vartypes(ProcInfo, VarTypes), + arg_info__partition_proc_args(ProcInfo, ModuleInfo, + _InputArgs, OutputArgs, _UnusedArgs), + Counter0 = counter__init(1), + counter__allocate(CurInterval, Counter0, Counter), + CurIntervalId = interval_id(CurInterval), + EndMap = map__det_insert(map__init, CurIntervalId, proc_end), + StartMap = map__init, + SuccMap = map__det_insert(map__init, CurIntervalId, []), + VarsMap = map__det_insert(map__init, CurIntervalId, OutputArgs), + IntParams = interval_params(ModuleInfo, VarTypes, no), + IntervalInfo0 = interval_info(IntParams, set__init, + OutputArgs, map__init, map__init, map__init, + CurIntervalId, Counter, + set__make_singleton_set(CurIntervalId), + map__init, set__init, StartMap, EndMap, + SuccMap, VarsMap, map__init), + build_interval_info_in_goal(Goal, IntervalInfo0, IntervalInfo, unit, _). - % This is needed only to satisfy the interface of interval.m - % + % This is needed only to satisfy the interface of interval.m + % :- instance build_interval_info_acc(unit) where [ - pred(use_cell/8) is tupling__use_cell + pred(use_cell/8) is tupling__use_cell ]. :- pred use_cell(prog_var::in, list(prog_var)::in, cons_id::in, hlds_goal::in, - interval_info::in, interval_info::out, unit::in, unit::out) is det. + interval_info::in, interval_info::out, unit::in, unit::out) is det. use_cell(_CellVar, _FieldVarList, _ConsId, _Goal, !IntervalInfo, !Unit). %-----------------------------------------------------------------------------% - % This predicate uses the interval information built previously to - % build an insertion map, i.e. a mapping from a left anchor to a - % deconstruction unification that is to be inserted _after_ the - % interval beginning with that left anchor. - % + % This predicate uses the interval information built previously to + % build an insertion map, i.e. a mapping from a left anchor to a + % deconstruction unification that is to be inserted _after_ the + % interval beginning with that left anchor. + % :- pred build_insert_map(prog_var::in, prog_vars::in, interval_info::in, - insert_map::out) is det. + insert_map::out) is det. build_insert_map(CellVar, FieldVars, IntervalInfo, InsertMap) :- - FieldVarsSet = set__from_list(FieldVars), - map__foldl(build_insert_map_2(CellVar, FieldVars, FieldVarsSet), - IntervalInfo ^ anchor_follow_map, - map__init, InsertMap). + FieldVarsSet = set__from_list(FieldVars), + map__foldl(build_insert_map_2(CellVar, FieldVars, FieldVarsSet), + IntervalInfo ^ anchor_follow_map, map__init, InsertMap). :- pred build_insert_map_2(prog_var::in, list(prog_var)::in, set(prog_var)::in, - anchor::in, anchor_follow_info::in, insert_map::in, insert_map::out) - is det. + anchor::in, anchor_follow_info::in, insert_map::in, insert_map::out) + is det. -build_insert_map_2(CellVar, FieldVars, FieldVarsSet, - Anchor, FollowVars - _, !InsertMap) :- - NeededFieldVars = FieldVarsSet `set__intersect` FollowVars, - ( set__empty(NeededFieldVars) -> - true - ; - deconstruct_tuple(CellVar, FieldVars, Goal), - InsertSpec = insert_spec(Goal, NeededFieldVars), - add_insert_spec(Anchor, InsertSpec, !InsertMap) - ). +build_insert_map_2(CellVar, FieldVars, FieldVarsSet, Anchor, FollowVars - _, + !InsertMap) :- + NeededFieldVars = FieldVarsSet `set__intersect` FollowVars, + ( set__empty(NeededFieldVars) -> + true + ; + deconstruct_tuple(CellVar, FieldVars, Goal), + InsertSpec = insert_spec(Goal, NeededFieldVars), + add_insert_spec(Anchor, InsertSpec, !InsertMap) + ). :- pred add_insert_spec(anchor::in, insert_spec::in, insert_map::in, - insert_map::out) is det. + insert_map::out) is det. add_insert_spec(Anchor, InsertSpec, !InsertMap) :- - ( map__search(!.InsertMap, Anchor, InsertSpecs0) -> - combine_inserts(InsertSpec, InsertSpecs0, InsertSpecs), - svmap__det_update(Anchor, InsertSpecs, !InsertMap) - ; - svmap__det_insert(Anchor, [InsertSpec], !InsertMap) - ). + ( map__search(!.InsertMap, Anchor, InsertSpecs0) -> + combine_inserts(InsertSpec, InsertSpecs0, InsertSpecs), + svmap__det_update(Anchor, InsertSpecs, !InsertMap) + ; + svmap__det_insert(Anchor, [InsertSpec], !InsertMap) + ). :- pred combine_inserts(insert_spec::in, list(insert_spec)::in, - list(insert_spec)::out) is det. + list(insert_spec)::out) is det. combine_inserts(A, [], [A]). combine_inserts(A, [B | Bs], [C | Cs]) :- - ( - A = insert_spec(Goal, ASet), - B = insert_spec(Goal, BSet) - -> - C = insert_spec(Goal, ASet `set__union` BSet), - Cs = Bs - ; - C = B, - combine_inserts(A, Bs, Cs) - ). + ( + A = insert_spec(Goal, ASet), + B = insert_spec(Goal, BSet) + -> + C = insert_spec(Goal, ASet `set__union` BSet), + Cs = Bs + ; + C = B, + combine_inserts(A, Bs, Cs) + ). %-----------------------------------------------------------------------------% % % Fixing calls to transformed procedures. % - % The transform_map structure records which procedures were - % transformed into what procedures. - % + % The transform_map structure records which procedures were + % transformed into what procedures. + % :- type transform_map == map(pred_proc_id, transformed_proc). -:- type transformed_proc ---> - transformed_proc( - transformed_pred_proc_id :: pred_proc_id, - % The pred_proc_id of the transformed version of - % the procedure. - tuple_cons_type :: (type), - % The type of the cell variable created by the - % transformation. This will be a tuple type. - args_to_tuple :: list(int), - % The argument positions of the original procedure - % which were tupled. - call_template :: hlds_goal - % A template for a call goal that is used to update - % calls of the original procedure to the transformed - % procedure instead. The arguments of the template - % need to be replaced by the actual arguments. - ). +:- type transformed_proc + ---> transformed_proc( + % The pred_proc_id of the transformed version of the procedure. + transformed_pred_proc_id :: pred_proc_id, + + % The type of the cell variable created by the transformation. + % This will be a tuple type. + tuple_cons_type :: (type), + + % The argument positions of the original procedure + % which were tupled. + args_to_tuple :: list(int), + + % A template for a call goal that is used to update calls + % of the original procedure to the transformed procedure + % instead. The arguments of the template need to be replaced + % by the actual arguments. + call_template :: hlds_goal + ). :- pred fix_calls_in_procs(transform_map::in, list(pred_proc_id)::in, - module_info::in, module_info::out) is det. + module_info::in, module_info::out) is det. fix_calls_in_procs(TransformMap, PredProcIds, !ModuleInfo) :- - list__foldl(fix_calls_in_proc(TransformMap), - PredProcIds, !ModuleInfo). + list__foldl(fix_calls_in_proc(TransformMap), PredProcIds, !ModuleInfo). :- pred fix_calls_in_transformed_procs(transform_map::in, - module_info::in, module_info::out) is det. + module_info::in, module_info::out) is det. fix_calls_in_transformed_procs(TransformMap, !ModuleInfo) :- - map__foldl(fix_calls_in_transformed_procs_2(TransformMap), - TransformMap, !ModuleInfo). + map__foldl(fix_calls_in_transformed_procs_2(TransformMap), TransformMap, + !ModuleInfo). :- pred fix_calls_in_transformed_procs_2(transform_map::in, pred_proc_id::in, - transformed_proc::in, module_info::in, module_info::out) is det. + transformed_proc::in, module_info::in, module_info::out) is det. fix_calls_in_transformed_procs_2(TransformMap, - _, transformed_proc(PredProcId, _, _, _), !ModuleInfo) :- - fix_calls_in_proc(TransformMap, PredProcId, !ModuleInfo). + _, transformed_proc(PredProcId, _, _, _), !ModuleInfo) :- + fix_calls_in_proc(TransformMap, PredProcId, !ModuleInfo). :- pred fix_calls_in_proc(transform_map::in, pred_proc_id::in, - module_info::in, module_info::out) is det. + module_info::in, module_info::out) is det. fix_calls_in_proc(TransformMap, proc(PredId, ProcId), !ModuleInfo) :- - some [!ProcInfo] ( - module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId, - PredInfo, !:ProcInfo), - % XXX: Don't modify predicates that were created by type - % specialisation. This is a last-minute workaround for some - % linking problems that occurred when such predicates in the - % library were made to call tupled procedures. - pred_info_get_origin(PredInfo, Origin), - ( Origin = transformed(type_specialization(_), _, _) -> - true - ; - proc_info_goal(!.ProcInfo, Goal0), - proc_info_vartypes(!.ProcInfo, VarTypes0), - proc_info_varset(!.ProcInfo, VarSet0), - fix_calls_in_goal(Goal0, Goal, VarSet0, VarSet, - VarTypes0, VarTypes, TransformMap), - proc_info_set_goal(Goal, !ProcInfo), - proc_info_set_varset(VarSet, !ProcInfo), - proc_info_set_vartypes(VarTypes, !ProcInfo), - requantify_proc(!ProcInfo), - recompute_instmap_delta_proc(yes, !ProcInfo, - !ModuleInfo), - module_info_set_pred_proc_info(PredId, ProcId, - PredInfo, !.ProcInfo, !ModuleInfo) - ) - ). + some [!ProcInfo] ( + module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId, + PredInfo, !:ProcInfo), + % XXX: Don't modify predicates that were created by type + % specialisation. This is a last-minute workaround for some + % linking problems that occurred when such predicates in the + % library were made to call tupled procedures. + pred_info_get_origin(PredInfo, Origin), + ( Origin = transformed(type_specialization(_), _, _) -> + true + ; + proc_info_goal(!.ProcInfo, Goal0), + proc_info_vartypes(!.ProcInfo, VarTypes0), + proc_info_varset(!.ProcInfo, VarSet0), + fix_calls_in_goal(Goal0, Goal, VarSet0, VarSet, + VarTypes0, VarTypes, TransformMap), + proc_info_set_goal(Goal, !ProcInfo), + proc_info_set_varset(VarSet, !ProcInfo), + proc_info_set_vartypes(VarTypes, !ProcInfo), + requantify_proc(!ProcInfo), + recompute_instmap_delta_proc(yes, !ProcInfo, !ModuleInfo), + module_info_set_pred_proc_info(PredId, ProcId, + PredInfo, !.ProcInfo, !ModuleInfo) + ) + ). %-----------------------------------------------------------------------------% :- pred fix_calls_in_goal(hlds_goal::in, hlds_goal::out, prog_varset::in, - prog_varset::out, vartypes::in, vartypes::out, transform_map::in) - is det. + prog_varset::out, vartypes::in, vartypes::out, transform_map::in) + is det. fix_calls_in_goal(Goal - GoalInfo, Goal - GoalInfo, !_, !_, _TransformMap) :- - Goal = foreign_proc(_, _, _, _, _, _). + Goal = foreign_proc(_, _, _, _, _, _). fix_calls_in_goal(Goal - GoalInfo, Goal - GoalInfo, !_, !_, _TransformMap) :- - Goal = generic_call(_, _, _, _). + Goal = generic_call(_, _, _, _). fix_calls_in_goal(Goal0 - GoalInfo0, Goal, !VarSet, !VarTypes, TransformMap) :- - Goal0 = call(CalledPredId0, CalledProcId0, Args0, Builtin, - _Context, _SymName), - ( - Builtin = not_builtin, - map__search(TransformMap, proc(CalledPredId0, CalledProcId0), - transformed_proc(_, - TupleConsType, - ArgsToTuple, - CallAux0 - CallAuxInfo)) - -> - svvarset__new_named_var("TuplingCellVarForCall", CellVar, - !VarSet), - svmap__det_insert(CellVar, TupleConsType, !VarTypes), - extract_tupled_args_from_list(Args0, ArgsToTuple, - TupledArgs, UntupledArgs), - construct_tuple(CellVar, TupledArgs, ConstructGoal), - ( - NewArgs = UntupledArgs ++ [CellVar], - CallAux = CallAux0 ^ call_args := NewArgs - -> - CallGoal = CallAux - CallAuxInfo - ; - unexpected(this_file, - "fix_calls_in_goal: not a call template") - ), - conj_list_to_goal([ConstructGoal, CallGoal], GoalInfo0, Goal1), - RequantifyVars = set__from_list([CellVar | Args0]), - implicitly_quantify_goal(RequantifyVars, _, Goal1, Goal, - !VarSet, !VarTypes) - ; - Goal = Goal0 - GoalInfo0 - ). + Goal0 = call(CalledPredId0, CalledProcId0, Args0, Builtin, + _Context, _SymName), + ( + Builtin = not_builtin, + map__search(TransformMap, proc(CalledPredId0, CalledProcId0), + TransformedProc), + TransformedProc = transformed_proc(_, TupleConsType, ArgsToTuple, + CallAux0 - CallAuxInfo) + -> + svvarset__new_named_var("TuplingCellVarForCall", CellVar, !VarSet), + svmap__det_insert(CellVar, TupleConsType, !VarTypes), + extract_tupled_args_from_list(Args0, ArgsToTuple, + TupledArgs, UntupledArgs), + construct_tuple(CellVar, TupledArgs, ConstructGoal), + ( + NewArgs = UntupledArgs ++ [CellVar], + CallAux = CallAux0 ^ call_args := NewArgs + -> + CallGoal = CallAux - CallAuxInfo + ; + unexpected(this_file, "fix_calls_in_goal: not a call template") + ), + conj_list_to_goal([ConstructGoal, CallGoal], GoalInfo0, Goal1), + RequantifyVars = set__from_list([CellVar | Args0]), + implicitly_quantify_goal(RequantifyVars, _, Goal1, Goal, + !VarSet, !VarTypes) + ; + Goal = Goal0 - GoalInfo0 + ). fix_calls_in_goal(Goal - GoalInfo, Goal - GoalInfo, !_, !_, _TransformMap) :- - Goal = unify(_, _, _, _, _). + Goal = unify(_, _, _, _, _). fix_calls_in_goal(not(Goal0) - GoalInfo, not(Goal) - GoalInfo, - !VarSet, !VarTypes, TransformMap) :- - fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap). + !VarSet, !VarTypes, TransformMap) :- + fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap). fix_calls_in_goal(scope(Reason, Goal0) - GoalInfo, - scope(Reason, Goal) - GoalInfo, - !VarSet, !VarTypes, TransformMap) :- - fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap). + scope(Reason, Goal) - GoalInfo, + !VarSet, !VarTypes, TransformMap) :- + fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap). fix_calls_in_goal(conj(Goals0) - GoalInfo, conj(Goals) - GoalInfo, - !VarSet, !VarTypes, TransformMap) :- - fix_calls_in_conj(Goals0, Goals, !VarSet, !VarTypes, TransformMap). + !VarSet, !VarTypes, TransformMap) :- + fix_calls_in_conj(Goals0, Goals, !VarSet, !VarTypes, TransformMap). fix_calls_in_goal(par_conj(Goals0) - GoalInfo, par_conj(Goals) - GoalInfo, - !VarSet, !VarTypes, TransformMap) :- - % XXX: I am not sure whether parallel conjunctions should be treated - % with fix_calls_in_goal or fix_calls_in_goal_list. At any rate, - % this is untested. - fix_calls_in_goal_list(Goals0, Goals, !VarSet, !VarTypes, - TransformMap). + !VarSet, !VarTypes, TransformMap) :- + % XXX: I am not sure whether parallel conjunctions should be treated + % with fix_calls_in_goal or fix_calls_in_goal_list. At any rate, + % this is untested. + fix_calls_in_goal_list(Goals0, Goals, !VarSet, !VarTypes, TransformMap). fix_calls_in_goal(disj(Goals0) - GoalInfo, disj(Goals) - GoalInfo, - !VarSet, !VarTypes, TransformMap) :- - fix_calls_in_goal_list(Goals0, Goals, !VarSet, !VarTypes, - TransformMap). + !VarSet, !VarTypes, TransformMap) :- + fix_calls_in_goal_list(Goals0, Goals, !VarSet, !VarTypes, TransformMap). fix_calls_in_goal(switch(Var, CanFail, Cases0) - GoalInfo, - switch(Var, CanFail, Cases) - GoalInfo, - !VarSet, !VarTypes, TransformMap) :- - fix_calls_in_cases(Cases0, Cases, !VarSet, !VarTypes, TransformMap). + switch(Var, CanFail, Cases) - GoalInfo, + !VarSet, !VarTypes, TransformMap) :- + fix_calls_in_cases(Cases0, Cases, !VarSet, !VarTypes, TransformMap). fix_calls_in_goal(if_then_else(Vars, Cond0, Then0, Else0) - GoalInfo, - if_then_else(Vars, Cond, Then, Else) - GoalInfo, - !VarSet, !VarTypes, TransformMap) :- - fix_calls_in_goal(Cond0, Cond, !VarSet, !VarTypes, TransformMap), - fix_calls_in_goal(Then0, Then, !VarSet, !VarTypes, TransformMap), - fix_calls_in_goal(Else0, Else, !VarSet, !VarTypes, TransformMap). + if_then_else(Vars, Cond, Then, Else) - GoalInfo, + !VarSet, !VarTypes, TransformMap) :- + fix_calls_in_goal(Cond0, Cond, !VarSet, !VarTypes, TransformMap), + fix_calls_in_goal(Then0, Then, !VarSet, !VarTypes, TransformMap), + fix_calls_in_goal(Else0, Else, !VarSet, !VarTypes, TransformMap). fix_calls_in_goal(shorthand(_) - _, _, !VarSet, !VarTypes, _TransformMap) :- - unexpected(this_file, "fix_calls_in_goal: unexpected shorthand"). + unexpected(this_file, "fix_calls_in_goal: unexpected shorthand"). %-----------------------------------------------------------------------------% :- pred fix_calls_in_conj(hlds_goals::in, hlds_goals::out, - prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, - transform_map::in) is det. + prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, + transform_map::in) is det. fix_calls_in_conj([], [], !VarSet, !VarTypes, _). fix_calls_in_conj([Goal0 | Goals0], Goals, !VarSet, !VarTypes, TransformMap) :- - fix_calls_in_goal(Goal0, Goal1, !VarSet, !VarTypes, TransformMap), - fix_calls_in_conj(Goals0, Goals1, !VarSet, !VarTypes, TransformMap), - (if Goal1 = conj(ConjGoals) - _ then - Goals = ConjGoals ++ Goals1 - else - Goals = [Goal1 | Goals1] - ). + fix_calls_in_goal(Goal0, Goal1, !VarSet, !VarTypes, TransformMap), + fix_calls_in_conj(Goals0, Goals1, !VarSet, !VarTypes, TransformMap), + ( Goal1 = conj(ConjGoals) - _ -> + Goals = ConjGoals ++ Goals1 + ; + Goals = [Goal1 | Goals1] + ). :- pred fix_calls_in_goal_list(hlds_goals::in, hlds_goals::out, - prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, - transform_map::in) is det. + prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, + transform_map::in) is det. fix_calls_in_goal_list([], [], !VarSet, !VarTypes, _TransformMap). fix_calls_in_goal_list([Goal0 | Goals0], [Goal | Goals], !VarSet, !VarTypes, - TransformMap) :- - fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap), - fix_calls_in_goal_list(Goals0, Goals, !VarSet, !VarTypes, - TransformMap). + TransformMap) :- + fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap), + fix_calls_in_goal_list(Goals0, Goals, !VarSet, !VarTypes, TransformMap). :- pred fix_calls_in_cases(list(case)::in, list(case)::out, - prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, - transform_map::in) is det. + prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, + transform_map::in) is det. fix_calls_in_cases([], [], !VarSet, !VarTypes, _TransformMap). fix_calls_in_cases([Case0 | Cases0], [Case | Cases], !VarSet, !VarTypes, - TransformMap) :- - Case0 = case(Functor, Goal0), - fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap), - Case = case(Functor, Goal), - fix_calls_in_cases(Cases0, Cases, !VarSet, !VarTypes, TransformMap). + TransformMap) :- + Case0 = case(Functor, Goal0), + fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap), + Case = case(Functor, Goal), + fix_calls_in_cases(Cases0, Cases, !VarSet, !VarTypes, TransformMap). %-----------------------------------------------------------------------------% - % extract_tupled_args_from_list(ArgList, Indices, - % Selected, NotSelected) - % - % Pick out the elements of ArgList by the indices given and put them - % in the list Selected, in exactly the order that they are referenced - % in Indices. The list NotSelected is to contain all the elements - % of ArgList which did not end up in Selected, in the order that they - % appeared in ArgList. - % - % Note again that the ordering of Selected and NotSelected are - % determined by different lists! - % + % extract_tupled_args_from_list(ArgList, Indices, + % Selected, NotSelected) + % + % Pick out the elements of ArgList by the indices given and put them + % in the list Selected, in exactly the order that they are referenced + % in Indices. The list NotSelected is to contain all the elements + % of ArgList which did not end up in Selected, in the order that they + % appeared in ArgList. + % + % Note again that the ordering of Selected and NotSelected are + % determined by different lists! + % :- pred extract_tupled_args_from_list(prog_vars::in, list(int)::in, - prog_vars::out, prog_vars::out) is det. + prog_vars::out, prog_vars::out) is det. extract_tupled_args_from_list(ArgList, Indices, Selected, NotSelected) :- - list__map(list__index1_det(ArgList), Indices, Selected), - extract_tupled_args_from_list_2(ArgList, 1, Indices, NotSelected). + list__map(list__index1_det(ArgList), Indices, Selected), + extract_tupled_args_from_list_2(ArgList, 1, Indices, NotSelected). :- pred extract_tupled_args_from_list_2(prog_vars::in, int::in, list(int)::in, - prog_vars::out) is det. + prog_vars::out) is det. extract_tupled_args_from_list_2([], _Num, _Indices, []). extract_tupled_args_from_list_2([H | T], Num, Indices, NotSelected) :- - ( Num `list.member` Indices -> - extract_tupled_args_from_list_2(T, Num+1, Indices, - NotSelected) - ; - NotSelected = [H | NotSelected1], - extract_tupled_args_from_list_2(T, Num+1, Indices, - NotSelected1) - ). + ( list.member(Num, Indices) -> + extract_tupled_args_from_list_2(T, Num+1, Indices, NotSelected) + ; + extract_tupled_args_from_list_2(T, Num+1, Indices, NotSelectedTail), + NotSelected = [H | NotSelectedTail] + ). %-----------------------------------------------------------------------------% % @@ -1861,113 +1826,113 @@ extract_tupled_args_from_list_2([H | T], Num, Indices, NotSelected) :- % :- type mdbcomp_goal_path_step - == mdbcomp__program_representation__goal_path_step. + == mdbcomp__program_representation__goal_path_step. :- type mdbcomp_goal_path - == mdbcomp__program_representation__goal_path. + == mdbcomp__program_representation__goal_path. :- pred get_proc_counts(trace_counts::in, proc_label_and_filename::in, - maybe(proc_trace_counts)::out) is det. + maybe(proc_trace_counts)::out) is det. get_proc_counts(TraceCounts, ProcLabelAndFile, MaybeProcCounts) :- - ( map__search(TraceCounts, ProcLabelAndFile, ProcCounts) -> - MaybeProcCounts = yes(ProcCounts) - ; - MaybeProcCounts = no - ). + ( map__search(TraceCounts, ProcLabelAndFile, ProcCounts) -> + MaybeProcCounts = yes(ProcCounts) + ; + MaybeProcCounts = no + ). :- pred get_proc_calls(proc_trace_counts::in, int::out) is det. get_proc_calls(ProcCounts, Count) :- - map__lookup(ProcCounts, port_only(call), ContextCount), - Count = ContextCount ^ exec_count. + map__lookup(ProcCounts, port_only(call), ContextCount), + Count = ContextCount ^ exec_count. :- pred get_path_only_count(proc_trace_counts::in, mdbcomp_goal_path::in, - int::out) is det. + int::out) is det. get_path_only_count(ProcCounts, GoalPath, Count) :- - PathPort = path_only(GoalPath), - ( map__search(ProcCounts, PathPort, ContextCount) -> - Count = ContextCount ^ exec_count - ; - Count = 0 - ). + PathPort = path_only(GoalPath), + ( map__search(ProcCounts, PathPort, ContextCount) -> + Count = ContextCount ^ exec_count + ; + Count = 0 + ). :- pred get_ite_relative_frequencies(proc_trace_counts::in, - goal_path::in, goal_path::in, float::out, float::out) is det. + goal_path::in, goal_path::in, float::out, float::out) is det. get_ite_relative_frequencies(ProcCounts, ThenGoalPath, ElseGoalPath, - ThenRelFreq, ElseRelFreq) :- - goal_path_to_mdbcomp_goal_path(ThenGoalPath, MdbThenGoalPath), - goal_path_to_mdbcomp_goal_path(ElseGoalPath, MdbElseGoalPath), - get_path_only_count(ProcCounts, MdbThenGoalPath, ThenCounts), - get_path_only_count(ProcCounts, MdbElseGoalPath, ElseCounts), - Total = ThenCounts + ElseCounts, - ( Total > 0 -> - ThenRelFreq = float(ThenCounts) / float(Total), - ElseRelFreq = float(ElseCounts) / float(Total) - ; - ThenRelFreq = 0.5, - ElseRelFreq = 0.5 - ). + ThenRelFreq, ElseRelFreq) :- + goal_path_to_mdbcomp_goal_path(ThenGoalPath, MdbThenGoalPath), + goal_path_to_mdbcomp_goal_path(ElseGoalPath, MdbElseGoalPath), + get_path_only_count(ProcCounts, MdbThenGoalPath, ThenCounts), + get_path_only_count(ProcCounts, MdbElseGoalPath, ElseCounts), + Total = ThenCounts + ElseCounts, + ( Total > 0 -> + ThenRelFreq = float(ThenCounts) / float(Total), + ElseRelFreq = float(ElseCounts) / float(Total) + ; + ThenRelFreq = 0.5, + ElseRelFreq = 0.5 + ). :- pred get_disjunct_relative_frequency(proc_trace_counts::in, goal_path::in, - float::out) is det. + float::out) is det. get_disjunct_relative_frequency(ProcCounts, GoalPath, RelFreq) :- - ( GoalPath = [disj(Num) | GoalPathRest] -> - goal_path_to_mdbcomp_goal_path(GoalPathRest, MdbGoalPathRest), - get_path_only_count(ProcCounts, - [mdbcomp__program_representation__disj(Num) | - MdbGoalPathRest], DisjCount), - get_path_only_count(ProcCounts, - [mdbcomp__program_representation__disj(1) | - MdbGoalPathRest], FirstDisjCount), - ( FirstDisjCount = 0 -> - RelFreq = 0.0 - ; - RelFreq = float(DisjCount) / float(FirstDisjCount) - ) - ; - unexpected(this_file, - "get_disjunct_relative_frequency/3 " ++ - "did not see disj(N) at head of goal path") - ). + ( GoalPath = [disj(Num) | GoalPathRest] -> + goal_path_to_mdbcomp_goal_path(GoalPathRest, MdbGoalPathRest), + get_path_only_count(ProcCounts, + [mdbcomp__program_representation__disj(Num) | + MdbGoalPathRest], DisjCount), + get_path_only_count(ProcCounts, + [mdbcomp__program_representation__disj(1) | + MdbGoalPathRest], FirstDisjCount), + ( FirstDisjCount = 0 -> + RelFreq = 0.0 + ; + RelFreq = float(DisjCount) / float(FirstDisjCount) + ) + ; + unexpected(this_file, + "get_disjunct_relative_frequency/3 " ++ + "did not see disj(N) at head of goal path") + ). :- pred get_case_relative_frequency(proc_trace_counts::in, goal_path::in, - float::out) is det. + float::out) is det. get_case_relative_frequency(ProcCounts, GoalPath, RelFreq) :- - goal_path_to_mdbcomp_goal_path(GoalPath, MdbGoalPath), - get_path_only_count(ProcCounts, MdbGoalPath, CaseTotal), - get_switch_total_count(ProcCounts, MdbGoalPath, SwitchTotal), - ( SwitchTotal = 0 -> - RelFreq = 0.0 - ; - RelFreq = float(CaseTotal) / float(SwitchTotal) - ). + goal_path_to_mdbcomp_goal_path(GoalPath, MdbGoalPath), + get_path_only_count(ProcCounts, MdbGoalPath, CaseTotal), + get_switch_total_count(ProcCounts, MdbGoalPath, SwitchTotal), + ( SwitchTotal = 0 -> + RelFreq = 0.0 + ; + RelFreq = float(CaseTotal) / float(SwitchTotal) + ). :- pred get_switch_total_count(proc_trace_counts::in, mdbcomp_goal_path::in, - int::out) is det. + int::out) is det. get_switch_total_count(ProcCounts, MdbGoalPath, Total) :- - map__foldl(get_switch_total_count_2(MdbGoalPath), - ProcCounts, 0, Total). + map__foldl(get_switch_total_count_2(MdbGoalPath), + ProcCounts, 0, Total). :- pred get_switch_total_count_2(mdbcomp_goal_path::in, path_port::in, - line_no_and_count::in, int::in, int::out) is det. + line_no_and_count::in, int::in, int::out) is det. get_switch_total_count_2(SwitchGoalPath, PathPort, LineNoAndCount, - !TotalAcc) :- - ( case_in_switch(SwitchGoalPath, PathPort) -> - !:TotalAcc = !.TotalAcc + LineNoAndCount ^ exec_count - ; - true - ). + !TotalAcc) :- + ( case_in_switch(SwitchGoalPath, PathPort) -> + !:TotalAcc = !.TotalAcc + LineNoAndCount ^ exec_count + ; + true + ). :- pred case_in_switch(mdbcomp_goal_path::in, path_port::in) is semidet. case_in_switch([mdbcomp.program_representation.switch(_) | Prefix], - path_only([mdbcomp.program_representation.switch(_) | Prefix])). + path_only([mdbcomp.program_representation.switch(_) | Prefix])). %-----------------------------------------------------------------------------% @@ -1976,39 +1941,39 @@ case_in_switch([mdbcomp.program_representation.switch(_) | Prefix], % has switch/1 instead of switch/2. :- pred goal_path_to_mdbcomp_goal_path(goal_path::in, mdbcomp_goal_path::out) - is det. + is det. goal_path_to_mdbcomp_goal_path(GoalPath, MdbGoalPath) :- - list__map(goal_path_step_to_mdbcomp_goal_path_step, - GoalPath, MdbGoalPath). + list__map(goal_path_step_to_mdbcomp_goal_path_step, + GoalPath, MdbGoalPath). :- pred goal_path_step_to_mdbcomp_goal_path_step(goal_path_step::in, - mdbcomp_goal_path_step::out) is det. + mdbcomp_goal_path_step::out) is det. goal_path_step_to_mdbcomp_goal_path_step( - conj(N), mdbcomp.program_representation.conj(N)). + conj(N), mdbcomp.program_representation.conj(N)). goal_path_step_to_mdbcomp_goal_path_step( - disj(N), mdbcomp.program_representation.disj(N)). + disj(N), mdbcomp.program_representation.disj(N)). goal_path_step_to_mdbcomp_goal_path_step( - switch(N, _), mdbcomp.program_representation.switch(N)). + switch(N, _), mdbcomp.program_representation.switch(N)). goal_path_step_to_mdbcomp_goal_path_step( - ite_cond, mdbcomp.program_representation.ite_cond). + ite_cond, mdbcomp.program_representation.ite_cond). goal_path_step_to_mdbcomp_goal_path_step( - ite_then, mdbcomp.program_representation.ite_then). + ite_then, mdbcomp.program_representation.ite_then). goal_path_step_to_mdbcomp_goal_path_step( - ite_else, mdbcomp.program_representation.ite_else). + ite_else, mdbcomp.program_representation.ite_else). goal_path_step_to_mdbcomp_goal_path_step( - neg, mdbcomp.program_representation.neg). + neg, mdbcomp.program_representation.neg). goal_path_step_to_mdbcomp_goal_path_step( - scope(cut), mdbcomp.program_representation.scope( - mdbcomp.program_representation.cut)). + scope(cut), mdbcomp.program_representation.scope( + mdbcomp.program_representation.cut)). goal_path_step_to_mdbcomp_goal_path_step( - scope(no_cut), mdbcomp.program_representation.scope( - mdbcomp.program_representation.no_cut)). + scope(no_cut), mdbcomp.program_representation.scope( + mdbcomp.program_representation.no_cut)). goal_path_step_to_mdbcomp_goal_path_step( - first, mdbcomp.program_representation.first). + first, mdbcomp.program_representation.first). goal_path_step_to_mdbcomp_goal_path_step( - later, mdbcomp.program_representation.later). + later, mdbcomp.program_representation.later). %-----------------------------------------------------------------------------% diff --git a/compiler/type_class_info.m b/compiler/type_class_info.m index e972038aa..102f91d65 100644 --- a/compiler/type_class_info.m +++ b/compiler/type_class_info.m @@ -1,4 +1,6 @@ %---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% % Copyright (C) 2003-2005 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. @@ -28,7 +30,7 @@ :- import_module list. :- pred type_class_info__generate_rtti(module_info::in, bool::in, - list(rtti_data)::out) is det. + list(rtti_data)::out) is det. :- func generate_class_constraint(prog_constraint) = tc_constraint. @@ -64,165 +66,160 @@ % typed arguments. We generate descriptors for type class instances only if % requested to generate all the descriptors we can. -generate_rtti(ModuleInfo, GenerateAll, RttiDatas) :- - module_info_get_class_table(ModuleInfo, ClassTable), - map__to_assoc_list(ClassTable, Classes), - list__foldl(generate_class_decl(ModuleInfo), Classes, - [], RttiDatas0), - ( - GenerateAll = yes, - module_info_get_instance_table(ModuleInfo, InstanceTable), - map__to_assoc_list(InstanceTable, Instances), - list__foldl(generate_instance_decls(ModuleInfo), Instances, - RttiDatas0, RttiDatas) - ; - GenerateAll = no, - RttiDatas = RttiDatas0 - ). +generate_rtti(ModuleInfo, GenerateAll, !:RttiDatas) :- + module_info_get_class_table(ModuleInfo, ClassTable), + map__to_assoc_list(ClassTable, Classes), + list__foldl(generate_class_decl(ModuleInfo), Classes, [], !:RttiDatas), + ( + GenerateAll = yes, + module_info_get_instance_table(ModuleInfo, InstanceTable), + map__to_assoc_list(InstanceTable, Instances), + list__foldl(generate_instance_decls(ModuleInfo), Instances, !RttiDatas) + ; + GenerateAll = no + ). %---------------------------------------------------------------------------% :- pred generate_class_decl(module_info::in, - pair(class_id, hlds_class_defn)::in, - list(rtti_data)::in, list(rtti_data)::out) is det. + pair(class_id, hlds_class_defn)::in, + list(rtti_data)::in, list(rtti_data)::out) is det. generate_class_decl(ModuleInfo, ClassId - ClassDefn, !RttiDatas) :- - ImportStatus = ClassDefn ^ class_status, - ( status_defined_in_this_module(ImportStatus, yes) -> - TCId = generate_class_id(ModuleInfo, ClassId, ClassDefn), - Supers = ClassDefn ^ class_supers, - TCSupers = list__map(generate_class_constraint, Supers), - TCVersion = type_class_info_rtti_version, - RttiData = type_class_decl(tc_decl(TCId, TCVersion, TCSupers)), - !:RttiDatas = [RttiData | !.RttiDatas] - ; - true - ). + ImportStatus = ClassDefn ^ class_status, + ( status_defined_in_this_module(ImportStatus, yes) -> + TCId = generate_class_id(ModuleInfo, ClassId, ClassDefn), + Supers = ClassDefn ^ class_supers, + TCSupers = list__map(generate_class_constraint, Supers), + TCVersion = type_class_info_rtti_version, + RttiData = type_class_decl(tc_decl(TCId, TCVersion, TCSupers)), + !:RttiDatas = [RttiData | !.RttiDatas] + ; + true + ). :- func generate_class_id(module_info, class_id, hlds_class_defn) = tc_id. generate_class_id(ModuleInfo, ClassId, ClassDefn) = TCId :- - TCName = generate_class_name(ClassId), - ClassVars = ClassDefn ^ class_vars, - ClassVarSet = ClassDefn ^ class_tvarset, - list__map(varset__lookup_name(ClassVarSet), ClassVars, VarNames), - Interface = ClassDefn ^ class_hlds_interface, - MethodIds = list__map(generate_method_id(ModuleInfo), Interface), - TCId = tc_id(TCName, VarNames, MethodIds). + TCName = generate_class_name(ClassId), + ClassVars = ClassDefn ^ class_vars, + ClassVarSet = ClassDefn ^ class_tvarset, + list__map(varset__lookup_name(ClassVarSet), ClassVars, VarNames), + Interface = ClassDefn ^ class_hlds_interface, + MethodIds = list__map(generate_method_id(ModuleInfo), Interface), + TCId = tc_id(TCName, VarNames, MethodIds). :- func generate_method_id(module_info, hlds_class_proc) = tc_method_id. generate_method_id(ModuleInfo, ClassProc) = MethodId :- - ClassProc = hlds_class_proc(PredId, _ProcId), - module_info_pred_info(ModuleInfo, PredId, PredInfo), - MethodName = pred_info_name(PredInfo), - Arity = pred_info_orig_arity(PredInfo), - PredOrFunc = pred_info_is_pred_or_func(PredInfo), - MethodId = tc_method_id(MethodName, Arity, PredOrFunc). + ClassProc = hlds_class_proc(PredId, _ProcId), + module_info_pred_info(ModuleInfo, PredId, PredInfo), + MethodName = pred_info_name(PredInfo), + Arity = pred_info_orig_arity(PredInfo), + PredOrFunc = pred_info_is_pred_or_func(PredInfo), + MethodId = tc_method_id(MethodName, Arity, PredOrFunc). %---------------------------------------------------------------------------% :- pred generate_instance_decls(module_info::in, - pair(class_id, list(hlds_instance_defn))::in, - list(rtti_data)::in, list(rtti_data)::out) is det. + pair(class_id, list(hlds_instance_defn))::in, + list(rtti_data)::in, list(rtti_data)::out) is det. generate_instance_decls(ModuleInfo, ClassId - Instances, !RttiDatas) :- - list__foldl(generate_maybe_instance_decl(ModuleInfo, ClassId), - Instances, !RttiDatas). + list__foldl(generate_maybe_instance_decl(ModuleInfo, ClassId), + Instances, !RttiDatas). :- pred generate_maybe_instance_decl(module_info::in, - class_id::in, hlds_instance_defn::in, - list(rtti_data)::in, list(rtti_data)::out) is det. + class_id::in, hlds_instance_defn::in, + list(rtti_data)::in, list(rtti_data)::out) is det. generate_maybe_instance_decl(ModuleInfo, ClassId, InstanceDefn, !RttiDatas) :- - ImportStatus = InstanceDefn ^ instance_status, - Body = InstanceDefn ^ instance_body, - ( - Body = concrete(_), - % Only make the RTTI structure for the type class - % instance if the instance declaration originally - % came from _this_ module. - status_defined_in_this_module(ImportStatus, yes) - -> - RttiData = generate_instance_decl(ModuleInfo, ClassId, - InstanceDefn), - !:RttiDatas = [RttiData | !.RttiDatas] - ; - true - ). + ImportStatus = InstanceDefn ^ instance_status, + Body = InstanceDefn ^ instance_body, + ( + Body = concrete(_), + % Only make the RTTI structure for the type class instance if the + % instance declaration originally came from _this_ module. + status_defined_in_this_module(ImportStatus, yes) + -> + RttiData = generate_instance_decl(ModuleInfo, ClassId, + InstanceDefn), + !:RttiDatas = [RttiData | !.RttiDatas] + ; + true + ). :- func generate_instance_decl(module_info, class_id, hlds_instance_defn) - = rtti_data. + = rtti_data. generate_instance_decl(ModuleInfo, ClassId, Instance) = RttiData :- - TCName = generate_class_name(ClassId), - InstanceTypes = Instance ^ instance_types, - InstanceTCTypes = list__map(generate_tc_type, InstanceTypes), - TVarSet = Instance ^ instance_tvarset, - varset__vars(TVarSet, TVars), - TVarNums = list__map(term__var_to_int, TVars), - TVarLength = list__length(TVarNums), - ( list__last(TVarNums, LastTVarNum) -> - require(unify(TVarLength, LastTVarNum), - "generate_instance_decl: tvar num mismatch"), - NumTypeVars = TVarLength - ; - NumTypeVars = 0 - ), - Constraints = Instance ^ instance_constraints, - TCConstraints = list__map(generate_class_constraint, Constraints), - MaybeInterface = Instance ^ instance_hlds_interface, - ( - MaybeInterface = yes(Interface), - MethodProcLabels = list__map( - generate_method_proc_label(ModuleInfo), Interface) - ; - MaybeInterface = no, - error("generate_instance_decl: no interface") - ), - TCInstance = tc_instance(TCName, InstanceTCTypes, NumTypeVars, - TCConstraints, MethodProcLabels), - RttiData = type_class_instance(TCInstance). + TCName = generate_class_name(ClassId), + InstanceTypes = Instance ^ instance_types, + InstanceTCTypes = list__map(generate_tc_type, InstanceTypes), + TVarSet = Instance ^ instance_tvarset, + varset__vars(TVarSet, TVars), + TVarNums = list__map(term__var_to_int, TVars), + TVarLength = list__length(TVarNums), + ( list__last(TVarNums, LastTVarNum) -> + require(unify(TVarLength, LastTVarNum), + "generate_instance_decl: tvar num mismatch"), + NumTypeVars = TVarLength + ; + NumTypeVars = 0 + ), + Constraints = Instance ^ instance_constraints, + TCConstraints = list__map(generate_class_constraint, Constraints), + MaybeInterface = Instance ^ instance_hlds_interface, + ( + MaybeInterface = yes(Interface), + MethodProcLabels = list__map(generate_method_proc_label(ModuleInfo), + Interface) + ; + MaybeInterface = no, + error("generate_instance_decl: no interface") + ), + TCInstance = tc_instance(TCName, InstanceTCTypes, NumTypeVars, + TCConstraints, MethodProcLabels), + RttiData = type_class_instance(TCInstance). :- func generate_method_proc_label(module_info, hlds_class_proc) = - rtti_proc_label. + rtti_proc_label. generate_method_proc_label(ModuleInfo, hlds_class_proc(PredId, ProcId)) = - make_rtti_proc_label(ModuleInfo, PredId, ProcId). + make_rtti_proc_label(ModuleInfo, PredId, ProcId). %---------------------------------------------------------------------------% generate_class_name(class_id(SymName, Arity)) = TCName :- - ( - SymName = qualified(ModuleName, ClassName) - ; - SymName = unqualified(_), - error("generate_class_name: unqualified sym_name") - ), - TCName = tc_name(ModuleName, ClassName, Arity). + ( + SymName = qualified(ModuleName, ClassName) + ; + SymName = unqualified(_), + error("generate_class_name: unqualified sym_name") + ), + TCName = tc_name(ModuleName, ClassName, Arity). generate_class_constraint(constraint(ClassName, Types)) = TCConstr :- - Arity = list__length(Types), - ClassId = class_id(ClassName, Arity), - TCClassName = generate_class_name(ClassId), - ClassTypes = list__map(generate_tc_type, Types), - TCConstr = tc_constraint(TCClassName, ClassTypes). + Arity = list__length(Types), + ClassId = class_id(ClassName, Arity), + TCClassName = generate_class_name(ClassId), + ClassTypes = list__map(generate_tc_type, Types), + TCConstr = tc_constraint(TCClassName, ClassTypes). :- func generate_tc_type(type) = tc_type. generate_tc_type(Type) = TCType :- - pseudo_type_info__construct_maybe_pseudo_type_info(Type, -1, [], - TCType). + pseudo_type_info__construct_maybe_pseudo_type_info(Type, -1, [], TCType). %---------------------------------------------------------------------------% -% The version number of the runtime data structures describing type class -% information, most of which (currently, all of which) is generated in this -% module. -% -% The value returned by this function should be kept in sync with -% MR_TYPECLASS_VERSION in runtime/mercury_typeclass_info.h. - + % The version number of the runtime data structures describing type class + % information, most of which (currently, all of which) is generated in this + % module. + % + % The value returned by this function should be kept in sync with + % MR_TYPECLASS_VERSION in runtime/mercury_typeclass_info.h. + % :- func type_class_info_rtti_version = int. type_class_info_rtti_version = 0. diff --git a/compiler/typeclasses.m b/compiler/typeclasses.m index 77d452fef..9affed773 100644 --- a/compiler/typeclasses.m +++ b/compiler/typeclasses.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 2005 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. @@ -24,64 +26,64 @@ :- import_module io. - % perform_context_reduction(OrigTypeAssignSet, Info0, Info) is true - % iff either - % (a) Info is the typecheck_info that results from performing - % context reduction on the type_assigns in Info0, or - % (b) if there is no valid context reduction, then Info is Info0 - % with the type assign set replaced by OrigTypeAssignSet (see below). - % - % Context reduction is the process of eliminating redundant constraints - % from the constraints in the type_assign and adding the proof of the - % constraint's redundancy to the proofs in the same type_assign. There - % are three ways in which a constraint may be redundant: - % - % - if a constraint occurs in the pred/func declaration for this - % predicate or function, then it is redundant - % (in this case, the proof is trivial, so there is no need - % to record it in the proof map) - % - if a constraint is present in the set of constraints and all - % of the "superclass" constraints for the constraints are all - % present, then all the superclass constraints are eliminated - % - if there is an instance declaration that may be applied, the - % constraint is replaced by the constraints from that instance - % declaration - % - % In addition, context reduction removes repeated constraints. - % - % During context reduction we also try to "improve" the type binding - % in the given type_assign (that is, binding the type variables in - % such a way that the satisfiability of the constraints is not - % changed). This is done by applying improvement rules inside the - % fixpoint loop. The improvement rules are those which are induced - % by functional dependencies attached to typeclass declarations. - % - % If context reduction fails on a type_assign, that type_assign is - % removed from the type_assign_set. Context reduction fails if there is - % a constraint where the type of (at least) one of the arguments to - % the constraint has its top level functor bound, but there is no - % instance declaration for that type. - % - % If all type_assigns from the typecheck_info are rejected, than an - % appropriate error message is given, the type_assign_set is - % restored to the original one given by OrigTypeAssignSet, - % but without any typeclass constraints. - % The reason for this is to avoid reporting the same error at - % subsequent calls to perform_context_reduction. - % + % perform_context_reduction(OrigTypeAssignSet, !Info) is true + % iff either + % (a) !:Info is the typecheck_info that results from performing + % context reduction on the type_assigns in !.Info, or + % (b) if there is no valid context reduction, then !:Info is !.Info + % with the type assign set replaced by OrigTypeAssignSet (see below). + % + % Context reduction is the process of eliminating redundant constraints + % from the constraints in the type_assign and adding the proof of the + % constraint's redundancy to the proofs in the same type_assign. There + % are three ways in which a constraint may be redundant: + % + % - if a constraint occurs in the pred/func declaration for this + % predicate or function, then it is redundant + % (in this case, the proof is trivial, so there is no need + % to record it in the proof map) + % - if a constraint is present in the set of constraints and all + % of the "superclass" constraints for the constraints are all + % present, then all the superclass constraints are eliminated + % - if there is an instance declaration that may be applied, the + % constraint is replaced by the constraints from that instance + % declaration + % + % In addition, context reduction removes repeated constraints. + % + % During context reduction we also try to "improve" the type binding + % in the given type_assign (that is, binding the type variables in + % such a way that the satisfiability of the constraints is not + % changed). This is done by applying improvement rules inside the + % fixpoint loop. The improvement rules are those which are induced + % by functional dependencies attached to typeclass declarations. + % + % If context reduction fails on a type_assign, that type_assign is + % removed from the type_assign_set. Context reduction fails if there is + % a constraint where the type of (at least) one of the arguments to + % the constraint has its top level functor bound, but there is no + % instance declaration for that type. + % + % If all type_assigns from the typecheck_info are rejected, than an + % appropriate error message is given, the type_assign_set is + % restored to the original one given by OrigTypeAssignSet, + % but without any typeclass constraints. + % The reason for this is to avoid reporting the same error at + % subsequent calls to perform_context_reduction. + % :- pred perform_context_reduction(type_assign_set::in, - typecheck_info::in, typecheck_info::out, io::di, io::uo) is det. + typecheck_info::in, typecheck_info::out, io::di, io::uo) is det. - % Apply context reduction to the list of class constraints by applying - % the instance rules or superclass rules, building up proofs for - % redundant constraints. - % -:- pred typeclasses__reduce_context_by_rule_application(class_table::in, - instance_table::in, superclass_table::in, head_type_params::in, - tsubst::in, tsubst::out, tvarset::in, tvarset::out, - constraint_proof_map::in, constraint_proof_map::out, - constraint_map::in, constraint_map::out, - hlds_constraints::in, hlds_constraints::out) is det. + % Apply context reduction to the list of class constraints by applying + % the instance rules or superclass rules, building up proofs for + % redundant constraints. + % +:- pred reduce_context_by_rule_application(class_table::in, + instance_table::in, superclass_table::in, head_type_params::in, + tsubst::in, tsubst::out, tvarset::in, tvarset::out, + constraint_proof_map::in, constraint_proof_map::out, + constraint_map::in, constraint_map::out, + hlds_constraints::in, hlds_constraints::out) is det. %-----------------------------------------------------------------------------% @@ -105,832 +107,783 @@ %-----------------------------------------------------------------------------% perform_context_reduction(OrigTypeAssignSet, !Info, !IO) :- - checkpoint("before context reduction", !Info, !IO), - typecheck_info_get_module_info(!.Info, ModuleInfo), - module_info_get_class_table(ModuleInfo, ClassTable), - module_info_get_superclass_table(ModuleInfo, SuperClassTable), - module_info_get_instance_table(ModuleInfo, InstanceTable), - typecheck_info_get_type_assign_set(!.Info, TypeAssignSet0), - list__filter_map( - reduce_type_assign_context(ClassTable, SuperClassTable, - InstanceTable), - TypeAssignSet0, TypeAssignSet), - ( - % Check that this context reduction hasn't eliminated - % all the type assignments. - TypeAssignSet = [], - TypeAssignSet0 \= [] - -> - report_unsatisfiable_constraints(TypeAssignSet0, !Info, !IO), - DeleteConstraints = (pred(TA0::in, TA::out) is det :- - type_assign_get_typeclass_constraints(TA0, - Constraints0), - Constraints = (Constraints0 - ^ unproven := []) - ^ redundant := multi_map.init, - type_assign_set_typeclass_constraints(Constraints, - TA0, TA) - ), - list__map(DeleteConstraints, OrigTypeAssignSet, - NewTypeAssignSet), - typecheck_info_set_type_assign_set(NewTypeAssignSet, !Info) - ; - typecheck_info_set_type_assign_set(TypeAssignSet, !Info) - ). + checkpoint("before context reduction", !Info, !IO), + typecheck_info_get_module_info(!.Info, ModuleInfo), + module_info_get_class_table(ModuleInfo, ClassTable), + module_info_get_superclass_table(ModuleInfo, SuperClassTable), + module_info_get_instance_table(ModuleInfo, InstanceTable), + typecheck_info_get_type_assign_set(!.Info, TypeAssignSet0), + list__filter_map( + reduce_type_assign_context(ClassTable, SuperClassTable, InstanceTable), + TypeAssignSet0, TypeAssignSet), + ( + % Check that this context reduction hasn't eliminated + % all the type assignments. + TypeAssignSet0 = [_ | _], + TypeAssignSet = [] + -> + report_unsatisfiable_constraints(TypeAssignSet0, !Info, !IO), + DeleteConstraints = (pred(TA0::in, TA::out) is det :- + type_assign_get_typeclass_constraints(TA0, Constraints0), + Constraints = (Constraints0 + ^ unproven := []) + ^ redundant := multi_map.init, + type_assign_set_typeclass_constraints(Constraints, TA0, TA) + ), + list__map(DeleteConstraints, OrigTypeAssignSet, NewTypeAssignSet), + typecheck_info_set_type_assign_set(NewTypeAssignSet, !Info) + ; + typecheck_info_set_type_assign_set(TypeAssignSet, !Info) + ). :- pred reduce_type_assign_context(class_table::in, superclass_table::in, - instance_table::in, type_assign::in, type_assign::out) is semidet. + instance_table::in, type_assign::in, type_assign::out) is semidet. reduce_type_assign_context(ClassTable, SuperClassTable, InstanceTable, - !TypeAssign) :- - type_assign_get_head_type_params(!.TypeAssign, HeadTypeParams), - type_assign_get_type_bindings(!.TypeAssign, Bindings0), - type_assign_get_typeclass_constraints(!.TypeAssign, Constraints0), - type_assign_get_typevarset(!.TypeAssign, TVarSet0), - type_assign_get_constraint_proofs(!.TypeAssign, Proofs0), - type_assign_get_constraint_map(!.TypeAssign, ConstraintMap0), + !TypeAssign) :- + type_assign_get_head_type_params(!.TypeAssign, HeadTypeParams), + type_assign_get_type_bindings(!.TypeAssign, Bindings0), + type_assign_get_typeclass_constraints(!.TypeAssign, Constraints0), + type_assign_get_typevarset(!.TypeAssign, TVarSet0), + type_assign_get_constraint_proofs(!.TypeAssign, Proofs0), + type_assign_get_constraint_map(!.TypeAssign, ConstraintMap0), - typeclasses__reduce_context_by_rule_application(ClassTable, - InstanceTable, SuperClassTable, HeadTypeParams, - Bindings0, Bindings, TVarSet0, TVarSet, Proofs0, Proofs, - ConstraintMap0, ConstraintMap, Constraints0, Constraints), - check_satisfiability(Constraints ^ unproven, HeadTypeParams), + typeclasses__reduce_context_by_rule_application(ClassTable, + InstanceTable, SuperClassTable, HeadTypeParams, + Bindings0, Bindings, TVarSet0, TVarSet, Proofs0, Proofs, + ConstraintMap0, ConstraintMap, Constraints0, Constraints), + check_satisfiability(Constraints ^ unproven, HeadTypeParams), - type_assign_set_type_bindings(Bindings, !TypeAssign), - type_assign_set_typeclass_constraints(Constraints, !TypeAssign), - type_assign_set_typevarset(TVarSet, !TypeAssign), - type_assign_set_constraint_proofs(Proofs, !TypeAssign), - type_assign_set_constraint_map(ConstraintMap, !TypeAssign). + type_assign_set_type_bindings(Bindings, !TypeAssign), + type_assign_set_typeclass_constraints(Constraints, !TypeAssign), + type_assign_set_typevarset(TVarSet, !TypeAssign), + type_assign_set_constraint_proofs(Proofs, !TypeAssign), + type_assign_set_constraint_map(ConstraintMap, !TypeAssign). typeclasses__reduce_context_by_rule_application(ClassTable, InstanceTable, - SuperClassTable, HeadTypeParams, !Bindings, !TVarSet, !Proofs, - !ConstraintMap, !Constraints) :- - typeclasses__reduce_context_by_rule_application_2(ClassTable, - InstanceTable, SuperClassTable, HeadTypeParams, !Bindings, - !TVarSet, !Proofs, !ConstraintMap, !Constraints, - !.Constraints ^ unproven, _). + SuperClassTable, HeadTypeParams, !Bindings, !TVarSet, !Proofs, + !ConstraintMap, !Constraints) :- + typeclasses__reduce_context_by_rule_application_2(ClassTable, + InstanceTable, SuperClassTable, HeadTypeParams, !Bindings, + !TVarSet, !Proofs, !ConstraintMap, !Constraints, + !.Constraints ^ unproven, _). :- pred typeclasses__reduce_context_by_rule_application_2(class_table::in, - instance_table::in, superclass_table::in, head_type_params::in, - tsubst::in, tsubst::out, tvarset::in, tvarset::out, - constraint_proof_map::in, constraint_proof_map::out, - constraint_map::in, constraint_map::out, - hlds_constraints::in, hlds_constraints::out, - list(hlds_constraint)::in, list(hlds_constraint)::out) is det. + instance_table::in, superclass_table::in, head_type_params::in, + tsubst::in, tsubst::out, tvarset::in, tvarset::out, + constraint_proof_map::in, constraint_proof_map::out, + constraint_map::in, constraint_map::out, + hlds_constraints::in, hlds_constraints::out, + list(hlds_constraint)::in, list(hlds_constraint)::out) is det. typeclasses__reduce_context_by_rule_application_2(ClassTable, InstanceTable, - SuperClassTable, HeadTypeParams, !Bindings, !TVarSet, !Proofs, - !ConstraintMap, !Constraints, !Seen) :- - apply_rec_subst_to_constraints(!.Bindings, !Constraints), - apply_improvement_rules(ClassTable, InstanceTable, HeadTypeParams, - !.Constraints, !TVarSet, !Bindings, AppliedImprovementRule), + SuperClassTable, HeadTypeParams, !Bindings, !TVarSet, !Proofs, + !ConstraintMap, !Constraints, !Seen) :- + apply_rec_subst_to_constraints(!.Bindings, !Constraints), + apply_improvement_rules(ClassTable, InstanceTable, HeadTypeParams, + !.Constraints, !TVarSet, !Bindings, AppliedImprovementRule), - % We want to make sure that any changes to the bindings are - % reflected in the constraints, so that the full effect of the - % improvement rules applies as soon as possible. We therefore - % apply the bindings to the constraints (but only if the - % bindings have actually changed since they were last applied). - % - ( - AppliedImprovementRule = yes, - apply_rec_subst_to_constraints(!.Bindings, !Constraints) - ; - AppliedImprovementRule = no - ), + % We want to make sure that any changes to the bindings are reflected + % in the constraints, so that the full effect of the improvement rules + % applies as soon as possible. We therefore apply the bindings to the + % constraints (but only if the bindings have actually changed since + % they were last applied). + ( + AppliedImprovementRule = yes, + apply_rec_subst_to_constraints(!.Bindings, !Constraints) + ; + AppliedImprovementRule = no + ), - eliminate_assumed_constraints(!ConstraintMap, !Constraints, - EliminatedAssumed), - apply_instance_rules(ClassTable, InstanceTable, !TVarSet, !Proofs, - !ConstraintMap, !Seen, !Constraints, AppliedInstanceRule), - % XXX kind inference: - % We assume that all tvars have kind `star'. - map__init(KindMap), - apply_class_rules(SuperClassTable, !.TVarSet, KindMap, !Proofs, - !ConstraintMap, !Constraints, AppliedClassRule), - ( - AppliedImprovementRule = no, - EliminatedAssumed = no, - AppliedInstanceRule = no, - AppliedClassRule = no - -> - % We have reached fixpoint. - % - sort_and_merge_dups(!Constraints) - ; - typeclasses__reduce_context_by_rule_application_2(ClassTable, - InstanceTable, SuperClassTable, HeadTypeParams, - !Bindings, !TVarSet, !Proofs, !ConstraintMap, - !Constraints, !Seen) - ). + eliminate_assumed_constraints(!ConstraintMap, !Constraints, + EliminatedAssumed), + apply_instance_rules(ClassTable, InstanceTable, !TVarSet, !Proofs, + !ConstraintMap, !Seen, !Constraints, AppliedInstanceRule), + % XXX Kind inference: we assume that all tvars have kind `star'. + map__init(KindMap), + apply_class_rules(SuperClassTable, !.TVarSet, KindMap, !Proofs, + !ConstraintMap, !Constraints, AppliedClassRule), + ( + AppliedImprovementRule = no, + EliminatedAssumed = no, + AppliedInstanceRule = no, + AppliedClassRule = no + -> + % We have reached fixpoint. + sort_and_merge_dups(!Constraints) + ; + typeclasses__reduce_context_by_rule_application_2(ClassTable, + InstanceTable, SuperClassTable, HeadTypeParams, !Bindings, + !TVarSet, !Proofs, !ConstraintMap, !Constraints, !Seen) + ). :- pred sort_and_merge_dups(hlds_constraints::in, hlds_constraints::out) - is det. + is det. sort_and_merge_dups(!Constraints) :- - % Should we also sort and merge the other fields? - Unproven0 = !.Constraints ^ unproven, - list__sort(compare_hlds_constraints, Unproven0, Unproven1), - merge_adjacent_constraints(Unproven1, Unproven), - !:Constraints = !.Constraints ^ unproven := Unproven. + % Should we also sort and merge the other fields? + Unproven0 = !.Constraints ^ unproven, + list__sort(compare_hlds_constraints, Unproven0, Unproven1), + merge_adjacent_constraints(Unproven1, Unproven), + !:Constraints = !.Constraints ^ unproven := Unproven. :- pred merge_adjacent_constraints(list(hlds_constraint)::in, - list(hlds_constraint)::out) is det. + list(hlds_constraint)::out) is det. merge_adjacent_constraints([], []). merge_adjacent_constraints([C | Cs], Constraints) :- - merge_adjacent_constraints_2(C, Cs, Constraints). + merge_adjacent_constraints_2(C, Cs, Constraints). :- pred merge_adjacent_constraints_2(hlds_constraint::in, - list(hlds_constraint)::in, list(hlds_constraint)::out) is det. + list(hlds_constraint)::in, list(hlds_constraint)::out) is det. merge_adjacent_constraints_2(C0, [], [C0]). merge_adjacent_constraints_2(C0, [C1 | Cs], Constraints) :- - ( - merge_constraints(C0, C1, C) - -> - merge_adjacent_constraints_2(C, Cs, Constraints) - ; - merge_adjacent_constraints_2(C1, Cs, Constraints0), - Constraints = [C0 | Constraints0] - ). + ( merge_constraints(C0, C1, C) -> + merge_adjacent_constraints_2(C, Cs, Constraints) + ; + merge_adjacent_constraints_2(C1, Cs, Constraints0), + Constraints = [C0 | Constraints0] + ). - % merge_constraints(A, B, C) succeeds if A and B represent equivalent - % constraints. In this case, C is the equivalent constraint with the - % list of ids being the union of the ids of A and B. - % + % merge_constraints(A, B, C) succeeds if A and B represent equivalent + % constraints. In this case, C is the equivalent constraint with the + % list of ids being the union of the ids of A and B. + % :- pred merge_constraints(hlds_constraint::in, hlds_constraint::in, - hlds_constraint::out) is semidet. + hlds_constraint::out) is semidet. merge_constraints(constraint(IdsA, Name, Types), constraint(IdsB, Name, Types), - constraint(Ids, Name, Types)) :- - list__append(IdsA, IdsB, Ids0), - list__sort_and_remove_dups(Ids0, Ids). + constraint(Ids, Name, Types)) :- + list__append(IdsA, IdsB, Ids0), + list__sort_and_remove_dups(Ids0, Ids). :- pred apply_improvement_rules(class_table::in, instance_table::in, - head_type_params::in, hlds_constraints::in, tvarset::in, tvarset::out, - tsubst::in, tsubst::out, bool::out) is det. + head_type_params::in, hlds_constraints::in, tvarset::in, tvarset::out, + tsubst::in, tsubst::out, bool::out) is det. apply_improvement_rules(ClassTable, InstanceTable, HeadTypeParams, Constraints, - !TVarSet, !Bindings, Changed) :- - % XXX should we sort and merge the constraints here? - do_class_improvement(ClassTable, HeadTypeParams, Constraints, - !Bindings, Changed1), - % XXX do we really need to modify the varset? See the comment above - % find_matching_instance_rule. - do_instance_improvement(ClassTable, InstanceTable, HeadTypeParams, - Constraints, !TVarSet, !Bindings, Changed2), - Changed = bool__or(Changed1, Changed2). + !TVarSet, !Bindings, Changed) :- + % XXX Should we sort and merge the constraints here? + do_class_improvement(ClassTable, HeadTypeParams, Constraints, !Bindings, + Changed1), + % XXX Do we really need to modify the varset? See the comment above + % find_matching_instance_rule. + do_instance_improvement(ClassTable, InstanceTable, HeadTypeParams, + Constraints, !TVarSet, !Bindings, Changed2), + Changed = bool__or(Changed1, Changed2). :- pred do_class_improvement(class_table::in, head_type_params::in, - hlds_constraints::in, tsubst::in, tsubst::out, bool::out) is det. + hlds_constraints::in, tsubst::in, tsubst::out, bool::out) is det. do_class_improvement(ClassTable, HeadTypeParams, Constraints, !Bindings, - Changed) :- - Redundant = Constraints ^ redundant, - Assumed = Constraints ^ assumed, - multi_map__keys(Redundant, ClassIds), - list__foldl2( - do_class_improvement_2(ClassTable, HeadTypeParams, Redundant, - Assumed), - ClassIds, !Bindings, no, Changed). + Changed) :- + Redundant = Constraints ^ redundant, + Assumed = Constraints ^ assumed, + multi_map__keys(Redundant, ClassIds), + list__foldl2( + do_class_improvement_2(ClassTable, HeadTypeParams, Redundant, Assumed), + ClassIds, !Bindings, no, Changed). :- pred do_class_improvement_2(class_table::in, head_type_params::in, - redundant_constraints::in, list(hlds_constraint)::in, class_id::in, - tsubst::in, tsubst::out, bool::in, bool::out) is det. + redundant_constraints::in, list(hlds_constraint)::in, class_id::in, + tsubst::in, tsubst::out, bool::in, bool::out) is det. do_class_improvement_2(ClassTable, HeadTypeParams, RedundantConstraints, - Assumed, ClassId, !Bindings, !Changed) :- - map__lookup(ClassTable, ClassId, ClassDefn), - FunDeps = ClassDefn ^ class_fundeps, - map__lookup(RedundantConstraints, ClassId, Constraints), - do_class_improvement_by_pairs(Constraints, FunDeps, HeadTypeParams, - !Bindings, !Changed), - list__filter(has_class_id(ClassId), Assumed, ThisClassAssumed), - do_class_improvement_by_assumed(ThisClassAssumed, Constraints, FunDeps, - HeadTypeParams, !Bindings, !Changed). + Assumed, ClassId, !Bindings, !Changed) :- + map__lookup(ClassTable, ClassId, ClassDefn), + FunDeps = ClassDefn ^ class_fundeps, + map__lookup(RedundantConstraints, ClassId, Constraints), + do_class_improvement_by_pairs(Constraints, FunDeps, HeadTypeParams, + !Bindings, !Changed), + list__filter(has_class_id(ClassId), Assumed, ThisClassAssumed), + do_class_improvement_by_assumed(ThisClassAssumed, Constraints, FunDeps, + HeadTypeParams, !Bindings, !Changed). :- pred has_class_id(class_id::in, hlds_constraint::in) is semidet. has_class_id(class_id(Name, Arity), constraint(_, Name, Args)) :- - list__length(Args, Arity). + list__length(Args, Arity). - % Try to find an opportunity for improvement for each (unordered) - % pair of constraints from the list. - % + % Try to find an opportunity for improvement for each (unordered) + % pair of constraints from the list. + % :- pred do_class_improvement_by_pairs(list(hlds_constraint)::in, - hlds_class_fundeps::in, head_type_params::in, tsubst::in, tsubst::out, - bool::in, bool::out) is det. + hlds_class_fundeps::in, head_type_params::in, tsubst::in, tsubst::out, + bool::in, bool::out) is det. do_class_improvement_by_pairs([], _, _, !Bindings, !Changed). do_class_improvement_by_pairs([Constraint | Constraints], FunDeps, - HeadTypeParams, !Bindings, !Changed) :- - do_class_improvement_by_pairs_2(Constraint, Constraints, FunDeps, - HeadTypeParams, !Bindings, !Changed), - do_class_improvement_by_pairs(Constraints, FunDeps, HeadTypeParams, - !Bindings, !Changed). + HeadTypeParams, !Bindings, !Changed) :- + do_class_improvement_by_pairs_2(Constraint, Constraints, FunDeps, + HeadTypeParams, !Bindings, !Changed), + do_class_improvement_by_pairs(Constraints, FunDeps, HeadTypeParams, + !Bindings, !Changed). :- pred do_class_improvement_by_pairs_2(hlds_constraint::in, - list(hlds_constraint)::in, hlds_class_fundeps::in, - head_type_params::in, tsubst::in, tsubst::out, bool::in, bool::out) - is det. + list(hlds_constraint)::in, hlds_class_fundeps::in, head_type_params::in, + tsubst::in, tsubst::out, bool::in, bool::out) is det. do_class_improvement_by_pairs_2(_, [], _, _, !Bindings, !Changed). do_class_improvement_by_pairs_2(Constraint, [HeadConstraint | TailConstraints], - FunDeps, HeadTypeParams, !Bindings, !Changed) :- - do_class_improvement_pair(Constraint, HeadConstraint, FunDeps, - HeadTypeParams, !Bindings, !Changed), - do_class_improvement_by_pairs_2(Constraint, TailConstraints, FunDeps, - HeadTypeParams, !Bindings, !Changed). + FunDeps, HeadTypeParams, !Bindings, !Changed) :- + do_class_improvement_pair(Constraint, HeadConstraint, FunDeps, + HeadTypeParams, !Bindings, !Changed), + do_class_improvement_by_pairs_2(Constraint, TailConstraints, FunDeps, + HeadTypeParams, !Bindings, !Changed). - % Try to find an opportunity for improvement for each pair of - % constraints where one comes from the assumed constraints and the - % other comes from the redundant constraints. - % + % Try to find an opportunity for improvement for each pair of + % constraints where one comes from the assumed constraints and the + % other comes from the redundant constraints. + % :- pred do_class_improvement_by_assumed(list(hlds_constraint)::in, - list(hlds_constraint)::in, hlds_class_fundeps::in, - head_type_params::in, tsubst::in, tsubst::out, bool::in, bool::out) - is det. + list(hlds_constraint)::in, hlds_class_fundeps::in, head_type_params::in, + tsubst::in, tsubst::out, bool::in, bool::out) is det. do_class_improvement_by_assumed(Assumed, Constraints, FunDeps, HeadTypeParams, - !Bindings, !Changed) :- - list__foldl2( - do_class_improvement_by_assumed_2(Constraints, FunDeps, - HeadTypeParams), - Assumed, !Bindings, !Changed). + !Bindings, !Changed) :- + list__foldl2( + do_class_improvement_by_assumed_2(Constraints, FunDeps, + HeadTypeParams), + Assumed, !Bindings, !Changed). :- pred do_class_improvement_by_assumed_2(list(hlds_constraint)::in, - hlds_class_fundeps::in, head_type_params::in, hlds_constraint::in, - tsubst::in, tsubst::out, bool::in, bool::out) is det. + hlds_class_fundeps::in, head_type_params::in, hlds_constraint::in, + tsubst::in, tsubst::out, bool::in, bool::out) is det. do_class_improvement_by_assumed_2([], _, _, _, !Bindings, !Changed). do_class_improvement_by_assumed_2([Constraint | Constraints], FunDeps, - HeadTypeParams, Assumed, !Bindings, !Changed) :- - do_class_improvement_pair(Constraint, Assumed, FunDeps, HeadTypeParams, - !Bindings, !Changed), - do_class_improvement_by_assumed_2(Constraints, FunDeps, HeadTypeParams, - Assumed, !Bindings, !Changed). + HeadTypeParams, Assumed, !Bindings, !Changed) :- + do_class_improvement_pair(Constraint, Assumed, FunDeps, HeadTypeParams, + !Bindings, !Changed), + do_class_improvement_by_assumed_2(Constraints, FunDeps, HeadTypeParams, + Assumed, !Bindings, !Changed). - % Try to find an opportunity for improvement for this pair of - % constraints, using each fundep in turn. - % + % Try to find an opportunity for improvement for this pair of + % constraints, using each fundep in turn. + % :- pred do_class_improvement_pair(hlds_constraint::in, hlds_constraint::in, - hlds_class_fundeps::in, head_type_params::in, tsubst::in, tsubst::out, - bool::in, bool::out) is det. + hlds_class_fundeps::in, head_type_params::in, tsubst::in, tsubst::out, + bool::in, bool::out) is det. do_class_improvement_pair(_, _, [], _, !Bindings, !Changed). do_class_improvement_pair(ConstraintA, ConstraintB, [FunDep | FunDeps], - HeadTypeParams, !Bindings, !Changed) :- - do_class_improvement_fundep(ConstraintA, ConstraintB, FunDep, - HeadTypeParams, !Bindings, !Changed), - do_class_improvement_pair(ConstraintA, ConstraintB, FunDeps, - HeadTypeParams, !Bindings, !Changed). + HeadTypeParams, !Bindings, !Changed) :- + do_class_improvement_fundep(ConstraintA, ConstraintB, FunDep, + HeadTypeParams, !Bindings, !Changed), + do_class_improvement_pair(ConstraintA, ConstraintB, FunDeps, + HeadTypeParams, !Bindings, !Changed). :- pred do_class_improvement_fundep(hlds_constraint::in, hlds_constraint::in, - hlds_class_fundep::in, head_type_params::in, tsubst::in, tsubst::out, - bool::in, bool::out) is det. + hlds_class_fundep::in, head_type_params::in, tsubst::in, tsubst::out, + bool::in, bool::out) is det. do_class_improvement_fundep(ConstraintA, ConstraintB, FunDep, HeadTypeParams, - !Bindings, !Changed) :- - ConstraintA = constraint(_, _, TypesA), - ConstraintB = constraint(_, _, TypesB), - FunDep = fundep(Domain, Range), - ( - % - % We already know that the name/arity of the - % constraints match, since we have partitioned them - % already. - % - lists_match_on_elements(Domain, TypesA, TypesB), - \+ lists_match_on_elements(Range, TypesA, TypesB), + !Bindings, !Changed) :- + ConstraintA = constraint(_, _, TypesA), + ConstraintB = constraint(_, _, TypesB), + FunDep = fundep(Domain, Range), + ( + % We already know that the name/arity of the constraints match, + % since we have partitioned them already. + lists_match_on_elements(Domain, TypesA, TypesB), + \+ lists_match_on_elements(Range, TypesA, TypesB), - % - % The unification can fail if type parameters in the - % declaration would be bound by the improvement rule. - % This means that the declaration is not as specific - % as it could be, but that is not a problem for us. - % - unify_on_elements(Range, TypesA, TypesB, HeadTypeParams, - !Bindings) - -> - !:Changed = yes - ; - true - ). + % The unification can fail if type parameters in the declaration + % would be bound by the improvement rule. This means that the + % declaration is not as specific as it could be, but that is not + % a problem for us. + unify_on_elements(Range, TypesA, TypesB, HeadTypeParams, !Bindings) + -> + !:Changed = yes + ; + true + ). :- pred do_instance_improvement(class_table::in, instance_table::in, - head_type_params::in, hlds_constraints::in, tvarset::in, tvarset::out, - tsubst::in, tsubst::out, bool::out) is det. + head_type_params::in, hlds_constraints::in, tvarset::in, tvarset::out, + tsubst::in, tsubst::out, bool::out) is det. do_instance_improvement(ClassTable, InstanceTable, HeadTypeParams, Constraints, - !TVarSet, !Bindings, Changed) :- - RedundantConstraints = Constraints ^ redundant, - map__keys(RedundantConstraints, ClassIds), - list__foldl3( - do_instance_improvement_2(ClassTable, InstanceTable, - HeadTypeParams, RedundantConstraints), - ClassIds, !TVarSet, !Bindings, no, Changed). + !TVarSet, !Bindings, Changed) :- + RedundantConstraints = Constraints ^ redundant, + map__keys(RedundantConstraints, ClassIds), + list__foldl3( + do_instance_improvement_2(ClassTable, InstanceTable, + HeadTypeParams, RedundantConstraints), + ClassIds, !TVarSet, !Bindings, no, Changed). :- pred do_instance_improvement_2(class_table::in, instance_table::in, - head_type_params::in, redundant_constraints::in, class_id::in, - tvarset::in, tvarset::out, tsubst::in, tsubst::out, - bool::in, bool::out) is det. + head_type_params::in, redundant_constraints::in, class_id::in, + tvarset::in, tvarset::out, tsubst::in, tsubst::out, + bool::in, bool::out) is det. do_instance_improvement_2(ClassTable, InstanceTable, HeadTypeParams, - RedundantConstraints, ClassId, !TVarSet, !Bindings, - !Changed) :- - map__lookup(ClassTable, ClassId, ClassDefn), - FunDeps = ClassDefn ^ class_fundeps, - map__lookup(InstanceTable, ClassId, InstanceDefns), - map__lookup(RedundantConstraints, ClassId, Constraints), - list__foldl3( - do_instance_improvement_3(Constraints, FunDeps, - HeadTypeParams), - InstanceDefns, !TVarSet, !Bindings, !Changed). + RedundantConstraints, ClassId, !TVarSet, !Bindings, !Changed) :- + map__lookup(ClassTable, ClassId, ClassDefn), + FunDeps = ClassDefn ^ class_fundeps, + map__lookup(InstanceTable, ClassId, InstanceDefns), + map__lookup(RedundantConstraints, ClassId, Constraints), + list__foldl3( + do_instance_improvement_3(Constraints, FunDeps, HeadTypeParams), + InstanceDefns, !TVarSet, !Bindings, !Changed). :- pred do_instance_improvement_3(list(hlds_constraint)::in, - hlds_class_fundeps::in, head_type_params::in, hlds_instance_defn::in, - tvarset::in, tvarset::out, tsubst::in, tsubst::out, - bool::in, bool::out) is det. + hlds_class_fundeps::in, head_type_params::in, hlds_instance_defn::in, + tvarset::in, tvarset::out, tsubst::in, tsubst::out, + bool::in, bool::out) is det. do_instance_improvement_3(Constraints, FunDeps, HeadTypeParams, InstanceDefn, - !TVarSet, !Bindings, !Changed) :- - InstanceTVarSet = InstanceDefn ^ instance_tvarset, - InstanceTypes0 = InstanceDefn ^ instance_types, - tvarset_merge_renaming(!.TVarSet, InstanceTVarSet, NewTVarSet, - Renaming), - apply_variable_renaming_to_type_list(Renaming, InstanceTypes0, - InstanceTypes), - list__foldl2( - do_instance_improvement_4(FunDeps, InstanceTypes, - HeadTypeParams), - Constraints, !Bindings, no, Changed0), - ( - Changed0 = yes, - !:TVarSet = NewTVarSet, - !:Changed = yes - ; - Changed0 = no - ). + !TVarSet, !Bindings, !Changed) :- + InstanceTVarSet = InstanceDefn ^ instance_tvarset, + InstanceTypes0 = InstanceDefn ^ instance_types, + tvarset_merge_renaming(!.TVarSet, InstanceTVarSet, NewTVarSet, Renaming), + apply_variable_renaming_to_type_list(Renaming, InstanceTypes0, + InstanceTypes), + list__foldl2( + do_instance_improvement_4(FunDeps, InstanceTypes, HeadTypeParams), + Constraints, !Bindings, no, Changed0), + ( + Changed0 = yes, + !:TVarSet = NewTVarSet, + !:Changed = yes + ; + Changed0 = no + ). :- pred do_instance_improvement_4(hlds_class_fundeps::in, list(type)::in, - head_type_params::in, hlds_constraint::in, tsubst::in, tsubst::out, - bool::in, bool::out) is det. + head_type_params::in, hlds_constraint::in, tsubst::in, tsubst::out, + bool::in, bool::out) is det. do_instance_improvement_4(FunDeps, InstanceTypes, HeadTypeParams, Constraint, - !Bindings, !Changed) :- - list__foldl2( - do_instance_improvement_fundep(Constraint, InstanceTypes, - HeadTypeParams), - FunDeps, !Bindings, !Changed). + !Bindings, !Changed) :- + list__foldl2( + do_instance_improvement_fundep(Constraint, InstanceTypes, + HeadTypeParams), + FunDeps, !Bindings, !Changed). :- pred do_instance_improvement_fundep(hlds_constraint::in, list(type)::in, - head_type_params::in, hlds_class_fundep::in, tsubst::in, tsubst::out, - bool::in, bool::out) is det. + head_type_params::in, hlds_class_fundep::in, tsubst::in, tsubst::out, + bool::in, bool::out) is det. do_instance_improvement_fundep(Constraint, InstanceTypes0, HeadTypeParams, - FunDep, !Bindings, !Changed) :- - Constraint = constraint(_, _, ConstraintTypes), - FunDep = fundep(Domain, Range), - ( - % - % We already know that the name/arity of the - % constraints match, since we have partitioned them - % already. - % - subsumes_on_elements(Domain, InstanceTypes0, ConstraintTypes, - Subst), - apply_rec_subst_to_type_list(Subst, InstanceTypes0, - InstanceTypes), - \+ lists_match_on_elements(Range, InstanceTypes, - ConstraintTypes), + FunDep, !Bindings, !Changed) :- + Constraint = constraint(_, _, ConstraintTypes), + FunDep = fundep(Domain, Range), + ( + % We already know that the name/arity of the constraints match, + % since we have partitioned them already. + subsumes_on_elements(Domain, InstanceTypes0, ConstraintTypes, Subst), + apply_rec_subst_to_type_list(Subst, InstanceTypes0, InstanceTypes), + \+ lists_match_on_elements(Range, InstanceTypes, ConstraintTypes), - % - % The unification can fail if type parameters in the - % declaration would be bound by the improvement rule. - % This means that the declaration is not as specific - % as it could be, but that is not a problem for us. - % - unify_on_elements(Range, InstanceTypes, ConstraintTypes, - HeadTypeParams, !Bindings) - -> - !:Changed = yes - ; - true - ). + % The unification can fail if type parameters in the declaration + % would be bound by the improvement rule. This means that the + % declaration is not as specific as it could be, but that is not + % a problem for us. + unify_on_elements(Range, InstanceTypes, ConstraintTypes, + HeadTypeParams, !Bindings) + -> + !:Changed = yes + ; + true + ). - % For each index in the set, check that the types in the corresponding - % positions in the lists are identical. - % + % For each index in the set, check that the types in the corresponding + % positions in the lists are identical. + % :- pred lists_match_on_elements(set(hlds_class_argpos)::in, list(type)::in, - list(type)::in) is semidet. + list(type)::in) is semidet. lists_match_on_elements(Elements, TypesA, TypesB) :- - RTypesA = restrict_list_elements(Elements, TypesA), - RTypesB = restrict_list_elements(Elements, TypesB), - RTypesA = RTypesB. + RTypesA = restrict_list_elements(Elements, TypesA), + RTypesB = restrict_list_elements(Elements, TypesB), + RTypesA = RTypesB. - % For each index in the set, unify the types in the corresponding - % positions in the lists and add to the current bindings. - % + % For each index in the set, unify the types in the corresponding + % positions in the lists and add to the current bindings. + % :- pred unify_on_elements(set(hlds_class_argpos)::in, list(type)::in, - list(type)::in, head_type_params::in, tsubst::in, tsubst::out) - is semidet. + list(type)::in, head_type_params::in, tsubst::in, tsubst::out) + is semidet. unify_on_elements(Elements, TypesA, TypesB, HeadTypeParams, !Bindings) :- - RTypesA = restrict_list_elements(Elements, TypesA), - RTypesB = restrict_list_elements(Elements, TypesB), - type_unify_list(RTypesA, RTypesB, HeadTypeParams, !Bindings). + RTypesA = restrict_list_elements(Elements, TypesA), + RTypesB = restrict_list_elements(Elements, TypesB), + type_unify_list(RTypesA, RTypesB, HeadTypeParams, !Bindings). - % Analogous to type_list_subsumes except that it only checks those - % elements of the list specified by the set of indices. - % + % Analogous to type_list_subsumes except that it only checks those + % elements of the list specified by the set of indices. + % :- pred subsumes_on_elements(set(hlds_class_argpos)::in, list(type)::in, - list(type)::in, tsubst::out) is semidet. + list(type)::in, tsubst::out) is semidet. subsumes_on_elements(Elements, TypesA, TypesB, Subst) :- - RTypesA = restrict_list_elements(Elements, TypesA), - RTypesB = restrict_list_elements(Elements, TypesB), - prog_type__vars_list(RTypesB, RTypesBVars), - map__init(Subst0), - type_unify_list(RTypesA, RTypesB, RTypesBVars, Subst0, Subst). + RTypesA = restrict_list_elements(Elements, TypesA), + RTypesB = restrict_list_elements(Elements, TypesB), + prog_type__vars_list(RTypesB, RTypesBVars), + map__init(Subst0), + type_unify_list(RTypesA, RTypesB, RTypesBVars, Subst0, Subst). :- pred eliminate_assumed_constraints(constraint_map::in, constraint_map::out, - hlds_constraints::in, hlds_constraints::out, bool::out) is det. + hlds_constraints::in, hlds_constraints::out, bool::out) is det. eliminate_assumed_constraints(!ConstraintMap, !Constraints, Changed) :- - !.Constraints = constraints(Unproven0, Assumed, Redundant), - eliminate_assumed_constraints_2(Assumed, !ConstraintMap, - Unproven0, Unproven, Changed), - !:Constraints = constraints(Unproven, Assumed, Redundant). + !.Constraints = constraints(Unproven0, Assumed, Redundant), + eliminate_assumed_constraints_2(Assumed, !ConstraintMap, + Unproven0, Unproven, Changed), + !:Constraints = constraints(Unproven, Assumed, Redundant). :- pred eliminate_assumed_constraints_2(list(hlds_constraint)::in, - constraint_map::in, constraint_map::out, - list(hlds_constraint)::in, list(hlds_constraint)::out, - bool::out) is det. + constraint_map::in, constraint_map::out, + list(hlds_constraint)::in, list(hlds_constraint)::out, + bool::out) is det. eliminate_assumed_constraints_2(_, !ConstraintMap, [], [], no). eliminate_assumed_constraints_2(AssumedCs, !ConstraintMap, [C | Cs], NewCs, - Changed) :- - eliminate_assumed_constraints_2(AssumedCs, !ConstraintMap, Cs, NewCs0, - Changed0), - ( - some [A] ( - list__member(A, AssumedCs), - matching_constraints(A, C) - ) - -> - update_constraint_map(C, !ConstraintMap), - NewCs = NewCs0, - Changed = yes - ; - NewCs = [C | NewCs0], - Changed = Changed0 - ). + Changed) :- + eliminate_assumed_constraints_2(AssumedCs, !ConstraintMap, Cs, NewCs0, + Changed0), + ( + some [A] ( + list__member(A, AssumedCs), + matching_constraints(A, C) + ) + -> + update_constraint_map(C, !ConstraintMap), + NewCs = NewCs0, + Changed = yes + ; + NewCs = [C | NewCs0], + Changed = Changed0 + ). :- pred apply_instance_rules(class_table::in, instance_table::in, - tvarset::in, tvarset::out, - constraint_proof_map::in, constraint_proof_map::out, - constraint_map::in, constraint_map::out, - list(hlds_constraint)::in, list(hlds_constraint)::out, - hlds_constraints::in, hlds_constraints::out, bool::out) is det. + tvarset::in, tvarset::out, + constraint_proof_map::in, constraint_proof_map::out, + constraint_map::in, constraint_map::out, + list(hlds_constraint)::in, list(hlds_constraint)::out, + hlds_constraints::in, hlds_constraints::out, bool::out) is det. apply_instance_rules(ClassTable, InstanceTable, !TVarSet, !Proofs, - !ConstraintMap, !Seen, !Constraints, Changed) :- - !.Constraints = constraints(Unproven0, Assumed, Redundant0), - apply_instance_rules_2(ClassTable, InstanceTable, !TVarSet, !Proofs, - !ConstraintMap, Redundant0, Redundant, !Seen, - Unproven0, Unproven, Changed), - !:Constraints = constraints(Unproven, Assumed, Redundant). + !ConstraintMap, !Seen, !Constraints, Changed) :- + !.Constraints = constraints(Unproven0, Assumed, Redundant0), + apply_instance_rules_2(ClassTable, InstanceTable, !TVarSet, !Proofs, + !ConstraintMap, Redundant0, Redundant, !Seen, + Unproven0, Unproven, Changed), + !:Constraints = constraints(Unproven, Assumed, Redundant). :- pred apply_instance_rules_2(class_table::in, instance_table::in, - tvarset::in, tvarset::out, - constraint_proof_map::in, constraint_proof_map::out, - constraint_map::in, constraint_map::out, - redundant_constraints::in, redundant_constraints::out, - list(hlds_constraint)::in, list(hlds_constraint)::out, - list(hlds_constraint)::in, list(hlds_constraint)::out, bool::out) - is det. + tvarset::in, tvarset::out, + constraint_proof_map::in, constraint_proof_map::out, + constraint_map::in, constraint_map::out, + redundant_constraints::in, redundant_constraints::out, + list(hlds_constraint)::in, list(hlds_constraint)::out, + list(hlds_constraint)::in, list(hlds_constraint)::out, bool::out) is det. apply_instance_rules_2(_, _, !TVarSet, !Proofs, !ConstraintMap, !Redundant, - !Seen, [], [], no). + !Seen, [], [], no). apply_instance_rules_2(ClassTable, InstanceTable, !TVarSet, !Proofs, - !ConstraintMap, !Redundant, !Seen, [C | Cs], Constraints, - Changed) :- - C = constraint(_, ClassName, Types), - list__length(Types, Arity), - map__lookup(InstanceTable, class_id(ClassName, Arity), Instances), - InitialTVarSet = !.TVarSet, - ( - find_matching_instance_rule(Instances, C, !TVarSet, !Proofs, - NewConstraints0) - -> - update_constraint_map(C, !ConstraintMap), - % Remove any constraints we've already seen. - % This ensures we don't get into an infinite loop. - list__filter(matches_no_constraint(!.Seen), NewConstraints0, - NewConstraints), - update_redundant_constraints(ClassTable, !.TVarSet, - NewConstraints, !Redundant), - % Put the new constraints at the front of the list - !:Seen = NewConstraints ++ !.Seen, - Changed1 = yes - ; - % Put the old constraint at the front of the list - NewConstraints = [C], - !:TVarSet = InitialTVarSet, - Changed1 = no - ), - apply_instance_rules_2(ClassTable, InstanceTable, !TVarSet, !Proofs, - !ConstraintMap, !Redundant, !Seen, Cs, TailConstraints, - Changed2), - bool__or(Changed1, Changed2, Changed), - list__append(NewConstraints, TailConstraints, Constraints). + !ConstraintMap, !Redundant, !Seen, [C | Cs], Constraints, Changed) :- + C = constraint(_, ClassName, Types), + list__length(Types, Arity), + map__lookup(InstanceTable, class_id(ClassName, Arity), Instances), + InitialTVarSet = !.TVarSet, + ( + find_matching_instance_rule(Instances, C, !TVarSet, !Proofs, + NewConstraints0) + -> + update_constraint_map(C, !ConstraintMap), + % Remove any constraints we've already seen. + % This ensures we don't get into an infinite loop. + list__filter(matches_no_constraint(!.Seen), NewConstraints0, + NewConstraints), + update_redundant_constraints(ClassTable, !.TVarSet, + NewConstraints, !Redundant), + % Put the new constraints at the front of the list. + !:Seen = NewConstraints ++ !.Seen, + Changed1 = yes + ; + % Put the old constraint at the front of the list. + NewConstraints = [C], + !:TVarSet = InitialTVarSet, + Changed1 = no + ), + apply_instance_rules_2(ClassTable, InstanceTable, !TVarSet, !Proofs, + !ConstraintMap, !Redundant, !Seen, Cs, TailConstraints, Changed2), + bool__or(Changed1, Changed2, Changed), + list__append(NewConstraints, TailConstraints, Constraints). :- pred matches_no_constraint(list(hlds_constraint)::in, hlds_constraint::in) - is semidet. + is semidet. matches_no_constraint(Seen, Constraint) :- - \+ (some [S] ( - list__member(S, Seen), - matching_constraints(S, Constraint) - )). + \+ ( some [S] ( + list__member(S, Seen), + matching_constraints(S, Constraint) + )). - % We take the first matching instance rule that we can find; any - % overlapping instance declarations will have been caught earlier. - % - % This pred also catches tautological constraints since the - % NewConstraints will be []. - % - % XXX Surely we shouldn't need to rename the variables and return - % a new varset: this substitution should have been worked out before, - % as these varsets would already have been merged. - % + % We take the first matching instance rule that we can find; any + % overlapping instance declarations will have been caught earlier. + % + % This pred also catches tautological constraints since the + % NewConstraints will be []. + % + % XXX Surely we shouldn't need to rename the variables and return + % a new varset: this substitution should have been worked out before, + % as these varsets would already have been merged. + % :- pred find_matching_instance_rule(list(hlds_instance_defn)::in, - hlds_constraint::in, tvarset::in, tvarset::out, - constraint_proof_map::in, constraint_proof_map::out, - list(hlds_constraint)::out) is semidet. + hlds_constraint::in, tvarset::in, tvarset::out, + constraint_proof_map::in, constraint_proof_map::out, + list(hlds_constraint)::out) is semidet. find_matching_instance_rule(Instances, Constraint, !TVarSet, !Proofs, - NewConstraints) :- - % Start a counter so we remember which instance decl we have used. - find_matching_instance_rule_2(Instances, 1, Constraint, !TVarSet, - !Proofs, NewConstraints). + NewConstraints) :- + % Start a counter so we remember which instance decl we have used. + find_matching_instance_rule_2(Instances, 1, Constraint, !TVarSet, + !Proofs, NewConstraints). :- pred find_matching_instance_rule_2(list(hlds_instance_defn)::in, int::in, - hlds_constraint::in, tvarset::in, tvarset::out, - constraint_proof_map::in, constraint_proof_map::out, - list(hlds_constraint)::out) is semidet. + hlds_constraint::in, tvarset::in, tvarset::out, + constraint_proof_map::in, constraint_proof_map::out, + list(hlds_constraint)::out) is semidet. find_matching_instance_rule_2([Instance | Instances], InstanceNum0, Constraint, - !TVarSet, !Proofs, NewConstraints) :- - Constraint = constraint(_Ids, _Name, Types), - ProgConstraints0 = Instance ^ instance_constraints, - InstanceTypes0 = Instance ^ instance_types, - InstanceTVarSet = Instance ^ instance_tvarset, - tvarset_merge_renaming(!.TVarSet, InstanceTVarSet, NewTVarSet, - Renaming), - apply_variable_renaming_to_type_list(Renaming, InstanceTypes0, - InstanceTypes), - ( - type_list_subsumes(InstanceTypes, Types, Subst) - -> - !:TVarSet = NewTVarSet, - apply_variable_renaming_to_prog_constraint_list(Renaming, - ProgConstraints0, ProgConstraints1), - apply_rec_subst_to_prog_constraint_list(Subst, - ProgConstraints1, ProgConstraints), - init_hlds_constraint_list(ProgConstraints, NewConstraints), + !TVarSet, !Proofs, NewConstraints) :- + Constraint = constraint(_Ids, _Name, Types), + ProgConstraints0 = Instance ^ instance_constraints, + InstanceTypes0 = Instance ^ instance_types, + InstanceTVarSet = Instance ^ instance_tvarset, + tvarset_merge_renaming(!.TVarSet, InstanceTVarSet, NewTVarSet, Renaming), + apply_variable_renaming_to_type_list(Renaming, InstanceTypes0, + InstanceTypes), + ( + type_list_subsumes(InstanceTypes, Types, Subst) + -> + !:TVarSet = NewTVarSet, + apply_variable_renaming_to_prog_constraint_list(Renaming, + ProgConstraints0, ProgConstraints1), + apply_rec_subst_to_prog_constraint_list(Subst, + ProgConstraints1, ProgConstraints), + init_hlds_constraint_list(ProgConstraints, NewConstraints), - NewProof = apply_instance(InstanceNum0), - retrieve_prog_constraint(Constraint, ProgConstraint), - map__set(!.Proofs, ProgConstraint, NewProof, !:Proofs) - ; - InstanceNum = InstanceNum0 + 1, - find_matching_instance_rule_2(Instances, InstanceNum, - Constraint, !TVarSet, !Proofs, NewConstraints) - ). + NewProof = apply_instance(InstanceNum0), + retrieve_prog_constraint(Constraint, ProgConstraint), + map__set(!.Proofs, ProgConstraint, NewProof, !:Proofs) + ; + InstanceNum = InstanceNum0 + 1, + find_matching_instance_rule_2(Instances, InstanceNum, + Constraint, !TVarSet, !Proofs, NewConstraints) + ). - % To reduce a constraint using class declarations, we search the - % superclass relation to find a path from the inferred constraint to - % another (declared or inferred) constraint. - % + % To reduce a constraint using class declarations, we search the + % superclass relation to find a path from the inferred constraint to + % another (declared or inferred) constraint. + % :- pred apply_class_rules(superclass_table::in, tvarset::in, tvar_kind_map::in, - constraint_proof_map::in, constraint_proof_map::out, - constraint_map::in, constraint_map::out, - hlds_constraints::in, hlds_constraints::out, bool::out) is det. + constraint_proof_map::in, constraint_proof_map::out, + constraint_map::in, constraint_map::out, + hlds_constraints::in, hlds_constraints::out, bool::out) is det. apply_class_rules(SuperClassTable, TVarSet, KindMap, !Proofs, !ConstraintMap, - !Constraints, Changed) :- - !.Constraints = constraints(Unproven0, Assumed, _), - apply_class_rules_2(Assumed, SuperClassTable, TVarSet, KindMap, - !Proofs, !ConstraintMap, Unproven0, Unproven, Changed), - !:Constraints = !.Constraints ^ unproven := Unproven. + !Constraints, Changed) :- + !.Constraints = constraints(Unproven0, Assumed, _), + apply_class_rules_2(Assumed, SuperClassTable, TVarSet, KindMap, + !Proofs, !ConstraintMap, Unproven0, Unproven, Changed), + !:Constraints = !.Constraints ^ unproven := Unproven. :- pred apply_class_rules_2(list(hlds_constraint)::in, superclass_table::in, - tvarset::in, tvar_kind_map::in, constraint_proof_map::in, - constraint_proof_map::out, constraint_map::in, constraint_map::out, - list(hlds_constraint)::in, list(hlds_constraint)::out, - bool::out) is det. + tvarset::in, tvar_kind_map::in, constraint_proof_map::in, + constraint_proof_map::out, constraint_map::in, constraint_map::out, + list(hlds_constraint)::in, list(hlds_constraint)::out, + bool::out) is det. apply_class_rules_2(_, _, _, _, !Proofs, !ConstraintMap, [], [], no). apply_class_rules_2(AssumedConstraints, SuperClassTable, TVarSet, KindMap, - !Proofs, !ConstraintMap, [Constraint0 | Constraints0], - Constraints, Changed) :- - Parents = [], - retrieve_prog_constraint(Constraint0, ProgConstraint0), + !Proofs, !ConstraintMap, [Constraint0 | Constraints0], + Constraints, Changed) :- + Parents = [], + retrieve_prog_constraint(Constraint0, ProgConstraint0), - % The head_type_params argument contains all the variables from - % the original constraint that we are trying to prove. (These - % are the type variables that must not be bound as we search - % through the superclass relation). - % - constraint_get_tvars(ProgConstraint0, HeadTypeParams), - ( - eliminate_constraint_by_class_rules(ProgConstraint0, _, _, - AssumedConstraints, SuperClassTable, HeadTypeParams, - TVarSet, KindMap, Parents, !Proofs) - -> - update_constraint_map(Constraint0, !ConstraintMap), - apply_class_rules_2(AssumedConstraints, SuperClassTable, - TVarSet, KindMap, !Proofs, !ConstraintMap, - Constraints0, Constraints, _), - Changed = yes - ; - apply_class_rules_2(AssumedConstraints, SuperClassTable, - TVarSet, KindMap, !Proofs, !ConstraintMap, - Constraints0, TailConstraints, Changed), - Constraints = [Constraint0 | TailConstraints] - ). + % The head_type_params argument contains all the variables from the + % original constraint that we are trying to prove. (These are the type + % variables that must not be bound as we search through the superclass + % relation). + constraint_get_tvars(ProgConstraint0, HeadTypeParams), + ( + eliminate_constraint_by_class_rules(ProgConstraint0, _, _, + AssumedConstraints, SuperClassTable, HeadTypeParams, + TVarSet, KindMap, Parents, !Proofs) + -> + update_constraint_map(Constraint0, !ConstraintMap), + apply_class_rules_2(AssumedConstraints, SuperClassTable, + TVarSet, KindMap, !Proofs, !ConstraintMap, + Constraints0, Constraints, _), + Changed = yes + ; + apply_class_rules_2(AssumedConstraints, SuperClassTable, + TVarSet, KindMap, !Proofs, !ConstraintMap, + Constraints0, TailConstraints, Changed), + Constraints = [Constraint0 | TailConstraints] + ). - % eliminate_constraint_by_class_rules eliminates a class constraint - % by applying the superclass relation. A list of "parent" constraints - % is also passed in --- these are the constraints that we are - % (recursively) in the process of checking, and is used to ensure that - % we don't get into a cycle in the relation. - % + % eliminate_constraint_by_class_rules eliminates a class constraint + % by applying the superclass relation. A list of "parent" constraints + % is also passed in --- these are the constraints that we are + % (recursively) in the process of checking, and is used to ensure that + % we don't get into a cycle in the relation. + % :- pred eliminate_constraint_by_class_rules(prog_constraint::in, - prog_constraint::out, tsubst::out, list(hlds_constraint)::in, - superclass_table::in, head_type_params::in, tvarset::in, - tvar_kind_map::in, list(prog_constraint)::in, - constraint_proof_map::in, constraint_proof_map::out) is semidet. + prog_constraint::out, tsubst::out, list(hlds_constraint)::in, + superclass_table::in, head_type_params::in, tvarset::in, + tvar_kind_map::in, list(prog_constraint)::in, + constraint_proof_map::in, constraint_proof_map::out) is semidet. eliminate_constraint_by_class_rules(C, SubstC, SubClassSubst, - AssumedConstraints, SuperClassTable, HeadTypeParams, TVarSet, - KindMap, ParentConstraints, Proofs0, Proofs) :- + AssumedConstraints, SuperClassTable, HeadTypeParams, TVarSet, + KindMap, ParentConstraints, Proofs0, Proofs) :- - % Make sure we aren't in a cycle in the - % superclass relation - \+ list__member(C, ParentConstraints), + % Make sure we aren't in a cycle in the superclass relation. + \+ list__member(C, ParentConstraints), - C = constraint(SuperClassName, SuperClassTypes), - list__length(SuperClassTypes, SuperClassArity), - SuperClassId = class_id(SuperClassName, SuperClassArity), - multi_map__search(SuperClassTable, SuperClassId, SubClasses), + C = constraint(SuperClassName, SuperClassTypes), + list__length(SuperClassTypes, SuperClassArity), + SuperClassId = class_id(SuperClassName, SuperClassArity), + multi_map__search(SuperClassTable, SuperClassId, SubClasses), - % Convert all the subclass_details into prog_constraints by - % doing the appropriate variable renaming and applying the - % type variable bindings. - % If the unification of the type variables for a particular - % constraint fails then that constraint is eliminated because it - % cannot contribute to proving the constraint we are trying to - % prove. - list__filter_map( - subclass_details_to_constraint(TVarSet, KindMap, - SuperClassTypes), - SubClasses, SubClassConstraints), - ( - % Do the first level of search. We search for - % an assumed constraint which unifies with any - % of the subclass constraints. - varset__vars(TVarSet, XXXHeadTypeParams), - list.find_first_map( - match_assumed_constraint(XXXHeadTypeParams, - SubClassConstraints), - AssumedConstraints, SubClass - SubClassSubst0) - -> - SubClassSubst = SubClassSubst0, - apply_rec_subst_to_prog_constraint(SubClassSubst, C, SubstC), - map__set(Proofs0, SubstC, superclass(SubClass), Proofs) - ; - NewParentConstraints = [C | ParentConstraints], + % Convert all the subclass_details into prog_constraints by doing the + % appropriate variable renaming and applying the type variable bindings. + % If the unification of the type variables for a particular constraint + % fails then that constraint is eliminated because it cannot contribute + % to proving the constraint we are trying to prove. + list__filter_map( + subclass_details_to_constraint(TVarSet, KindMap, SuperClassTypes), + SubClasses, SubClassConstraints), + ( + % Do the first level of search. We search for an assumed constraint + % which unifies with any of the subclass constraints. + varset__vars(TVarSet, XXXHeadTypeParams), + list.find_first_map( + match_assumed_constraint(XXXHeadTypeParams, SubClassConstraints), + AssumedConstraints, SubClass - SubClassSubst0) + -> + SubClassSubst = SubClassSubst0, + apply_rec_subst_to_prog_constraint(SubClassSubst, C, SubstC), + map__set(Proofs0, SubstC, superclass(SubClass), Proofs) + ; + NewParentConstraints = [C | ParentConstraints], - % Recursively search the rest of the superclass - % relation. - SubClassSearch = (pred(Constraint::in, CnstrtAndProof::out) - is semidet :- - eliminate_constraint_by_class_rules(Constraint, - SubstConstraint, SubClassSubst0, - AssumedConstraints, SuperClassTable, - HeadTypeParams, TVarSet, KindMap, - NewParentConstraints, Proofs0, SubProofs), - CnstrtAndProof = {SubstConstraint, SubClassSubst0, - SubProofs} - ), - % XXX this could (and should) be more efficient. - % (i.e. by manually doing a "cut"). - find_first_map(SubClassSearch, SubClassConstraints, - {NewSubClass, SubClassSubst, NewProofs}), - apply_rec_subst_to_prog_constraint(SubClassSubst, C, SubstC), - map__set(NewProofs, SubstC, superclass(NewSubClass), Proofs) - ). + % Recursively search the rest of the superclass relation. + SubClassSearch = (pred(Constraint::in, CnstrtAndProof::out) + is semidet :- + eliminate_constraint_by_class_rules(Constraint, + SubstConstraint, SubClassSubst0, + AssumedConstraints, SuperClassTable, + HeadTypeParams, TVarSet, KindMap, + NewParentConstraints, Proofs0, SubProofs), + CnstrtAndProof = {SubstConstraint, SubClassSubst0, SubProofs} + ), + % XXX this could (and should) be more efficient. + % (i.e. by manually doing a "cut"). + find_first_map(SubClassSearch, SubClassConstraints, + {NewSubClass, SubClassSubst, NewProofs}), + apply_rec_subst_to_prog_constraint(SubClassSubst, C, SubstC), + map__set(NewProofs, SubstC, superclass(NewSubClass), Proofs) + ). :- pred match_assumed_constraint(head_type_params::in, - list(prog_constraint)::in, hlds_constraint::in, - pair(prog_constraint, tsubst)::out) is semidet. + list(prog_constraint)::in, hlds_constraint::in, + pair(prog_constraint, tsubst)::out) is semidet. match_assumed_constraint(HeadTypeParams, SubClassConstraints, - AssumedConstraint, Match) :- - find_first_map( - match_assumed_constraint_2(HeadTypeParams, AssumedConstraint), - SubClassConstraints, Match). + AssumedConstraint, Match) :- + find_first_map( + match_assumed_constraint_2(HeadTypeParams, AssumedConstraint), + SubClassConstraints, Match). :- pred match_assumed_constraint_2(head_type_params::in, hlds_constraint::in, - prog_constraint::in, pair(prog_constraint, tsubst)::out) is semidet. + prog_constraint::in, pair(prog_constraint, tsubst)::out) is semidet. match_assumed_constraint_2(HeadTypeParams, AssumedConstraint, - SubClassConstraint, Match) :- - AssumedConstraint = constraint(_, AssumedConstraintClass, - AssumedConstraintTypes), - SubClassConstraint = constraint(AssumedConstraintClass, - SubClassConstraintTypes), - map__init(EmptySub), - type_unify_list(SubClassConstraintTypes, AssumedConstraintTypes, - HeadTypeParams, EmptySub, AssumedConstraintSub), - retrieve_prog_constraint(AssumedConstraint, MatchingProgConstraint), - Match = MatchingProgConstraint - AssumedConstraintSub. + SubClassConstraint, Match) :- + AssumedConstraint = constraint(_, AssumedConstraintClass, + AssumedConstraintTypes), + SubClassConstraint = constraint(AssumedConstraintClass, + SubClassConstraintTypes), + map__init(EmptySub), + type_unify_list(SubClassConstraintTypes, AssumedConstraintTypes, + HeadTypeParams, EmptySub, AssumedConstraintSub), + retrieve_prog_constraint(AssumedConstraint, MatchingProgConstraint), + Match = MatchingProgConstraint - AssumedConstraintSub. - % subclass_details_to_constraint will fail iff the call to - % type_unify_list fails. - % + % subclass_details_to_constraint will fail iff the call to + % type_unify_list fails. + % :- pred subclass_details_to_constraint(tvarset::in, tvar_kind_map::in, - list(type)::in, subclass_details::in, prog_constraint::out) is semidet. + list(type)::in, subclass_details::in, prog_constraint::out) is semidet. subclass_details_to_constraint(TVarSet, KindMap0, SuperClassTypes, - SubClassDetails, SubC) :- - SubClassDetails = subclass_details(SuperVars0, SubID, SubVars0, - SuperVarSet), + SubClassDetails, SubC) :- + SubClassDetails = subclass_details(SuperVars0, SubID, SubVars0, + SuperVarSet), - % Rename the variables from the typeclass - % declaration into those of the current pred. - tvarset_merge_renaming(TVarSet, SuperVarSet, _NewTVarSet, Renaming), - apply_variable_renaming_to_tvar_kind_map(Renaming, KindMap0, KindMap), - apply_variable_renaming_to_tvar_list(Renaming, SubVars0, SubVars), - apply_variable_renaming_to_type_list(Renaming, SuperVars0, SuperVars), + % Rename the variables from the typeclass declaration into those + % of the current pred. + tvarset_merge_renaming(TVarSet, SuperVarSet, _NewTVarSet, Renaming), + apply_variable_renaming_to_tvar_kind_map(Renaming, KindMap0, KindMap), + apply_variable_renaming_to_tvar_list(Renaming, SubVars0, SubVars), + apply_variable_renaming_to_type_list(Renaming, SuperVars0, SuperVars), - % Work out what the (renamed) vars from the - % typeclass declaration are bound to here. - type_unify_list(SuperVars, SuperClassTypes, [], map__init, Bindings), - SubID = class_id(SubName, _SubArity), - apply_rec_subst_to_tvar_list(KindMap, Bindings, SubVars, - SubClassTypes), - SubC = constraint(SubName, SubClassTypes). + % Work out what the (renamed) vars from the typeclass declaration + % are bound to here. + type_unify_list(SuperVars, SuperClassTypes, [], map__init, Bindings), + SubID = class_id(SubName, _SubArity), + apply_rec_subst_to_tvar_list(KindMap, Bindings, SubVars, + SubClassTypes), + SubC = constraint(SubName, SubClassTypes). - % check_satisfiability(Constraints, HeadTypeParams): - % Check that all of the constraints are satisfiable. - % Fail if any are definitely not satisfiable. - % - % We disallow ground constraints - % for which there are no matching instance rules, - % even though the module system means that it would - % make sense to allow them: even if there - % is no instance declaration visible in the current - % module, there may be one visible in the caller. - % The reason we disallow them is that in practice - % allowing this causes type inference to let too - % many errors slip through, with the error diagnosis - % being too far removed from the real cause of the - % error. Note that ground constraints *are* allowed - % if you declare them, since we removed declared - % constraints before checking satisfiability. - % - % Similarly, for constraints on head type params - % (universally quantified type vars in this pred's type decl, - % or existentially quantified type vars in type decls for - % callees), we know that the head type params can never get bound. - % This means that if the constraint wasn't an assumed constraint - % and can't be eliminated by instance rule or class rule - % application, then we can report an error now, rather than - % later. (For non-head-type-param type variables, - % we need to wait, in case the type variable gets bound - % to a type for which there is a valid instance declaration.) - % - % So a constraint is considered satisfiable iff it - % contains at least one type variable that is not in the - % head type params. - % + % check_satisfiability(Constraints, HeadTypeParams): + % + % Check that all of the constraints are satisfiable. Fail if any are + % definitely not satisfiable. + % + % We disallow ground constraints for which there are no matching instance + % rules, even though the module system means that it would make sense + % to allow them: even if there is no instance declaration visible + % in the current module, there may be one visible in the caller. The reason + % we disallow them is that in practice allowing this causes type inference + % to let too many errors slip through, with the error diagnosis being + % too far removed from the real cause of the error. Note that ground + % constraints *are* allowed if you declare them, since we removed declared + % constraints before checking satisfiability. + % + % Similarly, for constraints on head type params (universally quantified + % type vars in this pred's type decl, or existentially quantified type vars + % in type decls for callees), we know that the head type params can + % never get bound. This means that if the constraint wasn't an assumed + % constraint and can't be eliminated by instance rule or class rule + % application, then we can report an error now, rather than later. + % (For non-head-type-param type variables, we need to wait, in case + % the type variable gets bound to a type for which there is a valid + % instance declaration.) + % + % So a constraint is considered satisfiable iff it contains at least one + % type variable that is not in the head type params. + % :- pred check_satisfiability(list(hlds_constraint)::in, head_type_params::in) - is semidet. + is semidet. check_satisfiability(Constraints, HeadTypeParams) :- - all [Constraint] ( - list__member(Constraint, Constraints) - => - ( - Constraint = constraint(_Ids, _ClassName, Types), - type_list_contains_var(Types, TVar), - not list__member(TVar, HeadTypeParams) - ) - ). + all [Constraint] ( + list__member(Constraint, Constraints) + => + ( + Constraint = constraint(_Ids, _ClassName, Types), + type_list_contains_var(Types, TVar), + not list__member(TVar, HeadTypeParams) + ) + ). %-----------------------------------------------------------------------------% :- end_module check_hlds.typeclasses. diff --git a/compiler/unique_modes.m b/compiler/unique_modes.m index 9e89d7fa6..2ac733145 100644 --- a/compiler/unique_modes.m +++ b/compiler/unique_modes.m @@ -593,7 +593,7 @@ check_call_modes(ArgVars, ProcArgModes, ArgOffset, Determinism, NeverSucceeds, modecheck_var_has_inst_list(ArgVars, InitialInsts, NeedExactMatch, ArgOffset, InstVarSub, !ModeInfo), mode_list_get_final_insts(ModuleInfo, ProcArgModes, FinalInsts0), - inst_list_apply_substitution(FinalInsts0, InstVarSub, FinalInsts), + inst_list_apply_substitution(InstVarSub, FinalInsts0, FinalInsts), modecheck_set_var_inst_list(ArgVars, InitialInsts, FinalInsts, ArgOffset, NewArgVars, ExtraGoals, !ModeInfo), ( diff --git a/compiler/wrap_blocks.m b/compiler/wrap_blocks.m index 5f12b6d06..3ba37e0a5 100644 --- a/compiler/wrap_blocks.m +++ b/compiler/wrap_blocks.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 2001, 2003, 2005 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. @@ -25,8 +27,7 @@ :- import_module list. -:- pred wrap_blocks(list(instruction)::in, list(instruction)::out) - is det. +:- pred wrap_blocks(list(instruction)::in, list(instruction)::out) is det. :- implementation. @@ -38,57 +39,55 @@ :- import_module std_util. wrap_blocks(Instrs0, Instrs) :- - wrap_instrs(Instrs0, 0, 0, [], Instrs). + wrap_instrs(Instrs0, 0, 0, [], Instrs). - % R is the number of the highest numbered tempr variable seen so far; - % R = 0 means we haven't seen any temp variables. Similarly, F is the - % highest numbered tempf variable seen so far. RevSofar is a - % reversed list of instructions starting with the first instruction - % in this block that accesses a temp variable. Invariant: RevSofar - % is always empty if R = 0 and F = 0. + % R is the number of the highest numbered tempr variable seen so far; + % R = 0 means we haven't seen any temp variables. Similarly, F is the + % highest numbered tempf variable seen so far. RevSofar is a + % reversed list of instructions starting with the first instruction + % in this block that accesses a temp variable. Invariant: RevSofar + % is always empty if R = 0 and F = 0. :- pred wrap_instrs(list(instruction)::in, int::in, int::in, - list(instruction)::in, list(instruction)::out) is det. + list(instruction)::in, list(instruction)::out) is det. wrap_instrs([], R, F, RevSofar, []) :- - ( RevSofar = [_|_] -> - error("procedure ends with fallthrough") - ; ( R > 0 ; F > 0 ) -> - error("procedure ends without closing block") - ; - true - ). + ( RevSofar = [_ | _] -> + error("procedure ends with fallthrough") + ; ( R > 0 ; F > 0 ) -> + error("procedure ends without closing block") + ; + true + ). wrap_instrs([Instr0 | Instrs0], R0, F0, RevSofar, Instrs) :- - Instr0 = Uinstr0 - _Comment0, - opt_util__count_temps_instr(Uinstr0, R0, R1, F0, F1), - ( ( R1 > 0 ; F1 > 0) -> - % We must close the block before a label, since you can jump - % to a label from other blocks. - % - % Call instructions cannot fall through, but they cannot refer - % to the temp variables declared by the block either, so we - % close the block either just before or just after the call - % instruction. We close the block before the call instruction, - % because including it in the block causes the test case - % debugger/all_solutions to fail. + Instr0 = Uinstr0 - _Comment0, + opt_util__count_temps_instr(Uinstr0, R0, R1, F0, F1), + ( ( R1 > 0 ; F1 > 0) -> + % We must close the block before a label, since you can jump + % to a label from other blocks. + % + % Call instructions cannot fall through, but they cannot refer + % to the temp variables declared by the block either, so we + % close the block either just before or just after the call + % instruction. We close the block before the call instruction, + % because including it in the block causes the test case + % debugger/all_solutions to fail. - ( ( Uinstr0 = label(_) ; Uinstr0 = call(_, _, _, _, _, _) ) -> - list__reverse(RevSofar, BlockInstrs), - wrap_instrs(Instrs0, 0, 0, [], Instrs1), - Instrs = [block(R1, F1, BlockInstrs) - "", Instr0 - | Instrs1] - ; opt_util__can_instr_fall_through(Uinstr0, no) -> - list__reverse([Instr0 | RevSofar], BlockInstrs), - wrap_instrs(Instrs0, 0, 0, [], Instrs1), - Instrs = [block(R1, F1, BlockInstrs) - "" | Instrs1] - ; - wrap_instrs(Instrs0, R1, F1, - [Instr0 | RevSofar], Instrs) - ) - ; - wrap_instrs(Instrs0, 0, 0, [], Instrs1), - Instrs = [Instr0 | Instrs1] - ). + ( ( Uinstr0 = label(_) ; Uinstr0 = call(_, _, _, _, _, _) ) -> + list__reverse(RevSofar, BlockInstrs), + wrap_instrs(Instrs0, 0, 0, [], Instrs1), + Instrs = [block(R1, F1, BlockInstrs) - "", Instr0 | Instrs1] + ; opt_util__can_instr_fall_through(Uinstr0, no) -> + list__reverse([Instr0 | RevSofar], BlockInstrs), + wrap_instrs(Instrs0, 0, 0, [], Instrs1), + Instrs = [block(R1, F1, BlockInstrs) - "" | Instrs1] + ; + wrap_instrs(Instrs0, R1, F1, [Instr0 | RevSofar], Instrs) + ) + ; + wrap_instrs(Instrs0, 0, 0, [], Instrs1), + Instrs = [Instr0 | Instrs1] + ). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% diff --git a/mdbcomp/mdbcomp.m b/mdbcomp/mdbcomp.m index 2a9952dd5..72e9e731e 100644 --- a/mdbcomp/mdbcomp.m +++ b/mdbcomp/mdbcomp.m @@ -1,4 +1,6 @@ %---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0 +%---------------------------------------------------------------------------% % Copyright (C) 2003, 2005 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. @@ -31,17 +33,17 @@ % See library/library.m for why we implement this predicate this way. :- pragma foreign_proc("C", - mdbcomp__version(Version::out), - [will_not_call_mercury, promise_pure, thread_safe], + mdbcomp__version(Version::out), + [will_not_call_mercury, promise_pure, thread_safe], " - MR_ConstString version_string; + MR_ConstString version_string; - version_string = MR_VERSION "", configured for "" MR_FULLARCH; - /* - ** Cast away const needed here, because Mercury declares Version - ** with type MR_String rather than MR_ConstString. - */ - Version = (MR_String) (MR_Word) version_string; + version_string = MR_VERSION "", configured for "" MR_FULLARCH; + /* + ** Cast away const needed here, because Mercury declares Version + ** with type MR_String rather than MR_ConstString. + */ + Version = (MR_String) (MR_Word) version_string; "). mdbcomp__version("unknown version"). diff --git a/mdbcomp/program_representation.m b/mdbcomp/program_representation.m index 697ef1a63..a2e9397a8 100644 --- a/mdbcomp/program_representation.m +++ b/mdbcomp/program_representation.m @@ -1,4 +1,6 @@ %-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% % Copyright (C) 2001-2005 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. @@ -35,171 +37,165 @@ :- import_module char, list, std_util, bool. - % A representation of the goal we execute. These need to be - % generated statically and stored inside the executable. - % - % Each element of this structure will correspond one-to-one - % to the original stage 90 HLDS. + % A representation of the goal we execute. These need to be generated + % statically and stored inside the executable. + % + % Each element of this structure will correspond one-to-one + % to the original stage 90 HLDS. :- type proc_rep - ---> proc_rep( - list(var_rep), % The head variables, in order, - % including the ones introduced - % by the compiler. - goal_rep % The procedure body. - ). + ---> proc_rep( + list(var_rep), % The head variables, in order, + % including the ones introduced + % by the compiler. + goal_rep % The procedure body. + ). :- type goal_rep - ---> conj_rep( - list(goal_rep) % The conjuncts in the original - % order. - ) - ; disj_rep( - list(goal_rep) % The disjuncts in the original - % order. - ) - ; switch_rep( - list(goal_rep) % The switch arms in the - % original order. - ) - ; ite_rep( - goal_rep, % Condition. - goal_rep, % Then branch. - goal_rep % Else branch. - ) - ; negation_rep( - goal_rep % The negated goal. - ) - ; scope_rep( - goal_rep, % The quantified goal. - maybe_cut - ) - ; atomic_goal_rep( - detism_rep, - string, % Filename of context. - int, % Line number of context. - list(var_rep), % The sorted list of the - % variables bound by the - % atomic goal. - atomic_goal_rep - ). + ---> conj_rep( + list(goal_rep) % The conjuncts in the original order. + ) + ; disj_rep( + list(goal_rep) % The disjuncts in the original order. + ) + ; switch_rep( + list(goal_rep) % The switch arms in the original order. + ) + ; ite_rep( + goal_rep, % Condition. + goal_rep, % Then branch. + goal_rep % Else branch. + ) + ; negation_rep( + goal_rep % The negated goal. + ) + ; scope_rep( + goal_rep, % The quantified goal. + maybe_cut + ) + ; atomic_goal_rep( + detism_rep, + string, % Filename of context. + int, % Line number of context. + list(var_rep), % The sorted list of the variables + % bound by the atomic goal. + atomic_goal_rep + ). :- type atomic_goal_rep - ---> unify_construct_rep( - var_rep, - cons_id_rep, - list(var_rep) - ) - ; unify_deconstruct_rep( - var_rep, - cons_id_rep, - list(var_rep) - ) - % - % A partial deconstruction of the form - % X = f(Y_1, Y_2, ..., Y_n) - % where X is more instanciated after the unification - % than before. - % - ; partial_deconstruct_rep( - var_rep, % X - cons_id_rep, % f - % The list of Y_i's. Y_i's which are - % input are wrapped in `yes', while the other - % Y_i positions are `no'. - list(maybe(var_rep)) - ) - % - % A partial construction of the form - % X = f(Y_1, Y_2, ..., Y_n) - % where X is free before the unification and bound, - % but not ground, after the unification. - % - ; partial_construct_rep( - var_rep, % X - cons_id_rep, % f - % The list of Y_i's. Y_i's which are - % input are wrapped in `yes', while the other - % Y_i positions are `no'. - list(maybe(var_rep)) - ) - ; unify_assign_rep( - var_rep, % target - var_rep % source - ) - ; cast_rep( - var_rep, % target - var_rep % source - ) - ; unify_simple_test_rep( - var_rep, - var_rep - ) - ; pragma_foreign_code_rep( - list(var_rep) % arguments - ) - ; higher_order_call_rep( - var_rep, % the closure to call - list(var_rep) % the call's plain arguments - ) - ; method_call_rep( - var_rep, % typeclass info var - int, % method number - list(var_rep) % the call's plain arguments - ) - ; plain_call_rep( - string, % name of called pred's module - string, % name of the called pred - list(var_rep) % the call's arguments - ) - ; builtin_call_rep( - string, % name of called pred's module - string, % name of the called pred - list(var_rep) % the call's arguments - ). + ---> unify_construct_rep( + var_rep, + cons_id_rep, + list(var_rep) + ) + ; unify_deconstruct_rep( + var_rep, + cons_id_rep, + list(var_rep) + ) + ; partial_deconstruct_rep( + % A partial deconstruction of the form + % X = f(Y_1, Y_2, ..., Y_n) + % where X is more instanciated after the unification + % than before. + var_rep, % X + cons_id_rep, % f + list(maybe(var_rep)) + % The list of Y_i's. Y_i's which are input + % are wrapped in `yes', while the other + % Y_i positions are `no'. + ) + ; partial_construct_rep( + % A partial construction of the form + % X = f(Y_1, Y_2, ..., Y_n) + % where X is free before the unification and bound, + % but not ground, after the unification. + var_rep, % X + cons_id_rep, % f + list(maybe(var_rep)) + % The list of Y_i's. Y_i's which are input + % are wrapped in `yes', while the other + % Y_i positions are `no'. + ) + ; unify_assign_rep( + var_rep, % target + var_rep % source + ) + ; cast_rep( + var_rep, % target + var_rep % source + ) + ; unify_simple_test_rep( + var_rep, + var_rep + ) + ; pragma_foreign_code_rep( + list(var_rep) % arguments + ) + ; higher_order_call_rep( + var_rep, % the closure to call + list(var_rep) % the call's plain arguments + ) + ; method_call_rep( + var_rep, % typeclass info var + int, % method number + list(var_rep) % the call's plain arguments + ) + ; plain_call_rep( + string, % name of called pred's module + string, % name of the called pred + list(var_rep) % the call's arguments + ) + ; builtin_call_rep( + string, % name of called pred's module + string, % name of the called pred + list(var_rep) % the call's arguments + ). -:- type var_rep == int. +:- type var_rep == int. -:- type cons_id_rep == string. +:- type cons_id_rep == string. :- type detism_rep - ---> det_rep - ; semidet_rep - ; nondet_rep - ; multidet_rep - ; cc_nondet_rep - ; cc_multidet_rep - ; erroneous_rep - ; failure_rep. + ---> det_rep + ; semidet_rep + ; nondet_rep + ; multidet_rep + ; cc_nondet_rep + ; cc_multidet_rep + ; erroneous_rep + ; failure_rep. - % If the given atomic goal behaves like a call in the sense that it - % generates events, then return the list of variables that are passed - % as arguments. - % + % If the given atomic goal behaves like a call in the sense that it + % generates events, then return the list of variables that are passed + % as arguments. + % :- func atomic_goal_generates_event(atomic_goal_rep) = maybe(list(var_rep)). - % If the given goal generates internal events directly then this - % function will return yes and no otherwise. - % + % If the given goal generates internal events directly then this + % function will return yes and no otherwise. + % :- func goal_generates_internal_event(goal_rep) = bool. - % call_is_primitive(ModuleName, PredName): succeeds iff a call to the - % named predicate behaves like a primitive operation, in the sense that - % it does not generate events. + % call_is_primitive(ModuleName, PredName): succeeds iff a call to the + % named predicate behaves like a primitive operation, in the sense that + % it does not generate events. + % :- pred call_is_primitive(string::in, string::in) is semidet. - % The atomic goals module, name and arity + % The atomic goal's module, name and arity. :- type atomic_goal_id - ---> atomic_goal_id(string, string, int). + ---> atomic_goal_id(string, string, int). - % Can we find out the atomic goals name, module and arity from - % its atomic_goal_rep? If so return them, otherwise return no. + % Can we find out the atomic goals name, module and arity from + % its atomic_goal_rep? If so return them, otherwise return no. + % :- func atomic_goal_identifiable(atomic_goal_rep) = - maybe(atomic_goal_id). + maybe(atomic_goal_id). %-----------------------------------------------------------------------------% - % The following three types are derived from compiler/hlds_goal.m. + % The following three types are derived from compiler/hlds_goal.m. :- type goal_path == list(goal_path_step). @@ -208,74 +204,76 @@ :- type goal_path_string == string. -:- type goal_path_step ---> conj(int) - ; disj(int) - ; switch(int) - ; ite_cond - ; ite_then - ; ite_else - ; neg - ; scope(maybe_cut) - ; first - ; later. +:- type goal_path_step + ---> conj(int) + ; disj(int) + ; switch(int) + ; ite_cond + ; ite_then + ; ite_else + ; neg + ; scope(maybe_cut) + ; first + ; later. - % Does the scope goal have a different determinism inside than outside? -:- type maybe_cut ---> cut ; no_cut. + % Does the scope goal have a different determinism inside than outside? +:- type maybe_cut + ---> cut + ; no_cut. -:- pred path_from_string_det(string, goal_path). -:- mode path_from_string_det(in, out) is det. +:- pred path_from_string_det(string::in, goal_path::out) is det. :- pred string_from_path(goal_path::in, string::out) is det. -:- pred path_from_string(string, goal_path). -:- mode path_from_string(in, out) is semidet. +:- pred path_from_string(string::in, goal_path::out) is semidet. -:- pred path_step_from_string(string, goal_path_step). -:- mode path_step_from_string(in, out) is semidet. +:- pred path_step_from_string(string::in, goal_path_step::out) is semidet. -:- pred is_path_separator(char). -:- mode is_path_separator(in) is semidet. +:- pred is_path_separator(char::in) is semidet. - % User-visible head variables are represented by a number from 1..N, - % where N is the user-visible arity. - % - % Both user-visible and compiler-generated head variables can be - % referred to via their position in the full list of head variables; - % the first head variable is at position 1. + % User-visible head variables are represented by a number from 1..N, + % where N is the user-visible arity. + % + % Both user-visible and compiler-generated head variables can be + % referred to via their position in the full list of head variables; + % the first head variable is at position 1. :- type arg_pos - ---> user_head_var(int) % Nth in the list of arguments after - % filtering out non-user-visible vars. - ; any_head_var(int) % Nth in the list of all arguments. + ---> user_head_var(int) % Nth in the list of arguments after + % filtering out non-user-visible vars. + ; any_head_var(int) % Nth in the list of all arguments. - % (M-N+1)th argument in the list of all arguments, - % where N is the value of the int in the constructor - % and M is the total number of arguments. - ; any_head_var_from_back(int). + ; any_head_var_from_back(int). + % (M-N+1)th argument in the list of all + % arguments, where N is the value of the int + % in the constructor and M is the total number + % of arguments. - % A particular subterm within a term is represented by a term_path. - % This is the list of argument positions that need to be followed - % in order to travel from the root to the subterm. In contrast to - % goal_paths, this list is in top-down order. + % A particular subterm within a term is represented by a term_path. + % This is the list of argument positions that need to be followed + % in order to travel from the root to the subterm. In contrast to + % goal_paths, this list is in top-down order. +:- type term_path == list(int). -:- type term_path == list(int). - - % Returns type_of(_ `with_type` proc_rep), for use in C code. + % Returns type_of(_ `with_type` proc_rep), for use in C code. + % :- func proc_rep_type = type_desc. - % Returns type_of(_ `with_type` goal_rep), for use in C code. + % Returns type_of(_ `with_type` goal_rep), for use in C code. + % :- func goal_rep_type = type_desc. - % Construct a representation of the interface determinism of a - % procedure. The code we have chosen is not sequential; instead - % it encodes the various properties of each determinism. - % This must match the encoding of MR_Determinism in - % mercury_stack_layout.h. - % - % The 8 bit is set iff the context is first_solution. - % The 4 bit is set iff the min number of solutions is more than zero. - % The 2 bit is set iff the max number of solutions is more than zero. - % The 1 bit is set iff the max number of solutions is more than one. + % Construct a representation of the interface determinism of a + % procedure. The code we have chosen is not sequential; instead + % it encodes the various properties of each determinism. + % This must match the encoding of MR_Determinism in + % mercury_stack_layout.h. + % + % The 8 bit is set iff the context is first_solution. + % The 4 bit is set iff the min number of solutions is more than zero. + % The 2 bit is set iff the max number of solutions is more than zero. + % The 1 bit is set iff the max number of solutions is more than one. + % :- func detism_rep(detism_rep) = int. :- pred determinism_representation(detism_rep, int). @@ -283,35 +281,35 @@ :- mode determinism_representation(out, in) is semidet. :- type bytecode_goal_type - ---> goal_conj - ; goal_disj - ; goal_switch - ; goal_ite - ; goal_neg - ; goal_scope - ; goal_construct - ; goal_deconstruct - ; goal_partial_construct - ; goal_partial_deconstruct - ; goal_assign - ; goal_cast - ; goal_simple_test - ; goal_foreign - ; goal_ho_call - ; goal_method_call - ; goal_plain_call - ; goal_builtin_call. + ---> goal_conj + ; goal_disj + ; goal_switch + ; goal_ite + ; goal_neg + ; goal_scope + ; goal_construct + ; goal_deconstruct + ; goal_partial_construct + ; goal_partial_deconstruct + ; goal_assign + ; goal_cast + ; goal_simple_test + ; goal_foreign + ; goal_ho_call + ; goal_method_call + ; goal_plain_call + ; goal_builtin_call. :- func goal_type_to_byte(bytecode_goal_type) = int. :- func byte_to_goal_type(int) = bytecode_goal_type is semidet. - % A variable number is represented in a byte if there are no more than - % 255 variables in the procedure. Otherwise a short is used. - % + % A variable number is represented in a byte if there are no more than + % 255 variables in the procedure. Otherwise a short is used. + % :- type var_num_rep - ---> byte - ; short. + ---> byte + ; short. :- pred var_num_rep_byte(var_num_rep, int). :- mode var_num_rep_byte(in, out) is det. @@ -339,29 +337,29 @@ atomic_goal_generates_event(higher_order_call_rep(_, Args)) = yes(Args). atomic_goal_generates_event(method_call_rep(_, _, Args)) = yes(Args). atomic_goal_generates_event(builtin_call_rep(_, _, _)) = no. atomic_goal_generates_event(plain_call_rep(ModuleName, PredName, Args)) = - ( call_is_primitive(ModuleName, PredName) -> - % These calls behave as primitives and do not generate events. - no - ; - yes(Args) - ). + ( call_is_primitive(ModuleName, PredName) -> + % These calls behave as primitives and do not generate events. + no + ; + yes(Args) + ). call_is_primitive(ModuleName, PredName) :- - ( - string_to_sym_name(ModuleName, ".", SymModuleName), - any_mercury_builtin_module(SymModuleName) - ; - % - % The following are also treated as primitive since - % compiler generated predicate events are not - % included in the annotated trace at the moment. - % - PredName = "__Unify__" - ; - PredName = "__Index__" - ; - PredName = "__Compare__" - ). + ( + string_to_sym_name(ModuleName, ".", SymModuleName), + any_mercury_builtin_module(SymModuleName) + ; + % The following are also treated as primitive since events from + % compiler generated predicates are not included in the annotated trace + % at the moment. + ( + PredName = "__Unify__" + ; + PredName = "__Index__" + ; + PredName = "__Compare__" + ) + ). goal_generates_internal_event(conj_rep(_)) = no. goal_generates_internal_event(disj_rep(_)) = yes. @@ -383,9 +381,9 @@ atomic_goal_identifiable(pragma_foreign_code_rep(_)) = no. atomic_goal_identifiable(higher_order_call_rep(_, _)) = no. atomic_goal_identifiable(method_call_rep(_, _, _)) = no. atomic_goal_identifiable(builtin_call_rep(Module, Name, Args)) = - yes(atomic_goal_id(Module, Name, length(Args))). + yes(atomic_goal_id(Module, Name, length(Args))). atomic_goal_identifiable(plain_call_rep(Module, Name, Args)) = - yes(atomic_goal_id(Module, Name, length(Args))). + yes(atomic_goal_id(Module, Name, length(Args))). :- pragma export(proc_rep_type = out, "ML_proc_rep_type"). @@ -398,29 +396,29 @@ goal_rep_type = type_of(_ `with_type` goal_rep). %-----------------------------------------------------------------------------% path_from_string_det(GoalPathStr, GoalPath) :- - ( path_from_string(GoalPathStr, GoalPathPrime) -> - GoalPath = GoalPathPrime - ; - error("path_from_string_det: path_from_string failed") - ). + ( path_from_string(GoalPathStr, GoalPathPrime) -> + GoalPath = GoalPathPrime + ; + error("path_from_string_det: path_from_string failed") + ). path_from_string(GoalPathStr, GoalPath) :- - StepStrs = string__words(is_path_separator, GoalPathStr), - list__map(path_step_from_string, StepStrs, GoalPath). + StepStrs = string__words(is_path_separator, GoalPathStr), + list__map(path_step_from_string, StepStrs, GoalPath). path_step_from_string(String, Step) :- - string__first_char(String, First, Rest), - path_step_from_string_2(First, Rest, Step). + string__first_char(String, First, Rest), + path_step_from_string_2(First, Rest, Step). :- pred path_step_from_string_2(char::in, string::in, goal_path_step::out) - is semidet. + is semidet. path_step_from_string_2('c', NStr, conj(N)) :- - string__to_int(NStr, N). + string__to_int(NStr, N). path_step_from_string_2('d', NStr, disj(N)) :- - string__to_int(NStr, N). + string__to_int(NStr, N). path_step_from_string_2('s', NStr, switch(N)) :- - string__to_int(NStr, N). + string__to_int(NStr, N). path_step_from_string_2('?', "", ite_cond). path_step_from_string_2('t', "", ite_then). path_step_from_string_2('e', "", ite_else). @@ -433,8 +431,8 @@ path_step_from_string_2('l', "", later). is_path_separator(';'). string_from_path(GoalPath, GoalPathStr) :- - list.map(string_from_path_step, GoalPath, GoalPathSteps), - GoalPathStr = string.join_list(";", GoalPathSteps) ++ ";". + list.map(string_from_path_step, GoalPath, GoalPathSteps), + GoalPathStr = string.join_list(";", GoalPathSteps) ++ ";". :- pred string_from_path_step(goal_path_step::in, string::out) is det. @@ -453,7 +451,7 @@ string_from_path_step(later, "l"). %-----------------------------------------------------------------------------% detism_rep(Detism) = Rep :- - determinism_representation(Detism, Rep). + determinism_representation(Detism, Rep). % This encoding must match the encoding of MR_Determinism in % runtime/mercury_stack_layout.h. The rationale for this encoding @@ -471,10 +469,10 @@ determinism_representation(cc_multidet_rep, 14). %-----------------------------------------------------------------------------% goal_type_to_byte(Type) = TypeInt :- - goal_type_byte(TypeInt, Type). + goal_type_byte(TypeInt, Type). byte_to_goal_type(TypeInt) = Type :- - goal_type_byte(TypeInt, Type). + goal_type_byte(TypeInt, Type). :- pred goal_type_byte(int, bytecode_goal_type). :- mode goal_type_byte(in, out) is semidet.