mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-15 01:13:30 +00:00
976 lines
39 KiB
Mathematica
976 lines
39 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 2006-2011 The University of Melbourne.
|
|
% Copyright (C) 2014-2025 The Mercury team.
|
|
% This file may only be copied under the terms of the GNU General
|
|
% Public License - see the file COPYING in the Mercury distribution.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% File: prog_event.m.
|
|
% Author: zs.
|
|
%
|
|
% This module defines the database of information the compiler has about
|
|
% events other than the built-in set of execution tracing events.
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module parse_tree.prog_event.
|
|
:- interface.
|
|
|
|
:- import_module parse_tree.error_spec.
|
|
:- import_module parse_tree.prog_data.
|
|
:- import_module parse_tree.prog_data_event.
|
|
|
|
:- import_module io.
|
|
:- import_module list.
|
|
|
|
% read_event_set(FileName, EventSetName, EventSpecMap, ErrorSpecs, !IO):
|
|
%
|
|
% Read in a set of event specifications from FileName, and return them
|
|
% in EventSetName and EventSpecMap. Set ErrorSpecs to a list of all the
|
|
% errors discovered during the process.
|
|
%
|
|
:- pred read_event_set(string::in, string::out, event_spec_map::out,
|
|
list(error_spec)::out, io::di, io::uo) is det.
|
|
|
|
% Return a description of the given event set.
|
|
%
|
|
:- func derive_event_set_data(event_set) = event_set_data.
|
|
|
|
% Given an event name, returns its number.
|
|
%
|
|
:- pred event_number(event_spec_map::in, string::in, int::out) is semidet.
|
|
|
|
% Given an event name, returns the attributes of the event.
|
|
%
|
|
:- pred event_attributes(event_spec_map::in, string::in,
|
|
list(event_attribute)::out) is semidet.
|
|
|
|
% Given an event name, returns the types of the arguments of the event.
|
|
%
|
|
:- pred event_arg_types(event_spec_map::in, string::in, list(mer_type)::out)
|
|
is semidet.
|
|
|
|
% Given an event name, returns the modes of the arguments of the event.
|
|
%
|
|
:- pred event_arg_modes(event_spec_map::in, string::in, list(mer_mode)::out)
|
|
is semidet.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.sym_name.
|
|
:- import_module parse_tree.builtin_lib_types.
|
|
:- import_module parse_tree.prog_mode.
|
|
:- import_module parse_tree.prog_type_construct.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module bimap.
|
|
:- import_module digraph.
|
|
:- import_module int.
|
|
:- import_module io.file.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module pair.
|
|
:- import_module require.
|
|
:- import_module set.
|
|
:- import_module string.
|
|
:- import_module term_context.
|
|
|
|
read_event_set(SpecsFileName, EventSetName, EventSpecMap, ErrorSpecs, !IO) :-
|
|
% Currently, we convert the event specification file into a Mercury term
|
|
% by using the yacc parser in the trace directory to create a C data
|
|
% structure to represent its contents, writing out that data structure
|
|
% as a Mercury term to a file (TermFileName), and then reading in the term
|
|
% from that file.
|
|
%
|
|
% This is a clumsy approach, since it requires access to the C code in the
|
|
% trace directory (via the event_spec library) and a temporary file.
|
|
% Using Mercury scanners and parsers generated by mscangen and mparsegen
|
|
% respectively would be a much better and more direct approach, but
|
|
% those tools are not yet mature enough. When they are, we should switch
|
|
% to using them.
|
|
|
|
make_temp_file_and_open_it(read_specs_file(SpecsFileName),
|
|
TermFileResult, !IO),
|
|
(
|
|
TermFileResult = ok({TermFileName, TermStream}),
|
|
io.read(TermStream, TermReadRes, !IO),
|
|
(
|
|
TermReadRes = ok(EventSetTerm),
|
|
EventSetTerm = event_set_spec(EventSetName,
|
|
EventSpecsTerm),
|
|
convert_list_to_spec_map(SpecsFileName, EventSpecsTerm,
|
|
map.init, EventSpecMap, [], ErrorSpecs)
|
|
;
|
|
TermReadRes = eof,
|
|
EventSetName = "",
|
|
EventSpecMap = map.init,
|
|
Pieces = [words("Error: unexpected end-of-file"),
|
|
words("in term specification file."), nl],
|
|
ErrorSpec = no_ctxt_spec($pred, severity_error, phase_t2pt,
|
|
Pieces),
|
|
ErrorSpecs = [ErrorSpec]
|
|
;
|
|
TermReadRes = error(TermReadMsg, LineNumber),
|
|
EventSetName = "",
|
|
EventSpecMap = map.init,
|
|
Pieces = [words(TermReadMsg), nl],
|
|
ErrorSpec = spec($pred, severity_error, phase_t2pt,
|
|
term_context.context(TermFileName, LineNumber), Pieces),
|
|
ErrorSpecs = [ErrorSpec]
|
|
),
|
|
io.close_input(TermStream, !IO),
|
|
io.file.remove_file(TermFileName, _RemoveRes, !IO)
|
|
;
|
|
TermFileResult = error(ErrorMessage),
|
|
EventSetName = "",
|
|
EventSpecMap = map.init,
|
|
Pieces = [words("Error:"), lower_case_next_if_not_first,
|
|
words(ErrorMessage), nl],
|
|
ErrorSpec = no_ctxt_spec($pred, severity_error, phase_t2pt, Pieces),
|
|
ErrorSpecs = [ErrorSpec]
|
|
).
|
|
|
|
% make_temp_file_and_open_it(WritePred, Result, !IO):
|
|
%
|
|
% Create a temporary file and call WritePred which will write data to it.
|
|
% If successful, return the file's name and a freshly opened input stream.
|
|
% On error, remove the temporary file.
|
|
%
|
|
:- pred make_temp_file_and_open_it(
|
|
pred(string, maybe_error, io, io)::in(pred(in, out, di, uo) is det),
|
|
maybe_error({string, text_input_stream})::out,
|
|
io::di, io::uo) is det.
|
|
|
|
make_temp_file_and_open_it(WritePred, Result, !IO) :-
|
|
io.file.make_temp_file(TempFileResult, !IO),
|
|
(
|
|
TempFileResult = ok(TempFileName),
|
|
WritePred(TempFileName, PredResult, !IO),
|
|
(
|
|
PredResult = ok,
|
|
io.open_input(TempFileName, OpenResult, !IO),
|
|
(
|
|
OpenResult = ok(Stream),
|
|
Result = ok({TempFileName, Stream})
|
|
;
|
|
OpenResult = error(Error),
|
|
ErrorMessage = string.format("could not open `%s': %s",
|
|
[s(TempFileName), s(error_message(Error))]),
|
|
Result = error(ErrorMessage),
|
|
io.file.remove_file(TempFileName, _, !IO)
|
|
)
|
|
;
|
|
PredResult = error(ErrorMessage),
|
|
io.file.remove_file(TempFileName, _, !IO),
|
|
Result = error(ErrorMessage)
|
|
)
|
|
;
|
|
TempFileResult = error(Error),
|
|
ErrorMessage = string.format("could not create temporary file: %s",
|
|
[s(error_message(Error))]),
|
|
Result = error(ErrorMessage)
|
|
).
|
|
|
|
:- pred read_specs_file(string::in, string::in, maybe_error::out,
|
|
io::di, io::uo) is det.
|
|
|
|
read_specs_file(SpecsFile, TermFile, Result, !IO) :-
|
|
read_specs_file_2(SpecsFile, TermFile, Problem, !IO),
|
|
( if Problem = "" then
|
|
Result = ok
|
|
else
|
|
Result = error(Problem)
|
|
).
|
|
|
|
:- pragma foreign_decl("C",
|
|
"
|
|
#include ""mercury_event_spec.h""
|
|
#include <stdio.h>
|
|
#include <fcntl.h>
|
|
|
|
MR_String read_specs_file_2(MR_AllocSiteInfoPtr alloc_id,
|
|
MR_String specs_file_name, MR_String term_file_name);
|
|
MR_String read_specs_file_3(MR_AllocSiteInfoPtr alloc_id,
|
|
MR_String specs_file_name, MR_String term_file_name,
|
|
int spec_fd);
|
|
MR_String read_specs_file_4(MR_AllocSiteInfoPtr alloc_id,
|
|
MR_String specs_file_name, MR_String term_file_name,
|
|
int spec_fd, size_t size, char *spec_buf);
|
|
").
|
|
|
|
:- pred read_specs_file_2(string::in, string::in, string::out,
|
|
io::di, io::uo) is det.
|
|
:- pragma no_determinism_warning(pred(read_specs_file_2/5)).
|
|
|
|
:- pragma foreign_proc("C",
|
|
read_specs_file_2(SpecsFileName::in, TermFileName::in, Problem::out,
|
|
_IO0::di, _IO::uo),
|
|
[will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
|
|
"
|
|
// We need to save/restore MR_hp so that we can allocate the return
|
|
// value on Mercury's heap if necessary.
|
|
MR_save_transient_hp();
|
|
Problem = read_specs_file_2(MR_ALLOC_ID, SpecsFileName, TermFileName);
|
|
MR_restore_transient_hp();
|
|
").
|
|
|
|
read_specs_file_2(_, _, Problem, IO, IO) :-
|
|
Problem = "mmc can read event set specifications only when it itself " ++
|
|
"is compiled in a grade that targets C code.".
|
|
|
|
:- pragma foreign_code("C", "
|
|
|
|
MR_String
|
|
read_specs_file_2(MR_AllocSiteInfoPtr alloc_id, MR_String specs_file_name,
|
|
MR_String term_file_name)
|
|
{
|
|
int spec_fd;
|
|
MR_String problem;
|
|
char errbuf[MR_STRERROR_BUF_SIZE];
|
|
|
|
// There are race conditions between opening the file, stat'ing the file
|
|
// and reading the contents of the file, but the Unix API doesn't really
|
|
// allow these race conditions to be resolved.
|
|
|
|
spec_fd = open(specs_file_name, O_RDONLY);
|
|
if (spec_fd < 0) {
|
|
problem = MR_make_string(alloc_id, ""could not open %s: %s"",
|
|
specs_file_name, MR_strerror(errno, errbuf, sizeof(errbuf)));
|
|
} else {
|
|
problem = read_specs_file_3(alloc_id, specs_file_name,
|
|
term_file_name, spec_fd);
|
|
(void) close(spec_fd);
|
|
}
|
|
return problem;
|
|
}
|
|
|
|
MR_String
|
|
read_specs_file_3(MR_AllocSiteInfoPtr alloc_id, MR_String specs_file_name,
|
|
MR_String term_file_name, int spec_fd)
|
|
{
|
|
struct stat stat_buf;
|
|
MR_String problem;
|
|
|
|
if (fstat(spec_fd, &stat_buf) != 0) {
|
|
problem = MR_make_string(alloc_id, ""could not stat %s"",
|
|
specs_file_name);
|
|
} else {
|
|
char *spec_buf;
|
|
|
|
spec_buf = malloc(stat_buf.st_size + 1);
|
|
if (spec_buf == NULL) {
|
|
problem = MR_make_string(alloc_id,
|
|
""could not allocate memory for a copy of %s"",
|
|
specs_file_name);
|
|
} else {
|
|
problem = read_specs_file_4(alloc_id, specs_file_name,
|
|
term_file_name, spec_fd, stat_buf.st_size, spec_buf);
|
|
free(spec_buf);
|
|
}
|
|
}
|
|
return problem;
|
|
}
|
|
|
|
MR_String
|
|
read_specs_file_4(MR_AllocSiteInfoPtr alloc_id, MR_String specs_file_name,
|
|
MR_String term_file_name, int spec_fd, size_t size, char *spec_buf)
|
|
{
|
|
size_t num_bytes_read;
|
|
MR_String problem;
|
|
|
|
// XXX We don't handle successful but partial reads.
|
|
do {
|
|
num_bytes_read = read(spec_fd, spec_buf, size);
|
|
} while (num_bytes_read == -1 && MR_is_eintr(errno));
|
|
if (num_bytes_read != size) {
|
|
problem = MR_make_string(alloc_id, ""could not read in %s"",
|
|
specs_file_name);
|
|
} else {
|
|
MR_EventSet event_set;
|
|
|
|
// NULL terminate the string we have read in.
|
|
spec_buf[num_bytes_read] = '\\0';
|
|
event_set = MR_read_event_set(specs_file_name, spec_buf);
|
|
if (event_set == NULL) {
|
|
problem = MR_make_string(alloc_id, ""could not parse %s"",
|
|
specs_file_name);
|
|
} else {
|
|
FILE *term_fp;
|
|
char errbuf[MR_STRERROR_BUF_SIZE];
|
|
|
|
term_fp = fopen(term_file_name, ""w"");
|
|
if (term_fp == NULL) {
|
|
problem = MR_make_string(alloc_id, ""could not open %s: %s"",
|
|
term_file_name,
|
|
MR_strerror(errno, errbuf, sizeof(errbuf)));
|
|
} else {
|
|
MR_print_event_set(term_fp, event_set);
|
|
fclose(term_fp);
|
|
|
|
// Our caller tests Problem against the empty string, not NULL.
|
|
problem = MR_make_string(alloc_id, """");
|
|
}
|
|
}
|
|
}
|
|
return problem;
|
|
}
|
|
").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type event_set_spec
|
|
---> event_set_spec(
|
|
event_set_name :: string,
|
|
event_set_specs :: list(event_spec_term)
|
|
).
|
|
|
|
:- type event_spec_term
|
|
---> event_spec_term(
|
|
event_name :: string,
|
|
event_num :: int,
|
|
event_linenumber :: int,
|
|
event_attrs :: list(event_attr_term)
|
|
).
|
|
|
|
:- type event_attr_term
|
|
---> event_attr_term(
|
|
attr_name :: string,
|
|
attr_linenum :: int,
|
|
attr_type :: event_attr_type
|
|
).
|
|
|
|
:- type event_attr_synth_call_term
|
|
---> event_attr_synth_call_term(
|
|
func_attr_name :: string,
|
|
arg_attr_names :: list(string)
|
|
).
|
|
|
|
:- type event_attr_function_kind
|
|
---> event_attr_pure_function
|
|
; event_attr_impure_function.
|
|
|
|
:- type event_attr_type
|
|
---> event_attr_type_ordinary(
|
|
event_attr_type_term
|
|
)
|
|
; event_attr_type_synthesized(
|
|
event_attr_type_term,
|
|
event_attr_synth_call_term
|
|
)
|
|
; event_attr_type_function(
|
|
event_attr_function_kind
|
|
).
|
|
|
|
:- type event_attr_type_term
|
|
---> event_attr_type_term(
|
|
string,
|
|
list(event_attr_type_term)
|
|
).
|
|
|
|
:- pred convert_list_to_spec_map(string::in, list(event_spec_term)::in,
|
|
event_spec_map::in, event_spec_map::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
convert_list_to_spec_map(_, [], !EventSpecMap, !ErrorSpecs).
|
|
convert_list_to_spec_map(FileName, [SpecTerm | SpecTerms],
|
|
!EventSpecMap, !ErrorSpecs) :-
|
|
convert_term_to_spec_map(FileName, SpecTerm, !EventSpecMap, !ErrorSpecs),
|
|
convert_list_to_spec_map(FileName, SpecTerms, !EventSpecMap, !ErrorSpecs).
|
|
|
|
:- pred convert_term_to_spec_map(string::in, event_spec_term::in,
|
|
event_spec_map::in, event_spec_map::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
convert_term_to_spec_map(FileName, SpecTerm, !EventSpecMap, !ErrorSpecs) :-
|
|
SpecTerm = event_spec_term(EventName, EventNumber, EventLineNumber,
|
|
AttrTerms),
|
|
|
|
% We convert the event_spec_term we have read in to the event_spec_map
|
|
% table entry we need in three stages.
|
|
%
|
|
% Stage 1 is done by build_plain_type_map. This records the types of all
|
|
% of the ordinary and synthesized attributes in AttrTypeMap0, builds up
|
|
% KeyMap, which maps each attribute name to its digraph_key in DepRel0,
|
|
% and builds DepRel0, which at the end of stage 1 just contains one key
|
|
% for each attribute with no relationships between them.
|
|
%
|
|
% Stage 2 is done by build_dep_map. This inserts into DepRel all the
|
|
% dependencies of synthesized attributes on the attributes they are
|
|
% synthesized from (including the attribute that provides the function).
|
|
% It also computes the types of the function attributes that are used
|
|
% to synthesize one or more other attributes.
|
|
%
|
|
% Stage 3, implemented by convert_terms_to_attrs, is the final pass.
|
|
% It does the data format conversion, and performs the last checks.
|
|
|
|
build_plain_type_map(EventName, FileName, EventLineNumber, AttrTerms,
|
|
0, map.init, _AttrNumMap, map.init, AttrNameMap,
|
|
map.init, AttrTypeMap0, bimap.init, KeyMap,
|
|
digraph.init, DepRel0, !ErrorSpecs),
|
|
build_dep_map(EventName, FileName, AttrNameMap, KeyMap, AttrTerms,
|
|
AttrTypeMap0, AttrTypeMap, DepRel0, DepRel, !ErrorSpecs),
|
|
convert_terms_to_attrs(EventName, FileName, AttrNameMap,
|
|
AttrTypeMap, 0, AttrTerms, [], RevAttrs, !ErrorSpecs),
|
|
( if
|
|
digraph.return_vertices_in_from_to_order(DepRel, AllAttrNameOrder)
|
|
then
|
|
% There is an order for computing the synthesized attributes.
|
|
keep_only_synth_attr_nums(AttrNameMap, AllAttrNameOrder,
|
|
SynthAttrNumOrder)
|
|
else
|
|
Context = term_context.context(FileName, EventLineNumber),
|
|
Sccs = digraph.return_sccs_in_to_from_order(DepRel),
|
|
list.filter(two_or_more_attrs_in_scc, Sccs, TooLargeSccs),
|
|
digraph.to_assoc_list(DepRel, DepRelEdges),
|
|
list.foldl(acc_self_dependent_nodes, DepRelEdges, [], RevSelfRecSccs),
|
|
list.reverse(RevSelfRecSccs, SelfRecSccs),
|
|
% Each scc in TooLargeSccs contains mutual recursion, while
|
|
% each scc in SelfRecSccs contains self recursion.
|
|
BadSccs = TooLargeSccs ++ SelfRecSccs,
|
|
(
|
|
BadSccs = [_ | _],
|
|
list.foldl(acc_circular_synth_attr_error(Context, EventName),
|
|
BadSccs, !ErrorSpecs)
|
|
;
|
|
BadSccs = [],
|
|
% Print an error message even if we can't blame a specific
|
|
% subset of the synthesized attributes.
|
|
acc_circular_synth_attr_error(Context, EventName,
|
|
set.init, !ErrorSpecs)
|
|
),
|
|
SynthAttrNumOrder = []
|
|
),
|
|
list.reverse(RevAttrs, Attrs),
|
|
EventSpec = event_spec(EventNumber, EventName, EventLineNumber,
|
|
Attrs, SynthAttrNumOrder),
|
|
( if map.search(!.EventSpecMap, EventName, OldEventSpec) then
|
|
OldLineNumber = OldEventSpec ^ event_spec_linenum,
|
|
Pieces1 = [words("Error: this specification for event")] ++
|
|
color_as_subject([quote(EventName)]) ++
|
|
color_as_incorrect([words("is a duplicate.")]),
|
|
Pieces2 = [words("The previous specification of event"),
|
|
quote(EventName), words("is here."), nl],
|
|
EventContext = term_context.context(FileName, EventLineNumber),
|
|
OldContext = term_context.context(FileName, OldLineNumber),
|
|
DuplErrorSpec = error_spec($pred, severity_error, phase_t2pt,
|
|
[msg(EventContext, Pieces1),
|
|
msg(OldContext, Pieces2)]),
|
|
!:ErrorSpecs = [DuplErrorSpec | !.ErrorSpecs]
|
|
else
|
|
map.det_insert(EventName, EventSpec, !EventSpecMap)
|
|
).
|
|
|
|
:- pred two_or_more_attrs_in_scc(set(string)::in) is semidet.
|
|
|
|
two_or_more_attrs_in_scc(Scc) :-
|
|
set.count(Scc) > 1.
|
|
|
|
:- pred acc_self_dependent_nodes(pair(string, string)::in,
|
|
list(set(string))::in, list(set(string))::out) is det.
|
|
|
|
acc_self_dependent_nodes(From - To, !RevSelfRecSccs) :-
|
|
( if From = To then
|
|
!:RevSelfRecSccs = [set.make_singleton_set(From) | !.RevSelfRecSccs]
|
|
else
|
|
true
|
|
).
|
|
|
|
:- pred acc_circular_synth_attr_error(prog_context::in, string::in,
|
|
set(string)::in, list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
acc_circular_synth_attr_error(Context, EventName, Scc, !ErrorSpecs) :-
|
|
Attrs = set.to_sorted_list(Scc),
|
|
(
|
|
Attrs = [_, _ | _],
|
|
Pieces =
|
|
[words("Error: synthesized attributes")] ++
|
|
quote_list_to_color_pieces(color_subject, "and", [], Attrs) ++
|
|
[words("of event"), quote(EventName)] ++
|
|
color_as_incorrect([words("depend on each other.")]) ++
|
|
[nl]
|
|
;
|
|
Attrs = [Attr],
|
|
Pieces =
|
|
[words("Error: synthesized attribute")] ++
|
|
color_as_subject([quote(Attr)]) ++
|
|
[words("of event"), quote(EventName)] ++
|
|
color_as_incorrect([words("depends on itself.")]) ++
|
|
[nl]
|
|
;
|
|
Attrs = [],
|
|
% This should never happen, as all circular dependencies
|
|
% should be classifiable as due to either mutual or self recursion,
|
|
% but just in case ...
|
|
Pieces =
|
|
[words("Error:")] ++
|
|
color_as_incorrect([words("circular dependency")]) ++
|
|
[words("among the synthesized attributes of")] ++
|
|
color_as_subject([words("event"), quote(EventName),
|
|
suffix(".")]) ++
|
|
[nl]
|
|
),
|
|
CircErrorSpec = spec($pred, severity_error, phase_t2pt, Context, Pieces),
|
|
!:ErrorSpecs = [CircErrorSpec | !.ErrorSpecs].
|
|
|
|
:- pred keep_only_synth_attr_nums(attr_name_map::in, list(string)::in,
|
|
list(int)::out) is det.
|
|
|
|
keep_only_synth_attr_nums(_, [], []).
|
|
keep_only_synth_attr_nums(AttrMap, [AttrName | AttrNames], SynthAttrNums) :-
|
|
keep_only_synth_attr_nums(AttrMap, AttrNames, SynthAttrNumsTail),
|
|
map.lookup(AttrMap, AttrName, attr_info(AttrNum, _, _, AttrType)),
|
|
(
|
|
( AttrType = event_attr_type_ordinary(_)
|
|
; AttrType = event_attr_type_function(_)
|
|
),
|
|
SynthAttrNums = SynthAttrNumsTail
|
|
;
|
|
AttrType = event_attr_type_synthesized(_, _),
|
|
SynthAttrNums = [AttrNum | SynthAttrNumsTail]
|
|
).
|
|
|
|
:- type attr_info
|
|
---> attr_info(
|
|
attr_info_number :: int,
|
|
attr_info_name :: string,
|
|
attr_info_linenumber :: int,
|
|
attr_info_type :: event_attr_type
|
|
).
|
|
|
|
:- func attr_info_number(attr_info) = int.
|
|
|
|
% Given an attribute number, return information about that attribute.
|
|
:- type attr_num_map == map(int, attr_info).
|
|
|
|
% Given an attribute name, return information about that attribute.
|
|
:- type attr_name_map == map(string, attr_info).
|
|
|
|
% Given an attribute number, return that attribute's type.
|
|
:- type attr_type_map == map(string, mer_type).
|
|
|
|
% The dependency relation has a node for each attribute. The links between
|
|
% nodes represent the dependency of one attribute on another.
|
|
%
|
|
% The attr_key_map maps the name of each attribute to its key in
|
|
% attr_dep_rel.
|
|
:- type attr_dep_rel == digraph(string).
|
|
:- type attr_key == digraph_key(string).
|
|
:- type attr_key_map == bimap(string, attr_key).
|
|
|
|
% See the big comment in convert_term_to_spec_map for the documentation
|
|
% of this predicate.
|
|
%
|
|
:- pred build_plain_type_map(string::in, string::in, int::in,
|
|
list(event_attr_term)::in, int::in, attr_num_map::in, attr_num_map::out,
|
|
attr_name_map::in, attr_name_map::out,
|
|
attr_type_map::in, attr_type_map::out,
|
|
attr_key_map::in, attr_key_map::out, attr_dep_rel::in, attr_dep_rel::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
build_plain_type_map(_, _, _, [], _, !AttrNumMap, !AttrNameMap, !AttrTypeMap,
|
|
!KeyMap, !DepRel, !ErrorSpecs).
|
|
build_plain_type_map(EventName, FileName, EventLineNumber,
|
|
[AttrTerm | AttrTerms], AttrNum, !AttrNumMap, !AttrNameMap,
|
|
!AttrTypeMap, !KeyMap, !DepRel, !ErrorSpecs) :-
|
|
AttrTerm = event_attr_term(AttrName, AttrLineNumber, AttrTypeTerm),
|
|
AttrInfo = attr_info(AttrNum, AttrName, AttrLineNumber, AttrTypeTerm),
|
|
map.det_insert(AttrNum, AttrInfo, !AttrNumMap),
|
|
digraph.add_vertex(AttrName, AttrKey, !DepRel),
|
|
( if bimap.insert(AttrName, AttrKey, !KeyMap) then
|
|
map.det_insert(AttrName, AttrInfo, !AttrNameMap)
|
|
else
|
|
Pieces = [words("Error: event"), quote(EventName)] ++
|
|
color_as_incorrect([words("has more than one")]) ++
|
|
[words("attribute named")] ++
|
|
color_as_subject([quote(AttrName), suffix(".")]) ++
|
|
[nl],
|
|
ErrorSpec = spec($pred, severity_error, phase_t2pt,
|
|
term_context.context(FileName, EventLineNumber), Pieces),
|
|
!:ErrorSpecs = [ErrorSpec | !.ErrorSpecs]
|
|
),
|
|
(
|
|
( AttrTypeTerm = event_attr_type_ordinary(TypeTerm)
|
|
; AttrTypeTerm = event_attr_type_synthesized(TypeTerm, _SynthCall)
|
|
),
|
|
Type = convert_term_to_type(TypeTerm),
|
|
( if map.search(!.AttrTypeMap, AttrName, _OldType) then
|
|
% The error message has already been generated above.
|
|
true
|
|
else
|
|
map.det_insert(AttrName, Type, !AttrTypeMap)
|
|
)
|
|
;
|
|
AttrTypeTerm = event_attr_type_function(_)
|
|
),
|
|
build_plain_type_map(EventName, FileName, EventLineNumber, AttrTerms,
|
|
AttrNum + 1, !AttrNumMap, !AttrNameMap, !AttrTypeMap, !KeyMap, !DepRel,
|
|
!ErrorSpecs).
|
|
|
|
% See the big comment in convert_term_to_spec_map for the documentation
|
|
% of this predicate.
|
|
%
|
|
:- pred build_dep_map(string::in, string::in,
|
|
attr_name_map::in, attr_key_map::in, list(event_attr_term)::in,
|
|
attr_type_map::in, attr_type_map::out, attr_dep_rel::in, attr_dep_rel::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
build_dep_map(_, _, _, _, [], !AttrTypeMap, !DepRel, !ErrorSpecs).
|
|
build_dep_map(EventName, FileName, AttrNameMap, KeyMap, [AttrTerm | AttrTerms],
|
|
!AttrTypeMap, !DepRel, !ErrorSpecs) :-
|
|
AttrTerm = event_attr_term(AttrName, AttrLineNumber, AttrTypeTerm),
|
|
bimap.lookup(KeyMap, AttrName, AttrKey),
|
|
(
|
|
AttrTypeTerm = event_attr_type_synthesized(_TypeTerm, SynthCallTerm),
|
|
SynthCallTerm = event_attr_synth_call_term(FuncAttrName, ArgAttrNames),
|
|
record_arg_dependencies(EventName, FileName, AttrLineNumber, KeyMap,
|
|
AttrName, AttrKey, ArgAttrNames, !DepRel, [], AttrErrorSpecs),
|
|
(
|
|
AttrErrorSpecs = [_ | _],
|
|
% We still record the fact that FuncAttrName is used, to prevent
|
|
% us from generating error messages saying that it is unused.
|
|
map.det_insert(FuncAttrName, void_type, !AttrTypeMap),
|
|
!:ErrorSpecs = AttrErrorSpecs ++ !.ErrorSpecs
|
|
;
|
|
AttrErrorSpecs = [],
|
|
( if map.search(!.AttrTypeMap, AttrName, AttrType) then
|
|
list.map(map.lookup(!.AttrTypeMap), ArgAttrNames, ArgTypes),
|
|
( if
|
|
map.search(AttrNameMap, FuncAttrName, FuncAttrInfo),
|
|
FuncAttrInfo ^ attr_info_type =
|
|
event_attr_type_function(FuncAttrPurity)
|
|
then
|
|
(
|
|
FuncAttrPurity = event_attr_pure_function,
|
|
FuncPurity = purity_pure
|
|
;
|
|
FuncAttrPurity = event_attr_impure_function,
|
|
FuncPurity = purity_impure
|
|
),
|
|
construct_higher_order_func_type(FuncPurity,
|
|
ArgTypes, AttrType, FuncAttrType),
|
|
( if
|
|
map.search(!.AttrTypeMap, FuncAttrName,
|
|
OldFuncAttrType)
|
|
then
|
|
( if FuncAttrType = OldFuncAttrType then
|
|
% AttrTypeMap already contains the correct info.
|
|
true
|
|
else
|
|
FuncAttrLine =
|
|
FuncAttrInfo ^ attr_info_linenumber,
|
|
% XXX Maybe we should give the types themselves.
|
|
Pieces = [words("Error: attribute")] ++
|
|
color_as_subject([quote(FuncAttrName)]) ++
|
|
[words("is assigned")] ++
|
|
color_as_incorrect(
|
|
[words("inconsistent types")]) ++
|
|
[words("by synthesized attributes."), nl],
|
|
Context = context(FileName, FuncAttrLine),
|
|
ErrorSpec = spec($pred, severity_error, phase_t2pt,
|
|
Context, Pieces),
|
|
!:ErrorSpecs = [ErrorSpec | !.ErrorSpecs]
|
|
)
|
|
else
|
|
map.det_insert(FuncAttrName, FuncAttrType,
|
|
!AttrTypeMap)
|
|
)
|
|
else
|
|
Pieces = [words("Error: attribute")] ++
|
|
color_as_subject([quote(AttrName)]) ++
|
|
color_as_incorrect([words("cannot be synthesized")]) ++
|
|
[words("by non-function attribute"),
|
|
quote(FuncAttrName), suffix("."), nl],
|
|
Context = context(FileName, AttrLineNumber),
|
|
ErrorSpec = spec($pred, severity_error, phase_t2pt,
|
|
Context, Pieces),
|
|
!:ErrorSpecs = [ErrorSpec | !.ErrorSpecs]
|
|
)
|
|
else
|
|
% The error message was already generated in the previous pass.
|
|
true
|
|
)
|
|
)
|
|
;
|
|
AttrTypeTerm = event_attr_type_ordinary(_TypeTerm)
|
|
;
|
|
AttrTypeTerm = event_attr_type_function(_)
|
|
),
|
|
build_dep_map(EventName, FileName, AttrNameMap, KeyMap, AttrTerms,
|
|
!AttrTypeMap, !DepRel, !ErrorSpecs).
|
|
|
|
:- pred record_arg_dependencies(string::in, string::in, int::in,
|
|
attr_key_map::in, string::in, attr_key::in,
|
|
list(string)::in, attr_dep_rel::in, attr_dep_rel::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
record_arg_dependencies(_, _, _, _, _, _, [], !DepRel, !ErrorSpecs).
|
|
record_arg_dependencies(EventName, FileName, AttrLineNumber, KeyMap,
|
|
SynthAttrName, SynthAttrKey, [AttrName | AttrNames],
|
|
!DepRel, !ErrorSpecs) :-
|
|
( if bimap.search(KeyMap, AttrName, AttrKey) then
|
|
digraph.add_edge(AttrKey, SynthAttrKey, !DepRel)
|
|
else
|
|
Pieces = [words("Error: attribute")] ++
|
|
color_as_subject([quote(SynthAttrName)]) ++
|
|
[words("of event"), quote(EventName), words("uses")] ++
|
|
color_as_incorrect([words("nonexistent attribute"),
|
|
quote(AttrName)]) ++
|
|
[words("in its synthesis."), nl],
|
|
ErrorSpec = spec($pred, severity_error, phase_t2pt,
|
|
term_context.context(FileName, AttrLineNumber), Pieces),
|
|
!:ErrorSpecs = [ErrorSpec | !.ErrorSpecs]
|
|
),
|
|
record_arg_dependencies(EventName, FileName, AttrLineNumber, KeyMap,
|
|
SynthAttrName, SynthAttrKey, AttrNames, !DepRel, !ErrorSpecs).
|
|
|
|
% See the big comment in convert_term_to_spec_map for the documentation
|
|
% of this predicate.
|
|
%
|
|
:- pred convert_terms_to_attrs(string::in, string::in, attr_name_map::in,
|
|
attr_type_map::in, int::in, list(event_attr_term)::in,
|
|
list(event_attribute)::in, list(event_attribute)::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
convert_terms_to_attrs(_, _, _, _, _, [], !RevAttrs, !ErrorSpecs).
|
|
convert_terms_to_attrs(EventName, FileName, AttrNameMap,
|
|
AttrTypeMap, AttrNum, [AttrTerm | AttrTerms], !RevAttrs,
|
|
!ErrorSpecs) :-
|
|
AttrTerm = event_attr_term(AttrName, AttrLineNumber, AttrTypeTerm),
|
|
(
|
|
AttrTypeTerm = event_attr_type_ordinary(_),
|
|
map.lookup(AttrTypeMap, AttrName, AttrType),
|
|
EventAttr = event_attribute(AttrNum, AttrName, AttrType, in_mode, no),
|
|
!:RevAttrs = [EventAttr | !.RevAttrs]
|
|
;
|
|
AttrTypeTerm = event_attr_type_synthesized(_, SynthCallTerm),
|
|
map.lookup(AttrTypeMap, AttrName, AttrType),
|
|
SynthCallTerm = event_attr_synth_call_term(FuncAttrName, ArgAttrNames),
|
|
( if
|
|
map.search(AttrNameMap, FuncAttrName, FuncAttrInfo),
|
|
FuncAttrNum = FuncAttrInfo ^ attr_info_number,
|
|
list.map(map.search(AttrNameMap), ArgAttrNames, ArgAttrInfos)
|
|
then
|
|
ArgAttrNums = list.map(attr_info_number, ArgAttrInfos),
|
|
ArgAttrNameNums = assoc_list.from_corresponding_lists(ArgAttrNames,
|
|
ArgAttrNums),
|
|
compute_prev_synth_attr_order(AttrNameMap, AttrName,
|
|
set.init, set.init, _, PrevSynthAttrOrder),
|
|
SynthCall = event_attr_synth_call(FuncAttrName - FuncAttrNum,
|
|
ArgAttrNameNums, PrevSynthAttrOrder),
|
|
EventAttr = event_attribute(AttrNum, AttrName, AttrType, in_mode,
|
|
yes(SynthCall)),
|
|
!:RevAttrs = [EventAttr | !.RevAttrs]
|
|
else
|
|
% The error that caused the map search failure has already had
|
|
% an error message generated for it.
|
|
true
|
|
)
|
|
;
|
|
AttrTypeTerm = event_attr_type_function(_),
|
|
( if map.search(AttrTypeMap, AttrName, AttrType) then
|
|
EventAttr = event_attribute(AttrNum, AttrName, AttrType, in_mode,
|
|
no),
|
|
!:RevAttrs = [EventAttr | !.RevAttrs]
|
|
else
|
|
Pieces = [words("Error: event"), quote(EventName)] ++
|
|
color_as_incorrect([words("does not use")]) ++
|
|
[words("the function attribute")] ++
|
|
color_as_subject([quote(AttrName), suffix(".")]) ++
|
|
[nl],
|
|
ErrorSpec = spec($pred, severity_error, phase_t2pt,
|
|
term_context.context(FileName, AttrLineNumber), Pieces),
|
|
!:ErrorSpecs = [ErrorSpec | !.ErrorSpecs]
|
|
)
|
|
),
|
|
convert_terms_to_attrs(EventName, FileName, AttrNameMap, AttrTypeMap,
|
|
AttrNum + 1, AttrTerms, !RevAttrs, !ErrorSpecs).
|
|
|
|
:- func convert_term_to_type(event_attr_type_term) = mer_type.
|
|
|
|
convert_term_to_type(Term) = Type :-
|
|
Term = event_attr_type_term(Name, Args),
|
|
( if
|
|
Args = [],
|
|
builtin_type_name(BuiltinType, Name)
|
|
then
|
|
Type = builtin_type(BuiltinType)
|
|
else
|
|
SymName = string_to_sym_name(Name),
|
|
ArgTypes = list.map(convert_term_to_type, Args),
|
|
Type = defined_type(SymName, ArgTypes, kind_star)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred compute_prev_synth_attr_order(attr_name_map::in, string::in,
|
|
set(string)::in, set(string)::in, set(string)::out, list(int)::out) is det.
|
|
|
|
compute_prev_synth_attr_order(AttrNameMap, AttrName, Ancestors,
|
|
!AlreadyComputed, PrevSynthOrder) :-
|
|
( if set.member(AttrName, Ancestors) then
|
|
% There is a circularity among the dependencies, which means that
|
|
% PrevSynthOrder won't actually be used.
|
|
PrevSynthOrder = []
|
|
else
|
|
( if map.search(AttrNameMap, AttrName, AttrInfo) then
|
|
AttrTerm = AttrInfo ^ attr_info_type,
|
|
(
|
|
( AttrTerm = event_attr_type_ordinary(_)
|
|
; AttrTerm = event_attr_type_function(_)
|
|
),
|
|
PrevSynthOrder = []
|
|
;
|
|
AttrTerm = event_attr_type_synthesized(_, SynthCall),
|
|
SynthCall = event_attr_synth_call_term(FuncAttrName,
|
|
ArgAttrNames),
|
|
set.insert(AttrName, Ancestors, SubAncestors),
|
|
compute_prev_synth_attr_order_for_args(AttrNameMap,
|
|
[FuncAttrName | ArgAttrNames], SubAncestors,
|
|
!AlreadyComputed, SubPrevSynthOrder),
|
|
set.insert(AttrName, !AlreadyComputed),
|
|
% This append at the end makes our algorithm O(n^2),
|
|
% but since n will always be small, this doesn't matter.
|
|
AttrNum = AttrInfo ^ attr_info_number,
|
|
PrevSynthOrder = SubPrevSynthOrder ++ [AttrNum]
|
|
)
|
|
else
|
|
% An error has occurred somewhere, which means that
|
|
% PrevSynthOrder won't actually be used.
|
|
PrevSynthOrder = []
|
|
)
|
|
).
|
|
|
|
:- pred compute_prev_synth_attr_order_for_args(attr_name_map::in,
|
|
list(string)::in, set(string)::in, set(string)::in, set(string)::out,
|
|
list(int)::out) is det.
|
|
|
|
compute_prev_synth_attr_order_for_args(_AttrNameMap, [],
|
|
_Ancestors, !AlreadyComputed, []).
|
|
compute_prev_synth_attr_order_for_args(AttrNameMap, [ArgName | ArgNames],
|
|
Ancestors, !AlreadyComputed, PrevSynthOrder) :-
|
|
compute_prev_synth_attr_order(AttrNameMap, ArgName,
|
|
Ancestors, !AlreadyComputed, PrevSynthOrderArg),
|
|
compute_prev_synth_attr_order_for_args(AttrNameMap, ArgNames,
|
|
Ancestors, !AlreadyComputed, PrevSynthOrderArgs),
|
|
PrevSynthOrder = PrevSynthOrderArg ++ PrevSynthOrderArgs.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
derive_event_set_data(EventSet) = EventSetData :-
|
|
EventSet = event_set(EventSetName, EventSpecMap),
|
|
map.values(EventSpecMap, EventSpecList),
|
|
list.sort(compare_event_specs_by_num, EventSpecList, SortedEventSpecList),
|
|
EventDescStrings = list.map(describe_event_spec, SortedEventSpecList),
|
|
string.append_list(EventDescStrings, EventDescs),
|
|
Desc = "event set " ++ EventSetName ++ "\n" ++ EventDescs,
|
|
list.foldl(update_max_num_attr, EventSpecList, -1, MaxNumAttr),
|
|
EventSetData = event_set_data(EventSetName, Desc, SortedEventSpecList,
|
|
MaxNumAttr).
|
|
|
|
:- pred update_max_num_attr(event_spec::in, int::in, int::out) is det.
|
|
|
|
update_max_num_attr(Spec, !MaxNumAttr) :-
|
|
AllAttrs = Spec ^ event_spec_attrs,
|
|
list.length(AllAttrs, NumAttr),
|
|
!:MaxNumAttr = int.max(!.MaxNumAttr, NumAttr).
|
|
|
|
:- pred compare_event_specs_by_num(event_spec::in, event_spec::in,
|
|
comparison_result::out) is det.
|
|
|
|
compare_event_specs_by_num(SpecA, SpecB, Result) :-
|
|
compare(Result, SpecA ^ event_spec_num, SpecB ^ event_spec_num).
|
|
|
|
:- func describe_event_spec(event_spec) = string.
|
|
|
|
describe_event_spec(Spec) = Desc :-
|
|
Spec = event_spec(_EventNumber, EventName, _EventLineNumber,
|
|
Attrs, _SynthAttrNumOrder),
|
|
AttrDescs = string.join_list(",\n", list.map(describe_event_attr, Attrs)),
|
|
Desc = "event " ++ EventName ++ "(" ++ AttrDescs ++ ")\n".
|
|
|
|
:- func describe_event_attr(event_attribute) = string.
|
|
|
|
describe_event_attr(Attr) = Desc :-
|
|
Attr = event_attribute(_Num, Name, Type, _Mode, MaybeSynthCall),
|
|
TypeDesc = describe_attr_type(Type),
|
|
(
|
|
MaybeSynthCall = no,
|
|
SynthCallDesc = ""
|
|
;
|
|
MaybeSynthCall = yes(SynthCall),
|
|
SynthCall = event_attr_synth_call(FuncAttrNameNum, ArgAttrNameNums,
|
|
_Order),
|
|
ArgAttrDesc = string.join_list(", ", assoc_list.keys(ArgAttrNameNums)),
|
|
SynthCallDesc = " synthesized by " ++
|
|
fst(FuncAttrNameNum) ++ "(" ++ ArgAttrDesc ++ ")"
|
|
),
|
|
Desc = Name ++ ": " ++ TypeDesc ++ SynthCallDesc.
|
|
|
|
:- func describe_attr_type(mer_type) = string.
|
|
|
|
describe_attr_type(Type) = Desc :-
|
|
(
|
|
Type = defined_type(SymName, ArgTypes, Kind),
|
|
expect(unify(Kind, kind_star), $pred, "not kind_star"),
|
|
(
|
|
ArgTypes = [],
|
|
ArgTypeDescs = ""
|
|
;
|
|
ArgTypes = [_ | _],
|
|
ArgTypeDescs = "(" ++
|
|
string.join_list(", ", list.map(describe_attr_type, ArgTypes))
|
|
++ ")"
|
|
),
|
|
Desc = sym_name_to_string(SymName) ++ ArgTypeDescs
|
|
;
|
|
Type = builtin_type(BuiltinType),
|
|
builtin_type_name(BuiltinType, Desc)
|
|
;
|
|
Type = higher_order_type(_, _, _, _),
|
|
Desc = "function"
|
|
;
|
|
( Type = type_variable(_, _)
|
|
; Type = tuple_type(_, _)
|
|
; Type = apply_n_type(_, _, _)
|
|
; Type = kinded_type(_, _)
|
|
),
|
|
unexpected($pred, "type not constructed by prog_event")
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
event_number(EventSpecMap, EventName, EventNumber) :-
|
|
map.search(EventSpecMap, EventName, EventSpec),
|
|
EventNumber = EventSpec ^ event_spec_num.
|
|
|
|
event_attributes(EventSpecMap, EventName, Attributes) :-
|
|
map.search(EventSpecMap, EventName, EventSpec),
|
|
Attributes = EventSpec ^ event_spec_attrs.
|
|
|
|
event_arg_types(EventSpecMap, EventName, ArgTypes) :-
|
|
event_attributes(EventSpecMap, EventName, Attributes),
|
|
list.filter_map(project_event_arg_type, Attributes, ArgTypes).
|
|
|
|
event_arg_modes(EventSpecMap, EventName, ArgModes) :-
|
|
event_attributes(EventSpecMap, EventName, Attributes),
|
|
list.filter_map(project_event_arg_mode, Attributes, ArgModes).
|
|
|
|
:- pred project_event_arg_type(event_attribute::in, mer_type::out) is semidet.
|
|
|
|
project_event_arg_type(Attribute, Attribute ^ attr_type) :-
|
|
Attribute ^ attr_maybe_synth_call = no.
|
|
|
|
:- pred project_event_arg_mode(event_attribute::in, mer_mode::out) is semidet.
|
|
|
|
project_event_arg_mode(Attribute, Attribute ^ attr_mode) :-
|
|
Attribute ^ attr_maybe_synth_call = no.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module parse_tree.prog_event.
|
|
%-----------------------------------------------------------------------------%
|