From d9f5ab5f60f2a66de4d41c2de9f4913081115599 Mon Sep 17 00:00:00 2001 From: Zoltan Somogyi Date: Wed, 7 Feb 2024 16:55:00 +1100 Subject: [PATCH] Implement type_spec_constrained_preds pragmas. This pragma, which has the form shown by this example, :- pragma type_spec_constrained_preds( [stream.line_oriented(Stream, State), stream.unboxed_reader(Stream, char, State, Error), stream.putback(Stream, char, State, Error)], apply_to_superclasses, [subst([Stream => io.text_input_stream, State => io.state, Error => io.error])]). allows programmers to ask the compiler to create type-specialized versions of all predicates and functions, in a module and its submodules, that have one or more of the specified typeclass constraints. The first argument specifies these constraints, of which the example above has three. The second argument specifies whether the request also applies to predicates and functions whose signatures include superclasses of the type classes involved (or *their* superclasses, and so on), not the named type classes themselves. The third argument specifies the requested list of one or more specializations, each of which consists of a substitution that maps one or more type variables to a type. (A type that should not itself be a type variable.) This example requests just one specialization for each match. compiler/prog_item.m: Add a new kind of decl_pragma item to represent the new pragma. Define the new types it needs. Add some documentation of the invariants of existing item kinds. compiler/prog_data.m: Define ground_type, a subtype of mer_type, for use by prog_item.m. compiler/prog_type_test.m: Add a utility predicate for converting a type to a ground_type, if it is indeed ground. compiler/prog_data_pragma.m: Change the definition of the type_subst type to use a purpose-specific function symbol instead of the pair function symbol. compiler/parse_pragma.m: Add code to parse the new pragma, and to check the parsed form to see whether it violates the requirements upon it. Modify the code that parses plain old type_spec pragma to also allow subst([State = io.state, Error = io.error]) syntax to be used to specify type substitutions, as discussed on m-rev. Modify the code that parses the old substitution syntax to use the infrastructure of the new syntax, which can generate better error messages. Change this now-common code to allow the two sides of a substitution to be separated by either an equal sign (such as "State = io.state") or an arrow (such as "Error => io.error"). Improve the wording of some error messages. Delete the code that accepted and then ignored a third argument in type_spec pragmas. This code was needed only until a change committed in July 2022 finished bootstrapping. vim/syntax/mercury.vim: Add the new pragma's name to the list of pragma keywords. compiler/add_pragma.m: compiler/add_pragma_type_spec.m: Add code to process the new pragma. Add code to debug the processing of the new pragma. Change the code that processes the old type_spec pragma, - to avoid using mode-specific clauses if the specialization applies to the whole predicate and not just one procedure of it (this avoids a bug that I reported on m-rev on 2024 feb 2), and - to set the context of type-specialized predicates to match the original predicates, instead of leaving them set to the default context, which is a dummy context (this helps avoid error messages whose lack of context can make it hard to figure out what exactly they are complaining about). compiler/options.m: doc/user_guide.texi: Add an option that add_pragma_type_spec.m now consults to decide whether to report the type_spec pragmas generated to implement each type_spec_constrained_preds pragma. The documentation of this option is commented out. It should be made visible to users once we have (a) gathered sufficient experience with the new pragma to have confidence in it, and (b) documented the pragma itself. Add a way to check whether this diff exists in the compiler. compiler/handle_options.m: Automatically disable the new option for all invocations other than those that generate code or check errors, since the output they generate would be more distracting than useful e.g. when making .intN files. compiler/parse_class.m: Restructure the code that selects superclass constraints (constraints on typeclass declarations) out of the whole set of constraints that a predicate that is designed to parse constraints on *predicate* declarations has parsed. The two use cases are different, because neither inst constraints, nor typeclass constraints involving partially-specified types, are allowed in typeclass declarations. The restructure allows us to improve the error messages we generate if and when any such disallowed constraints are found. compiler/parse_tree_out_pragma.m: Add code to output the new pragma. Add code to try to avoid putting redundant parentheses around name/arity pairs. It needs new code to be enabled in parse_tree_out_sym_name.m to work. compiler/parse_tree_out_type.m: Generalize (and rename) an existing function. compiler/parse_tree_out_sym_name.m: Add code (commented out for now) that can avoid putting redundant parentheses around name/arity pairs. compiler/maybe_error.m: Define maybeN for N = 6, to join N = {1,2,3,4,5}, for use by new code above. mdbcomp/sym_name.m: Fix a misleading predicate name. compiler/hlds_class.m: Document an invariant. compiler/hlds_module.m: Replace a multi_map with a one_or_more_map, and give a name to the type. compiler/parse_item.m: Fix comments. compiler/parse_tree_out_inst.m: Add a new utility function needed by other code in this diff. compiler/hlds_out_typeclass_table.m: Clarify the typeclass table part of HLDS dumps. compiler/check_import_accessibility.m: compiler/check_typeclass.m: compiler/convert_parse_tree.m: compiler/equiv_type.m: compiler/intermod.m: compiler/item_util.m: compiler/make_hlds_passes.m: compiler/make_hlds_separate_items.m: compiler/module_qual.qual_errors.m: compiler/module_qual.qualify_items.m: compiler/parse_type_name.m: compiler/pred_name.m: compiler/prog_item_stats.m: compiler/recompilation.usage.m: compiler/recompilation.version.m: mdbcomp/slice_and_dice.m: Conform to the changes above. compiler/prog_type_unify.m: Fix indentation. tests/hard_coded/type_spec_modes.m: Modify this test to see whether the code parsing type substitutions in type_spec pragmas using the new syntax works. tests/invalid_nodepend/typeclass_test_3.err_exp: Expect the improved error message parse_class.m now generates. tests/invalid_nodepend/bad_tscp.{m,exp}: Add this test case to check the error messages generated by parse_pragma.m to report the problems it detects in malformed type_spec_constrained_preds pragmas. tests/invalid_nodepend/Mmakefile: Enable the new test case. tests/warnings/test_tscp.{m,exp}: Add a test case that checks whether, given a list of the new pragmas, the compiler generates the expected set of type_spec pragmas. tests/warnings/{Mmakefile,Mercury.options}: Enable the new test case. --- compiler/add_pragma.m | 35 +- compiler/add_pragma_type_spec.m | 1281 ++++++++++++++++- compiler/check_import_accessibility.m | 2 +- compiler/check_typeclass.m | 4 +- compiler/convert_parse_tree.m | 2 + compiler/equiv_type.m | 137 +- compiler/handle_options.m | 51 +- compiler/hlds_class.m | 6 + compiler/hlds_module.m | 9 +- compiler/hlds_out_typeclass_table.m | 10 +- compiler/intermod.m | 5 +- compiler/item_util.m | 4 + compiler/make_hlds_passes.m | 6 +- compiler/make_hlds_separate_items.m | 49 +- compiler/maybe_error.m | 19 + compiler/module_qual.qual_errors.m | 11 + compiler/module_qual.qualify_items.m | 120 +- compiler/options.m | 10 + compiler/parse_class.m | 204 ++- compiler/parse_item.m | 14 +- compiler/parse_pragma.m | 726 +++++++++- compiler/parse_tree_out_inst.m | 8 + compiler/parse_tree_out_pragma.m | 119 +- compiler/parse_tree_out_sym_name.m | 13 + compiler/parse_tree_out_type.m | 26 +- compiler/parse_type_name.m | 4 + compiler/pred_name.m | 7 +- compiler/prog_data.m | 9 + compiler/prog_data_pragma.m | 6 +- compiler/prog_item.m | 85 +- compiler/prog_item_stats.m | 1 + compiler/prog_type_test.m | 40 +- compiler/prog_type_unify.m | 4 +- compiler/recompilation.usage.m | 7 +- compiler/recompilation.version.m | 145 +- doc/user_guide.texi | 7 + mdbcomp/slice_and_dice.m | 12 +- mdbcomp/sym_name.m | 16 +- tests/hard_coded/type_spec_modes.m | 2 +- tests/invalid/Mmakefile | 1 + tests/invalid/bad_tscp.err_exp | 30 + tests/invalid/bad_tscp.m | 79 + .../invalid_nodepend/typeclass_test_3.err_exp | 4 +- tests/warnings/Mercury.options | 2 + tests/warnings/Mmakefile | 1 + tests/warnings/test_tscp.exp | 18 +- tests/warnings/test_tscp.m | 78 +- vim/syntax/mercury.vim | 1 + 48 files changed, 3095 insertions(+), 335 deletions(-) create mode 100644 tests/invalid/bad_tscp.err_exp create mode 100644 tests/invalid/bad_tscp.m diff --git a/compiler/add_pragma.m b/compiler/add_pragma.m index c83337149..71db18ae7 100644 --- a/compiler/add_pragma.m +++ b/compiler/add_pragma.m @@ -21,7 +21,13 @@ %---------------------------------------------------------------------------% -:- pred add_decl_pragmas(ims_list(item_decl_pragma_info)::in, +:- pred add_decl_pragmas(io.text_output_stream::in, + ims_list(item_decl_pragma_info)::in, + module_info::in, module_info::out, qual_info::in, qual_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + +:- pred add_decl_pragmas_type_spec_constr(io.text_output_stream::in, + list(decl_pragma_type_spec_constr_info)::in, module_info::in, module_info::out, qual_info::in, qual_info::out, list(error_spec)::in, list(error_spec)::out) is det. @@ -151,12 +157,21 @@ % Adding decl pragmas to the HLDS. % -add_decl_pragmas([], !ModuleInfo, !QualInfo, !Specs). -add_decl_pragmas([ImsList | ImsLists], !ModuleInfo, !QualInfo, !Specs) :- +add_decl_pragmas(_, [], !ModuleInfo, !QualInfo, !Specs). +add_decl_pragmas(ProgressStream, [ImsList | ImsLists], + !ModuleInfo, !QualInfo, !Specs) :- ImsList = ims_sub_list(ItemMercuryStatus, Items), - list.foldl3(add_decl_pragma(ItemMercuryStatus), Items, + list.foldl3(add_decl_pragma(ProgressStream, ItemMercuryStatus), Items, !ModuleInfo, !QualInfo, !Specs), - add_decl_pragmas(ImsLists, !ModuleInfo, !QualInfo, !Specs). + add_decl_pragmas(ProgressStream, ImsLists, !ModuleInfo, !QualInfo, !Specs). + +add_decl_pragmas_type_spec_constr(_, [], !ModuleInfo, !QualInfo, !Specs). +add_decl_pragmas_type_spec_constr(ProgressStream, [Pragma | Pragmas], + !ModuleInfo, !QualInfo, !Specs) :- + add_pragma_type_spec_constr(ProgressStream, Pragma, + !ModuleInfo, !QualInfo, !Specs), + add_decl_pragmas_type_spec_constr(ProgressStream, Pragmas, + !ModuleInfo, !QualInfo, !Specs). add_decl_pragmas_type_spec([], !ModuleInfo, !QualInfo, !Specs). add_decl_pragmas_type_spec([Pragma | Pragmas], @@ -186,11 +201,13 @@ add_decl_pragmas_reuse([Pragma | Pragmas], !ModuleInfo, !Specs) :- %---------------------% -:- pred add_decl_pragma(item_mercury_status::in, item_decl_pragma_info::in, +:- pred add_decl_pragma(io.text_output_stream::in, item_mercury_status::in, + item_decl_pragma_info::in, module_info::in, module_info::out, qual_info::in, qual_info::out, list(error_spec)::in, list(error_spec)::out) is det. -add_decl_pragma(ItemMercuryStatus, Pragma, !ModuleInfo, !QualInfo, !Specs) :- +add_decl_pragma(ProgressStream, ItemMercuryStatus, Pragma, + !ModuleInfo, !QualInfo, !Specs) :- ( Pragma = decl_pragma_obsolete_pred(ObsoletePredInfo), mark_pred_as_obsolete(ObsoletePredInfo, ItemMercuryStatus, @@ -203,6 +220,10 @@ add_decl_pragma(ItemMercuryStatus, Pragma, !ModuleInfo, !QualInfo, !Specs) :- Pragma = decl_pragma_format_call(FormatCallInfo), mark_pred_as_format_call(FormatCallInfo, ItemMercuryStatus, !ModuleInfo, !Specs) + ; + Pragma = decl_pragma_type_spec_constr(TypeSpecConstrInfo), + add_pragma_type_spec_constr(ProgressStream, TypeSpecConstrInfo, + !ModuleInfo, !QualInfo, !Specs) ; Pragma = decl_pragma_type_spec(TypeSpecInfo), add_pragma_type_spec(TypeSpecInfo, !ModuleInfo, !QualInfo, !Specs) diff --git a/compiler/add_pragma_type_spec.m b/compiler/add_pragma_type_spec.m index 1e1ac5bd8..fe0d2d7fd 100644 --- a/compiler/add_pragma_type_spec.m +++ b/compiler/add_pragma_type_spec.m @@ -1,10 +1,10 @@ -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et -%-----------------------------------------------------------------------------% -% Copyright (C) 2015 The Mercury team. +%---------------------------------------------------------------------------% +% Copyright (C) 2015,2024 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. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% :- module hlds.make_hlds.add_pragma.add_pragma_type_spec. :- interface. @@ -16,15 +16,21 @@ :- import_module list. +:- pred add_pragma_type_spec_constr(io.text_output_stream::in, + decl_pragma_type_spec_constr_info::in, + module_info::in, module_info::out, qual_info::in, qual_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + :- pred add_pragma_type_spec(decl_pragma_type_spec_info::in, module_info::in, module_info::out, qual_info::in, qual_info::out, list(error_spec)::in, list(error_spec)::out) is det. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% :- implementation. :- import_module hlds.hlds_args. +:- import_module hlds.hlds_class. :- import_module hlds.hlds_code_util. :- import_module hlds.hlds_goal. :- import_module hlds.hlds_rtti. @@ -36,9 +42,14 @@ :- import_module libs.options. :- import_module mdbcomp. :- import_module mdbcomp.sym_name. +:- import_module parse_tree.parse_tree_out_info. +:- import_module parse_tree.parse_tree_out_pragma. +:- import_module parse_tree.parse_tree_out_sym_name. :- import_module parse_tree.parse_tree_out_term. +:- import_module parse_tree.parse_tree_out_type. :- import_module parse_tree.prog_type_scan. :- import_module parse_tree.prog_type_subst. +:- import_module parse_tree.prog_type_test. :- import_module parse_tree.prog_util. :- import_module parse_tree.set_of_var. :- import_module parse_tree.var_table. @@ -50,11 +61,1193 @@ :- import_module maybe. :- import_module multi_map. :- import_module one_or_more. +:- import_module one_or_more_map. :- import_module pair. :- import_module set. +:- import_module string. +:- import_module term. +:- import_module term_context. :- import_module varset. -%-----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +add_pragma_type_spec_constr(ProgressStream, TypeSpecConstr, + !ModuleInfo, !QualInfo, !Specs) :- + % The general approach we use to implement type_spec_constrained_preds + % pragmas is to compute the set of ordinary type_spec pragmas they + % correspond to, and add *those* to !ModuleInfo. + TypeSpecConstr = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints, ApplyToSupers, OoMTypeSubsts, PragmaTVarSet, _, + Context, _), + module_info_get_class_table(!.ModuleInfo, ClassTable), + % Start by finding out which typeclass constraints we should look for + % in the predicates in the predicate table. This includes checking + % whether all the type classes named in OoMConstraints actually exist. + Constraints = one_or_more_to_list(OoMConstraints), + list.foldl2( + build_class_constraint_map(ClassTable, ApplyToSupers, PragmaTVarSet), + Constraints, map.init, ClassConstraintMap, [], ClassSpecs), + ( + ClassSpecs = [], + % All the typeclass constraints in OoMConstraints exist. + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + io.output_stream(Stream, !IO), + ClassConstraintMapAL = + one_or_more_map.to_flat_assoc_list(ClassConstraintMap), + io.nl(Stream, !IO), + list.foldl(write_class_constraint_map_entry(Stream, PragmaTVarSet), + ClassConstraintMapAL, !IO) + ), + % Check all predicates defined in either ModuleName or its submodules + % to see whether they include one or more of the typeclass constraints + % we are looking out for, and when we find one, generate type_spec + % pragmas for that predicate for all the substitutions in + % OoMTypeSubsts. + module_info_get_predicate_table(!.ModuleInfo, PredTable), + predicate_table_get_pred_id_table(PredTable, PredIdTable), + map.foldl_values( + maybe_generate_pragma_type_specs_for_pred(ModuleName, + ClassConstraintMap, PragmaTVarSet, OoMTypeSubsts), + PredIdTable, [], Pragmas), + % For one reason for why Pragmas may contain duplicates, + % see the comment about this in build_class_constraint_map. + % That one is about different but equivalent instances of + % the same type class. Another reason is that instances of + % different type classes may result in the same specialization + % request. + list.sort_and_remove_dups(Pragmas, SortedPragmas), + module_info_get_globals(!.ModuleInfo, Globals), + globals.lookup_bool_option(Globals, + inform_generated_type_spec_pragmas, Inform), + ( + Inform = no + ; + Inform = yes, + trace [io(!IO)] ( + Context = context(FileName, LineNumber), + io.format(ProgressStream, + "%% For the type_spec_constrained_preds pragma" ++ + " at %s:%d,\n", + [s(FileName), i(LineNumber)], !IO), + io.write_string(ProgressStream, + "% the compiler generated ", !IO), + ( + SortedPragmas = [], + io.write_string(ProgressStream, + "no type_spec pragmas.\n", !IO) + ; + SortedPragmas = [_ | _], + io.write_string(ProgressStream, + "these type_spec pragmas:\n", !IO), + list.foldl(report_generated_pragma(ProgressStream), + SortedPragmas, !IO) + ) + ) + ), + % Actually add the generated type_spec pragmas to !ModuleInfo. + % + % XXX Since Pragmas were generated by the compiler, if adding them + % to !ModuleInfo results in any errors, they are the compiler's fault, + % not the user's. But for now, we want to report them, because if + % we ignored them, we would never be alerted to their existence. + list.foldl3(add_pragma_type_spec, SortedPragmas, + !ModuleInfo, !QualInfo, !Specs) + ; + ClassSpecs = [_ | _], + !:Specs = ClassSpecs ++ !.Specs + ). + +%---------------------% + + % Values of this type represent the set of typeclass constraints + % we want to specialize. Each class_id in here will correspond + % either to a constraint in a type_spec_constrained_preds pragma, + % one its superclasses, or one of *their* superclasses, and so on. + % + % We may be on the lookout for more than one instance of a given class, + % since the constraints in the pragma may refer to multiple instances + % of that class, either directly, or indirectly through superclasses. + % + % All type variables in values of these types come from the pragma. +:- type type_spec_constraint_map == one_or_more_map(class_id, arg_vector). +:- type arg_vector + ---> arg_vector(list(var_or_ground_type)). + + % Build the set of typeclass instances we need to look for to handle + % a given type_spec_constrained_preds pragma. This will include the + % constraints in the first argument of the type_spec_constrained_preds + % pragma, but may include their projections to their superclasses as well. + % +:- pred build_class_constraint_map(class_table::in, maybe_apply_to_supers::in, + tvarset::in, var_or_ground_constraint::in, + type_spec_constraint_map::in, type_spec_constraint_map::out, + list(error_spec)::in, list(error_spec)::out) is det. + +build_class_constraint_map(ClassTable, ApplyToSupers, PragmaTVarSet, + Constraint, !ClassConstraintMap, !Specs) :- + Constraint = + var_or_ground_constraint(ClassSymName, VarOrGroundTypes, Context), + list.length(VarOrGroundTypes, NumTypes), + ClassId = class_id(ClassSymName, NumTypes), + ( if map.search(ClassTable, ClassId, ClassDefn) then + ArgVector = arg_vector(VarOrGroundTypes), + ( if map.search(!.ClassConstraintMap, ClassId, ArgVectors0) then + ( if one_or_more.member(ArgVector, ArgVectors0) then + OldOrNew = "main old" + else + OldOrNew = "main nw+", + % It is possible for ArgVector to differ from an entry already + % in ArgVectors0 *only* in the number and/or the name of a type + % variable. If this is the case, then adding ArgVector + % to the map will cause our caller to generate duplicate + % type_spec pragmas. We handle this by having our caller + % remove duplicates while sorting those pragmas. This requires + % less code than checking for such differences here, while + % causing duplicate work to be done only in a situation + % that is extremely unlikely to arise in practice. + one_or_more_map.add(ClassId, ArgVector, !ClassConstraintMap) + ) + else + OldOrNew = "main new", + one_or_more_map.add(ClassId, ArgVector, !ClassConstraintMap) + ), + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + EntryStr = class_constraint_map_entry_to_string(PragmaTVarSet, + OldOrNew, ClassId, ArgVector), + io.output_stream(Stream, !IO), + io.nl(Stream, !IO), + io.write_string(Stream, EntryStr, !IO) + ), + ( + ApplyToSupers = do_not_apply_to_supers + ; + ApplyToSupers = apply_to_supers, + ClassTVars = ClassDefn ^ classdefn_vars, + map.from_corresponding_lists(ClassTVars, VarOrGroundTypes, Subst0), + Supers = ClassDefn ^ classdefn_supers, + list.foldl( + build_superclass_constraint_map(ClassTable, PragmaTVarSet, + Context, Subst0), + Supers, !ClassConstraintMap) + ) + else + Pieces = [words("In the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), nl, + words("error: the constraint list references"), + words("a type class named"), qual_class_id(ClassId), suffix(","), + words("but there is no visible type class"), + words("with this name and arity."), nl], + % XXX TSCP Warn about other arities, and "did you mean" close enough + % class names + % XXX Make any code for doing that general enough to handle + % all other error messages about references to unknown classes. + Spec = simplest_spec($pred, severity_error, phase_parse_tree_to_hlds, + Context, Pieces), + !:Specs = [Spec | !.Specs] + ). + + % This predicate does the same job as build_class_constraint_map above, + % but specialized to the situation where Constraint comes *not* from + % the original pragma, but from being the Nth level superclass of + % one of those constraints. This requires different handling, because + % any errors we find here are caused by typeclass declarations elsewhere, + % *not* by the pragma we are processing. + % +:- pred build_superclass_constraint_map(class_table::in, tvarset::in, + prog_context::in, map(tvar, var_or_ground_type)::in, prog_constraint::in, + type_spec_constraint_map::in, type_spec_constraint_map::out) is det. + +build_superclass_constraint_map(ClassTable, PragmaTVarSet, Context, + Subst0, Constraint, !ClassConstraintMap) :- + constraint_get_class_id_and_types(Constraint, ClassId, Types), + ( if map.search(ClassTable, ClassId, ClassDefn) then + compute_superclass_arg_types(Subst0, Types, VarOrGroundTypes), + ArgVector = arg_vector(VarOrGroundTypes), + ( if map.search(!.ClassConstraintMap, ClassId, ArgVectors0) then + ( if one_or_more.member(ArgVector, ArgVectors0) then + OldOrNew = "super old" + else + OldOrNew = "super nw+", + one_or_more_map.add(ClassId, ArgVector, !ClassConstraintMap) + ) + else + OldOrNew = "super new", + one_or_more_map.add(ClassId, ArgVector, !ClassConstraintMap) + ), + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + EntryStr = class_constraint_map_entry_to_string(PragmaTVarSet, + OldOrNew, ClassId, ArgVector), + io.output_stream(Stream, !IO), + io.write_string(Stream, EntryStr, !IO) + ), + + ClassTVars = ClassDefn ^ classdefn_vars, + map.from_corresponding_lists(ClassTVars, VarOrGroundTypes, Subst), + Supers = ClassDefn ^ classdefn_supers, + list.foldl( + build_superclass_constraint_map(ClassTable, PragmaTVarSet, + Context, Subst), + Supers, !ClassConstraintMap) + else + % The non-existence of the superclass is an error, but it is an error + % in the declaration of the subclass, not an error in the pragma + % we are processing. The error will reported when we process the + % declaration of the subclass; reporting it here also would not + % help the user. + true + ). + +%---------------------% + +:- pred compute_superclass_arg_types(map(tvar, var_or_ground_type)::in, + list(mer_type)::in, list(var_or_ground_type)::out) is det. + +compute_superclass_arg_types(_, [], []). +compute_superclass_arg_types(Subst, [Type | Types], + [VarOrGroundType | VarOrGroundTypes]) :- + ( if Type = type_variable(Var, _) then + map.lookup(Subst, Var, VarOrGroundType) + else if type_is_ground(Type, GroundType) then + VarOrGroundType = ground_type(GroundType) + else + unexpected($pred, "type is not var or ground") + ), + compute_superclass_arg_types(Subst, Types, VarOrGroundTypes). + +%---------------------------------------------------------------------------% + +:- pred maybe_generate_pragma_type_specs_for_pred(module_name::in, + type_spec_constraint_map::in, tvarset::in, one_or_more(type_subst)::in, + pred_info::in, + list(decl_pragma_type_spec_info)::in, + list(decl_pragma_type_spec_info)::out) is det. + +maybe_generate_pragma_type_specs_for_pred(PragmaModuleName, ClassConstraintMap, + PragmaTVarSet, OoMTypeSubsts, PredInfo, !Pragmas) :- + pred_info_get_module_name(PredInfo, PredModuleName), + ( if + is_same_module_or_submodule(PredModuleName, PragmaModuleName), + pred_info_get_class_context(PredInfo, ClassContext), + ClassContext = + univ_exist_constraints(UnivConstraints, _ExistConstraints), + UnivConstraints = [_ | _], + % We don't want to type-specialize predicates create by + % other type_spec pragmas, either user-provided or compiler-generated, + % for two reasons. + % + % First, it does not work; it seems that the way we set up + % the predicates created by type specialization differs from + % how we set up ordinary class-constrained predicates, in way + % that causes compiler errors on a *second* application of type + % specialization. (I -zs- don't know what the difference is exactly, + % but you could delete this test and find out. The test data for it + % was juliensf's csv parser, as it was on 2024 feb 1.) + % + % Second, even if type-specializing a type-specialized predicate + % worked, the result would depend on the *order* in which we processed + % type_spec pragmas, which is not a good idea. + pred_info_get_origin(PredInfo, Origin), + is_pred_origin_type_spec(Origin) = origin_is_not_type_spec + then + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + pred_info_get_name(PredInfo, PredName), + pred_info_get_context(PredInfo, PredContext), + PredContext = context(File, Line), + io.output_stream(Stream, !IO), + io.format(Stream, + "\nProcessing %s at %s:%d\n", + [s(PredName), s(File), i(Line)], !IO) + ), + generate_type_spec_solns_for_pred(ClassConstraintMap, PragmaTVarSet, + PredInfo, UnivConstraints, Solns), + list.foldl( + generate_pragma_type_specs_for_pred_soln(PragmaModuleName, + PragmaTVarSet, PredInfo, OoMTypeSubsts), + Solns, !Pragmas) + else + true + ). + +:- type is_origin_type_spec + ---> origin_is_not_type_spec + ; origin_is_type_spec. + +:- func is_pred_origin_type_spec(pred_origin) = is_origin_type_spec. + +is_pred_origin_type_spec(Origin) = IsTypeSpec :- + ( + ( Origin = origin_user(_) + ; Origin = origin_compiler(_) + ), + IsTypeSpec = origin_is_not_type_spec + ; + Origin = origin_proc_transform(_, BeforeTransformOrigin, _, _), + IsTypeSpec = is_pred_origin_type_spec(BeforeTransformOrigin) + ; + Origin = origin_pred_transform(PredTransform, + BeforeTransformOrigin, _), + ( + PredTransform = pred_transform_pragma_type_spec(_), + IsTypeSpec = origin_is_type_spec + ; + ( PredTransform = pred_transform_distance_granularity(_) + ; PredTransform = pred_transform_table_generator + ; PredTransform = pred_transform_ssdebug(_) + ; PredTransform = pred_transform_structure_reuse + ), + IsTypeSpec = is_pred_origin_type_spec(BeforeTransformOrigin) + ) + ). + +%---------------------% + + % Figure out which type vars in the given predicate's signature + % should be specialized to which types specified in the the + % type_spec_constrained_preds pragma we are processing. + % +:- pred generate_type_spec_solns_for_pred(type_spec_constraint_map::in, + tvarset::in, pred_info::in, list(prog_constraint)::in, + list(subst_soln)::out) is det. + +generate_type_spec_solns_for_pred(ClassConstraintMap, PragmaTVarSet, PredInfo, + UnivConstraints, Solns) :- + pred_info_get_typevarset(PredInfo, PredTVarSet), + % Find out the substitutions implied by each constraint that occurs + % in both the predicate's class context and in the first argument + % of the type_spec_constrained_preds pragma. This code calls these + % substitutions "solutions". + % + % If the predicate's class context contains two or more constraints + % for the same typeclass, record all of the resulting solutions + % as alternatives for that class. + list.foldl( + acc_class_ground_substs(PragmaTVarSet, PredTVarSet, + ClassConstraintMap), + UnivConstraints, map.init, ClassSolnsMap), + map.to_sorted_assoc_list(ClassSolnsMap, ClassSolnsMapAL), + ( + ClassSolnsMapAL = [], + Solns = [] + ; + ClassSolnsMapAL = [HeadClassSoln | TailClassSolns], + % There is at least one typeclass that occurs in both the predicate's + % class context and in the first argument of the pragma. + % If there are two or more, each of which may have more than one + % solution (though almost all will have just one), then consider + % all possible combinations that take one solution from each typeclass, + % and see whether they are compatible. Return, as SolnSetSet, + % the resulting combined solutions. + find_all_ground_subst_combinations(PragmaTVarSet, PredTVarSet, + HeadClassSoln, TailClassSolns, SolnSet), + set.to_sorted_list(SolnSet, Solns) + ), + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + SolnsStr = dump_subst_soln_list(PragmaTVarSet, PredTVarSet, "\n", + 1, Solns), + io.output_stream(Stream, !IO), + io.write_string(Stream, "Solns:\n", !IO), + io.write_string(Stream, SolnsStr, !IO), + io.write_string(Stream, "end Solns\n", !IO) + ). + +%---------------------% + + % This maps each class_id that has a constraint in the first argument + % of the type_spec_constrained_preds pragma we are processing, either + % directly or (if allowed) indirectly as a superclass, to the set of + % substitutions specified by those constraints. + % + % It is this type that requires subst_soln to be a type that has + % a canonical representation. + % +:- type class_solns_map == map(class_id, set(subst_soln)). + + % Values of this type represent either + % + % - the substitutions in a class_solns_map (in which case they are + % implicitly for the class whose class_id is the corresponding key), or + % + % - the result of unifying one ore more of those class-specific solutions. + % + % The latter are both the intermediate data structures, and the final + % result, of find_all_ground_subst_combinations. + % +:- type subst_soln + ---> subst_soln( + % This is a map from the predicate's type vars to the types + % in the pragma's first argument, but in a form which has + % a canonical representation, which allows us to construct + % a set of ground_substs without worrying that the set + % contains two (or more) elements that are syntactically + % different but semantically identical. + set(ground_or_tvar_subst), + + % For the subset of the entries in the previous field + % where the type in the pragma's first arg is a variable, + % a map from the pragma's tvar back to the predicate's tvar, + % again in a form with a canonical representation. + set(pragma_to_pred_tvar) + ). + +:- type ground_or_tvar_subst + ---> ground_or_tvar_subst(tvar, var_or_ground_type). + % Map from the predicate's type vars to the types + % in the pragma's first argument. + +:- type pragma_to_pred_tvar + ---> pragma_to_pred_tvar(tvar, tvar). + % The first tvar is from the pragma's tvarset, the second + % is from the predicate's tvarset. + +%---------------------% + + % Accumulate in !SolnsMap the set of solutions for the given typeclass. + % +:- pred acc_class_ground_substs(tvarset::in, tvarset::in, + type_spec_constraint_map::in, prog_constraint::in, + class_solns_map::in, class_solns_map::out) is det. + +acc_class_ground_substs(PragmaTVarSet, PredTVarSet, ClassConstraintMap, + Constraint, !SolnsMap) :- + constraint_get_class_id_and_types(Constraint, ClassId, Types), + ( if map.search(ClassConstraintMap, ClassId, OoMClassArgVectors) then + ClassArgVectors = one_or_more_to_list(OoMClassArgVectors), + acc_matching_arg_vectors(PragmaTVarSet, PredTVarSet, ClassId, Types, + ClassArgVectors, !SolnsMap) + else + true + ). + +:- pred acc_matching_arg_vectors(tvarset::in, tvarset::in, + class_id::in, list(mer_type)::in, list(arg_vector)::in, + class_solns_map::in, class_solns_map::out) is det. + +acc_matching_arg_vectors(_, _, _, _Types, [], !SolnsMap). +acc_matching_arg_vectors(PragmaTVarSet, PredTVarSet, ClassId, Types, + [ArgVector | ArgVectors], !SolnsMap) :- + % Types come from PredTVarSet, ArgVectors come from PragmaTVarSet. + ArgVector = arg_vector(VarOrGroundTypes), + ( if + is_matching_arg_vector(Types, VarOrGroundTypes, + map.init, Subst, map.init, RevTVarMap) + then + map.to_sorted_assoc_list(Subst, SubstAL), + PairToGroundOrTVarSubst = + (func(TV - VoG) = ground_or_tvar_subst(TV, VoG)), + GroundOrTVarSubsts = list.map(PairToGroundOrTVarSubst, SubstAL), + GroundOrTVarSubstSet = set.sorted_list_to_set(GroundOrTVarSubsts), + + map.to_sorted_assoc_list(RevTVarMap, RevTVarMapAL), + PairToPragmaToPred = + (func(Prag - Pred) = pragma_to_pred_tvar(Prag, Pred)), + PragmaToPreds = list.map(PairToPragmaToPred, RevTVarMapAL), + PragmaToPredsSet = set.sorted_list_to_set(PragmaToPreds), + + SubstSoln = subst_soln(GroundOrTVarSubstSet, PragmaToPredsSet), + ( if map.search(!.SolnsMap, ClassId, SubstSolns0) then + set.insert(SubstSoln, SubstSolns0, SubstSolns), + map.det_update(ClassId, SubstSolns, !SolnsMap) + else + SubstSolns = set.make_singleton_set(SubstSoln), + map.det_insert(ClassId, SubstSolns, !SolnsMap) + ), + + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + TypesStr = mercury_types_to_string(PredTVarSet, print_name_and_num, + Types), + ArgVectorStr = arg_vector_to_string(PragmaTVarSet, ArgVector), + SolnStr = + dump_subst_soln(PragmaTVarSet, PredTVarSet, "", SubstSoln), + io.output_stream(Stream, !IO), + io.format(Stream, "\nacc_matching_arg_vector for %s\n", + [s(class_id_to_string(ClassId))], !IO), + io.format(Stream, "types: %s\n", [s(TypesStr)], !IO), + io.format(Stream, "arg_vector: %s\n", [s(ArgVectorStr)], !IO), + io.format(Stream, "subst_soln: %s\n", [s(SolnStr)], !IO) + ) + else + true + ), + acc_matching_arg_vectors(PragmaTVarSet, PredTVarSet, ClassId, Types, + ArgVectors, !SolnsMap). + +%---------------------% + + % The first argument is the list of the argument types of a typeclass + % from the class context of the predicate we are processing. + % The second argument is either the list of argument types of a constraint + % in the first argument of the type_spec_constrained_preds pragma + % we are also processing, or is the list of corresponding argument types + % of its superclass, or *its* superclass, and so on. + % + % The first arg may contain arbitrary type variables anywhere. + % The types in the second arg will be either variables or ground terms, + % with nothing in between. Any type variables in it should also be + % distinct (XXX is this guaranteed to be true?) but we can't express + % that invariant in the type system, and we don't (yet) check that + % it actually holds. + % + % This predicate tests whether the constraint from the predicate + % has the constraint from the pragma as an instance. If it does, + % we succeed, and return + % + % - the substitution from predicate tvars to pragma types specifying + % that instance, as !:Subst, and + % - the tvar-to-tvar part of that substitution in reverse form, i.e. + % as a renaming from pragma tvars to predicate tvars, as !:RevTVarMap. + % +:- pred is_matching_arg_vector(list(mer_type)::in, + list(var_or_ground_type)::in, + map(tvar, var_or_ground_type)::in, map(tvar, var_or_ground_type)::out, + map(tvar, tvar)::in, map(tvar, tvar)::out) is semidet. + +is_matching_arg_vector([], [], !Subst, !RevTVarMap). +is_matching_arg_vector([Type | Types], [VarOrGroundType | VarOrGroundTypes], + !Subst, !RevTVarMap) :- + is_matching_arg_type(Type, VarOrGroundType, !Subst, !RevTVarMap), + is_matching_arg_vector(Types, VarOrGroundTypes, !Subst, !RevTVarMap). + +:- pred is_matching_arg_type(mer_type::in, var_or_ground_type::in, + map(tvar, var_or_ground_type)::in, map(tvar, var_or_ground_type)::out, + map(tvar, tvar)::in, map(tvar, tvar)::out) is semidet. + +is_matching_arg_type(Type, VarOrGroundType, !Subst, !RevTVarMap) :- + % There should not be any tvar-to-tvar-to-tvar bindings, because + % any tvars in Type can be mapped only to things in VarOrGroundType, + % which then cannot be mapped any further. + ( if Type = type_variable(TVar, kind_star) then + ( if map.search(!.Subst, TVar, OldBinding) then + ( + VarOrGroundType = ground_type(_GroundType), + % Since VarOrGroundType is ground_type, we *require* this + % argument type to be ground. Therefore we cannot allow + % a type variable to match a ground type. + fail + ; + VarOrGroundType = type_var_name(_VoGTypeVar, _VoGTypeName), + % tVar cannot be allowed to simultaneously match + % both VoGTypeVar and either + % - a different VoGTypeVar, or + % - any ground type. + ( if OldBinding = VarOrGroundType then + true + else + fail + ) + ) + else + map.det_insert(TVar, VarOrGroundType, !Subst), + ( + VarOrGroundType = ground_type(_) + ; + VarOrGroundType = type_var_name(VoGTypeVar, _), + ( if map.insert(VoGTypeVar, TVar, !RevTVarMap) then + true + else + fail + ) + ) + ) + else + ( + VarOrGroundType = ground_type(GroundType), + % Since VarOrGroundType is ground_type, we *require* this + % argument type to be ground. Therefore we cannot allow + % a non-ground Type such as map(K, string) to match + % a GroundType such as map(int, string). + ( if Type = coerce(GroundType) then + true + else + fail + ) + ; + VarOrGroundType = type_var_name(_VoGTypeVar, _VoGTypeName), + % VarOrGroundType makes no demands on Type. + true + ) + ). + +%---------------------% + + % find_all_ground_subst_combinations(PragmaTVarSet, PredTVarSet, + % HeadClassId - HeadSubstSolnSet, TailClassIdsSubstSolns, + % FinalSubstSet): + % + % Unify all the class-specific solutions in HeadSubstSolnSet with + % all the class-specific solutions in TailClassIdsSubstSolns, + % considering all possible combinations that take one solution + % from each class-specific solution set. + % + % While a combinatorial blowup is *theoretically* possible, + % it will almost certainly be vanishingly rare in practice, + % both because the class contexts of most predicates contain + % only very small number of constraints, and because it is very rare + % for two or more of those constraints to involved the same typeclass. + % +:- pred find_all_ground_subst_combinations(tvarset::in, tvarset::in, + pair(class_id, set(subst_soln))::in, + assoc_list(class_id, set(subst_soln))::in, set(subst_soln)::out) is det. + +find_all_ground_subst_combinations(PragmaTVarSet, PredTVarSet, + HeadClassId - HeadSubstSolnSet, TailClassIdsSubstSolns, + FinalSubstSet) :- + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + io.output_stream(Stream, !IO), + io.write_string(Stream, "\nfind_all_ground_subst_combinations\n", !IO), + % Printing HeadClassId here can be slightly misleading, as + % HeadSubstSolnSet will corresponding to HeadClassId only for the + % top-level invocation of find_all_ground_subst_combinations. + % For all later invocations, it will correspond to the + % result of unifying all the solution sets for the class_ids + % we have already processed. Since this output is only for debugging, + % there is no point in creating a more exact description. + HeadStr = dump_class_id_subst_soln(PragmaTVarSet, PredTVarSet, + "head ", "\n", HeadClassId - HeadSubstSolnSet), + io.write_string(Stream, HeadStr, !IO) + ), + ( + TailClassIdsSubstSolns = [], + FinalSubstSet = HeadSubstSolnSet, + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + io.output_stream(Stream, !IO), + io.write_string(Stream, "DONE\n\n", !IO) + ) + ; + TailClassIdsSubstSolns = + [HeadTailClassIdSubstSoln | TailTailClassIdsSubstSolns], + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + HeadTailStr = + dump_class_id_subst_soln(PragmaTVarSet, PredTVarSet, + "head_tail ", "\n", HeadTailClassIdSubstSoln), + io.output_stream(Stream, !IO), + io.write_string(Stream, HeadTailStr, !IO) + ), + HeadTailClassIdSubstSoln = HeadTailClassId - HeadTailSubstSolnSet, + set.to_sorted_list(HeadSubstSolnSet, HeadSubstSolns), + set.to_sorted_list(HeadTailSubstSolnSet, HeadTailSubstSolns), + unify_two_soln_lists_outer_loop(HeadSubstSolns, + HeadTailSubstSolns, set.init, NextSubstSolnSet), + find_all_ground_subst_combinations(PragmaTVarSet, PredTVarSet, + HeadTailClassId - NextSubstSolnSet, + TailTailClassIdsSubstSolns, FinalSubstSet) + ). + +%---------------------% + +:- pred unify_two_soln_lists_outer_loop( + list(subst_soln)::in, list(subst_soln)::in, + set(subst_soln)::in, set(subst_soln)::out) is det. + +unify_two_soln_lists_outer_loop([], _SolnsB, !UnifiedSolns). +unify_two_soln_lists_outer_loop([SubstA | SolnsA], SolnsB, + !UnifiedSolns) :- + unify_two_soln_lists_inner_loop(SubstA, SolnsB, + !UnifiedSolns), + unify_two_soln_lists_outer_loop(SolnsA, SolnsB, + !UnifiedSolns). + +:- pred unify_two_soln_lists_inner_loop( + subst_soln::in, list(subst_soln)::in, + set(subst_soln)::in, set(subst_soln)::out) is det. + +unify_two_soln_lists_inner_loop(_SolnA, [], !UnifiedSolns). +unify_two_soln_lists_inner_loop(SolnA, [SolnB | SolnsB], + !UnifiedSolns) :- + ( if unify_two_solns(SolnA, SolnB, UnifiedSoln) then + set.insert(UnifiedSoln, !UnifiedSolns) + else + true + ), + unify_two_soln_lists_inner_loop(SolnA, SolnsB, !UnifiedSolns). + +:- pred unify_two_solns(subst_soln::in, subst_soln::in, + subst_soln::out) is semidet. + +unify_two_solns(SolnA, SolnB, UnifiedSoln) :- + SolnA = subst_soln(TVarSubstSetA, PragmaToPredSetA), + SolnB = subst_soln(TVarSubstSetB, PragmaToPredSetB), + set.to_sorted_list(TVarSubstSetA, TVarSubstsA), + set.to_sorted_list(TVarSubstSetB, TVarSubstsB), + unify_two_subst_lists_loop(TVarSubstsA, TVarSubstsB, UnifiedSubsts), + set.sorted_list_to_set(UnifiedSubsts, UnifiedSubstsSet), + + unify_pragma_to_pred_sets(PragmaToPredSetA, PragmaToPredSetB, + PragmaToPredSet), + UnifiedSoln = subst_soln(UnifiedSubstsSet, PragmaToPredSet). + +:- pred unify_two_subst_lists_loop(list(ground_or_tvar_subst)::in, + list(ground_or_tvar_subst)::in, list(ground_or_tvar_subst)::out) + is semidet. + +unify_two_subst_lists_loop(TVarSubstsA, TVarSubstsB, UnifiedSubst) :- + ( + TVarSubstsA = [], + TVarSubstsB = [], + UnifiedSubst = [] + ; + TVarSubstsA = [], + TVarSubstsB = [_ | _], + UnifiedSubst = TVarSubstsB + ; + TVarSubstsA = [_ | _], + TVarSubstsB = [], + UnifiedSubst = TVarSubstsA + ; + TVarSubstsA = [HeadTVarSubstA | TailTVarSubstsA], + TVarSubstsB = [HeadTVarSubstB | TailTVarSubstsB], + HeadTVarSubstA = ground_or_tvar_subst(TVarA, VoGTypeA), + HeadTVarSubstB = ground_or_tvar_subst(TVarB, VoGTypeB), + compare(Cmp, TVarA, TVarB), + ( + Cmp = (=), + VoGTypeA = VoGTypeB, + unify_two_subst_lists_loop(TailTVarSubstsA, TailTVarSubstsB, + TailUnifiedSubst), + % HeadTVarSubstA and HeadTVarSubstB are identical. + UnifiedSubst = [HeadTVarSubstA | TailUnifiedSubst] + ; + Cmp = (<), + % TVarA < TVarB + unify_two_subst_lists_loop(TailTVarSubstsA, TVarSubstsB, + TailUnifiedSubst), + UnifiedSubst = [HeadTVarSubstA | TailUnifiedSubst] + ; + Cmp = (>), + % TVarA > TVarB + unify_two_subst_lists_loop(TVarSubstsA, TailTVarSubstsB, + TailUnifiedSubst), + UnifiedSubst = [HeadTVarSubstB | TailUnifiedSubst] + ) + ). + + % unify_pragma_to_pred_sets(PragmaToPredSetA, PragmaToPredSetB, + % PragmaToPredSet): + % + % PragmaToPredSetA and PragmaToPredSetB each should describe a map + % from pragma tvars to pred tvars. Return the union of the two maps + % (in set form), provided that the two are compatible, in the sense that + % for any pragma tvars that occur in both, they both map it to the same + % pred tvar. + % +:- pred unify_pragma_to_pred_sets(set(pragma_to_pred_tvar)::in, + set(pragma_to_pred_tvar)::in, set(pragma_to_pred_tvar)::out) is semidet. + +unify_pragma_to_pred_sets(PragmaToPredSetA, PragmaToPredSetB, + PragmaToPredSet) :- + set.union(PragmaToPredSetA, PragmaToPredSetB, PragmaToPredSetAB), + set.to_sorted_list(PragmaToPredSetAB, PragmaToPredListAB), + ( + PragmaToPredListAB = [] + ; + PragmaToPredListAB = [HeadPragmaToPredAB | TailPragmaToPredAB], + no_pragma_tvar_is_double_mapped(HeadPragmaToPredAB, TailPragmaToPredAB) + ), + PragmaToPredSet = PragmaToPredSetAB. + +:- pred no_pragma_tvar_is_double_mapped(pragma_to_pred_tvar::in, + list(pragma_to_pred_tvar)::in) is semidet. + +no_pragma_tvar_is_double_mapped(Head, Tail) :- + ( + Tail = [] + ; + Tail = [HeadTail | TailTail], + Head = pragma_to_pred_tvar(HeadPragmaTVar, _), + HeadTail = pragma_to_pred_tvar(HeadTailPragmaTVar, _), + % If HeadPragmaTVar = HeadTailPragmaTVar, then this pragma tvar + % is mapped to two different pred tvars by the two input args + % of unify_pragma_to_pred_sets. + HeadPragmaTVar \= HeadTailPragmaTVar, + no_pragma_tvar_is_double_mapped(HeadTail, TailTail) + ). + +%---------------------------------------------------------------------------% + + % Given some solutions we have computed for a type_spec_constrained_preds + % pragma, generate an actual type_spec pragma for each. + % +:- pred generate_pragma_type_specs_for_pred_soln(module_name::in, tvarset::in, + pred_info::in, one_or_more(type_subst)::in, subst_soln::in, + list(decl_pragma_type_spec_info)::in, + list(decl_pragma_type_spec_info)::out) is det. + +generate_pragma_type_specs_for_pred_soln(PragmaModuleName, PragmaTVarSet, + PredInfo, OoMTypeSubsts, Soln, !Pragmas) :- + OoMTypeSubsts = one_or_more(HeadTypeSubst, TailTypeSubts), + generate_pragma_type_spec(PragmaModuleName, PragmaTVarSet, PredInfo, + Soln, HeadTypeSubst, !Pragmas), + list.foldl( + generate_pragma_type_spec(PragmaModuleName, PragmaTVarSet, PredInfo, + Soln), + TailTypeSubts, !Pragmas). + +:- pred generate_pragma_type_spec(module_name::in, tvarset::in, pred_info::in, + subst_soln::in, type_subst::in, + list(decl_pragma_type_spec_info)::in, + list(decl_pragma_type_spec_info)::out) is det. + +generate_pragma_type_spec(PragmaModuleName, PragmaTVarSet, PredInfo, + Soln, TypeSubst, !Pragmas) :- + UserArity = pred_info_user_arity(PredInfo), + MoA = moa_arity(UserArity), + pred_info_get_is_pred_or_func(PredInfo, PredOrFunc), + ( + PredOrFunc = pf_predicate, + PFUMM = pfumm_predicate(MoA) + ; + PredOrFunc = pf_function, + PFUMM = pfumm_function(MoA) + ), + pred_info_get_sym_name(PredInfo, PredSymName), + set.init(RecompItems), + + Soln = subst_soln(_Subst, PragmaToPredSet), + PragmaToPreds = set.to_sorted_list(PragmaToPredSet), + list.foldl(build_pragma_to_pred_tvar_map, PragmaToPreds, + map.init, PragmaToPredMap), + + TypeSubst = one_or_more(HeadTVarSubst, TailTVarSubsts), + TVarSubsts = [HeadTVarSubst | TailTVarSubsts], + find_type_vars_in_tvar_substs(PragmaToPredMap, TVarSubsts, EffTVarSubsts, + set.init, EffTypeSubstTVars), + one_or_more.det_list_to_one_or_more(EffTVarSubsts, EffTypeSubst), + pred_info_get_typevarset(PredInfo, PredTVarSet), + construct_pragma_tvarset_components(PredTVarSet, PragmaToPredMap, + set.to_sorted_list(EffTypeSubstTVars), + 1, NewPragmaNumTVars, map.init, NewPragmaTVarNames, + map.init, Renaming), + list.map(construct_pragma_tvar_subst(Renaming), + EffTVarSubsts, NewPragmaTVarSubsts), + one_or_more.det_list_to_one_or_more(NewPragmaTVarSubsts, + NewPragmaTypeSubst), + varset.construct_varset(NewPragmaNumTVars, NewPragmaTVarNames, + NewPragmaTVarSet), + + Pragma = decl_pragma_type_spec_info(PFUMM, PredSymName, PragmaModuleName, + NewPragmaTypeSubst, NewPragmaTVarSet, RecompItems, + dummy_context, item_no_seq_num), + !:Pragmas = [Pragma | !.Pragmas], + + trace [ + compile_time(flag("type_spec_constr_preds")), + run_time(env("TYPE_SPEC_CONSTR_PREDS")), + io(!IO)] + ( + PragmaTVarSetStr = dump_tvarset(PragmaTVarSet), + PredTVarSetStr = dump_tvarset(PredTVarSet), + SolnStr = dump_subst_soln(PragmaTVarSet, PredTVarSet, "\n", Soln), + EffTypeSubstStr = dump_type_subst(PragmaTVarSet, "\n", EffTypeSubst), + NewPragmaTypeSubstStr = dump_type_subst(PragmaTVarSet, "\n", + NewPragmaTypeSubst), + io.output_stream(Stream, !IO), + io.write_string(Stream, "\ngenerate_pragma_type_spec:\n", !IO), + io.write_string(Stream, "PragmaTVarSet:\n", !IO), + io.write_string(Stream, PragmaTVarSetStr, !IO), + io.write_string(Stream, "PredTVarSet:\n", !IO), + io.write_string(Stream, PredTVarSetStr, !IO), + io.write_string(Stream, "Soln:\n", !IO), + io.write_string(Stream, SolnStr, !IO), + io.write_string(Stream, "EffTypeSubst:\n", !IO), + io.write_string(Stream, EffTypeSubstStr, !IO), + io.write_string(Stream, "NewPragmaTypeSubst:\n", !IO), + io.write_string(Stream, NewPragmaTypeSubstStr, !IO), + io.write_string(Stream, "Pragma:\n", !IO), + report_generated_pragma(Stream, Pragma, !IO) + ). + +:- pred build_pragma_to_pred_tvar_map(pragma_to_pred_tvar::in, + map(tvar, tvar)::in, map(tvar, tvar)::out) is det. + +build_pragma_to_pred_tvar_map(PragmaToPred, !PragmaToPredMap) :- + PragmaToPred = pragma_to_pred_tvar(PragmaTVar, PredTVar), + map.det_insert(PragmaTVar, PredTVar, !PragmaToPredMap). + +:- pred find_type_vars_in_tvar_substs(map(tvar, tvar)::in, + list(tvar_subst)::in, list(tvar_subst)::out, + set(tvar)::in, set(tvar)::out) is det. + +find_type_vars_in_tvar_substs(_, [], [], !TVars). +find_type_vars_in_tvar_substs(PragmaToPredMap, + [HeadTVarSubst | TailTVarSubsts], EffTVarSubsts, !TVars) :- + HeadTVarSubst = tvar_subst(HeadTVar, HeadType), + ( if map.search(PragmaToPredMap, HeadTVar, _) then + set.insert(HeadTVar, !TVars), + set_of_type_vars_in_type(HeadType, HeadTypeTVars), + set.union(HeadTypeTVars, !TVars), + find_type_vars_in_tvar_substs(PragmaToPredMap, + TailTVarSubsts, TailEffTVarSubsts, !TVars), + EffTVarSubsts = [HeadTVarSubst | TailEffTVarSubsts] + else + find_type_vars_in_tvar_substs(PragmaToPredMap, + TailTVarSubsts, EffTVarSubsts, !TVars) + ). + +:- pred construct_pragma_tvarset_components(tvarset::in, map(tvar, tvar)::in, + list(tvar)::in, int::in, int::out, + map(tvar, string)::in, map(tvar, string)::out, + map(tvar, tvar)::in, map(tvar, tvar)::out) is det. + +construct_pragma_tvarset_components(_, _, [], + !PragmaNumTVars, !PragmaTVarNames, !Renaming). +construct_pragma_tvarset_components(PredTVarSet, RevTVarMap, + [VoGTVar | VoGTVars], !PragmaNumTVars, !PragmaTVarNames, !Renaming) :- + Var = force_construct_var(!.PragmaNumTVars), + map.det_insert(VoGTVar, Var, !Renaming), + ( if + map.search(RevTVarMap, VoGTVar, PredTVar), + varset.lookup_name(PredTVarSet, PredTVar, PredTVarName) + then + map.det_insert(Var, PredTVarName, !PragmaTVarNames) + else + true + ), + !:PragmaNumTVars = !.PragmaNumTVars + 1, + construct_pragma_tvarset_components(PredTVarSet, RevTVarMap, + VoGTVars, !PragmaNumTVars, !PragmaTVarNames, !Renaming). + +:- pred construct_pragma_tvar_subst(map(tvar, tvar)::in, + tvar_subst::in, tvar_subst::out) is det. + +construct_pragma_tvar_subst(Renaming, VoGTVarSubst, PragmaTVarSubst) :- + VoGTVarSubst = tvar_subst(VoGTVar, VoGType), + apply_variable_renaming_to_tvar(Renaming, VoGTVar, PragmaTVar), + apply_variable_renaming_to_type(Renaming, VoGType, PragmaType), + PragmaTVarSubst = tvar_subst(PragmaTVar, PragmaType). + +%---------------------------------------------------------------------------% +% +% Auxiliary routines for add_pragma_type_spec_constr. Most of them +% are intended to be used in trace goals to help debug the code. +% + +:- pred constraint_get_class_id_and_types(prog_constraint::in, class_id::out, + list(mer_type)::out) is det. + +constraint_get_class_id_and_types(Constraint, ClassId, Types) :- + Constraint = constraint(ClassSymName, Types), + list.length(Types, NumTypes), + ClassId = class_id(ClassSymName, NumTypes). + +%---------------------% + +:- pred report_generated_pragma(io.text_output_stream::in, + decl_pragma_type_spec_info::in, io::di, io::uo) is det. + +report_generated_pragma(Stream, Pragma, !IO) :- + io.write_string(Stream, "% ", !IO), + mercury_format_pragma_type_spec(Stream, output_mercury, Pragma, !IO). + +%---------------------% + +:- pred write_class_constraint_map_entry(io.text_output_stream::in, + tvarset::in, pair(class_id, arg_vector)::in, io::di, io::uo) is det. + +write_class_constraint_map_entry(Stream, TVarSet, ClassId - ArgVector, !IO) :- + EntryStr = class_constraint_map_entry_to_string(TVarSet, "table", + ClassId, ArgVector), + io.write_string(Stream, EntryStr, !IO). + +:- func class_constraint_map_entry_to_string(tvarset, string, + class_id, arg_vector) = string. + +class_constraint_map_entry_to_string(TVarSet, Prefix, ClassId, ArgVector) + = Str :- + ClassId = class_id(ClassSymName, _ClassArity), + ClassNameStr = mercury_sym_name_to_string(ClassSymName), + ArgVectorStr = arg_vector_to_string(TVarSet, ArgVector), + string.format("%s %s(%s)\n", + [s(Prefix), s(ClassNameStr), s(ArgVectorStr)], Str). + +:- func arg_vector_to_string(tvarset, arg_vector) = string. + +arg_vector_to_string(TVarSet, ArgVector) = Str :- + ArgVector = arg_vector(VarOrGroundTypes), + ( + VarOrGroundTypes = [], + Str = "" + ; + VarOrGroundTypes = [HeadVoGType | TailVoGTypes], + Str = var_or_ground_types_to_string(TVarSet, HeadVoGType, TailVoGTypes) + ). + +:- func var_or_ground_types_to_string(tvarset, var_or_ground_type, + list(var_or_ground_type)) = string. + +var_or_ground_types_to_string(TVarSet, HeadVoGType, TailVoGTypes) = Str :- + HeadStr = var_or_ground_type_to_string(TVarSet, HeadVoGType), + ( + TailVoGTypes = [], + Str = HeadStr + ; + TailVoGTypes = [HeadTailVoGType | TailTailVoGTypes], + Str = HeadStr ++ ", " ++ var_or_ground_types_to_string(TVarSet, + HeadTailVoGType, TailTailVoGTypes) + ). + +:- func var_or_ground_type_to_string(tvarset, var_or_ground_type) = string. + +var_or_ground_type_to_string(TVarSet, VoGType) = Str :- + ( + VoGType = type_var_name(TVar, TVarName), + Type = type_variable(TVar, kind_star), + TypeStr = mercury_type_to_string(TVarSet, print_name_and_num, Type), + string.format("tvar %s %s", [s(TVarName), s(TypeStr)], Str) + ; + VoGType = ground_type(GroundType), + Type = coerce(GroundType), + Str = mercury_type_to_string(varset.init, print_name_and_num, Type) + ). + +%---------------------% + +:- func dump_tvarset(tvarset) = string. + +dump_tvarset(TVarSet) = Str :- + NumAllocated = varset.num_allocated(TVarSet), + varset.var_name_list(TVarSet, VarNames), + VarNameStrs = list.map(dump_tvarset_entry, VarNames), + VarNamesStr = string.join_list(", ", VarNameStrs), + string.format("tvarset(%d, [%s])\n", + [i(NumAllocated), s(VarNamesStr)], Str). + +:- func dump_tvarset_entry(pair(tvar, string)) = string. + +dump_tvarset_entry(TVar - Name) = Str :- + string.format("%d -> %s", [i(var_to_int(TVar)), s(Name)], Str). + +:- func dump_class_id_subst_soln(tvarset, tvarset, string, string, + pair(class_id, set(subst_soln))) = string. + +dump_class_id_subst_soln(PragmaTVarSet, PredTVarSet, Prefix, Suffix, + ClassId - SubstSolnSet) = Str :- + ClassId = class_id(ClassSymName, ClassArity), + string.format("%sclass_id %s/%d\n", + [s(Prefix), s(sym_name_to_string(ClassSymName)), i(ClassArity)], + ClassStr), + SolnStrs = dump_subst_soln_list(PragmaTVarSet, PredTVarSet, Suffix, + 1, set.to_sorted_list(SubstSolnSet)), + Str = ClassStr ++ SolnStrs. + +:- func dump_subst_soln_list(tvarset, tvarset, string, int, list(subst_soln)) + = string. + +dump_subst_soln_list(_, _, _, _, []) = "". +dump_subst_soln_list(PragmaTVarSet, PredTVarSet, Suffix, CurSolnNum, + [HeadSoln | TailSolns]) = Str :- + HeadStr0 = dump_subst_soln(PragmaTVarSet, PredTVarSet, Suffix, HeadSoln), + string.format("%d: %s", [i(CurSolnNum), s(HeadStr0)], HeadStr), + TailStr = dump_subst_soln_list(PragmaTVarSet, PredTVarSet, Suffix, + CurSolnNum + 1, TailSolns), + Str = HeadStr ++ TailStr. + +:- func dump_subst_soln(tvarset, tvarset, string, subst_soln) = string. + +dump_subst_soln(PragmaTVarSet, PredTVarSet, Suffix, SubstSoln) = Str :- + SubstSoln = subst_soln(GroundOrTVarSubstSet, PragmaToPredTVarMap), + set.to_sorted_list(GroundOrTVarSubstSet, GroundOrTVarSubsts), + GroundOrTVarSubstStrs = list.map( + dump_ground_or_tvar_subst(PragmaTVarSet, PredTVarSet, " "), + GroundOrTVarSubsts), + GroundOrTVarSubstsStr = string.append_list(GroundOrTVarSubstStrs), + set.to_sorted_list(PragmaToPredTVarMap, PragmaToPredTVarMapAL), + RenameStrs = list.map(dump_tvar_rename(PragmaTVarSet, PredTVarSet, " "), + PragmaToPredTVarMapAL), + RenamesStr = string.append_list(RenameStrs), + string.format("subst_soln(\n%s\n%s)%s", + [s(GroundOrTVarSubstsStr), s(RenamesStr), s(Suffix)], Str). + +:- func dump_ground_or_tvar_subst(tvarset, tvarset, string, + ground_or_tvar_subst) = string. + +dump_ground_or_tvar_subst(PragmaTVarSet, PredTVarSet, Prefix, GroundTVarSubst) + = Str :- + GroundTVarSubst = ground_or_tvar_subst(PredTVar, VoG), + PredTVarStr = + mercury_var_to_string_vs(PredTVarSet, print_name_and_num, PredTVar), + ( + VoG = type_var_name(PragmaTVar, VoGStr0), + VoGKindStr = "tvar", + PragmaTVarStr = mercury_var_to_string_vs(PragmaTVarSet, + print_name_and_num, PragmaTVar), + string.format("%s %s", [s(VoGStr0), s(PragmaTVarStr)], VoGStr) + ; + VoG = ground_type(GroundType), + VoGKindStr = "grnd", + Type = coerce(GroundType), + % There should be no type variables in Type. + VoGStr = mercury_type_to_string(varset.init, print_num_only, Type) + ), + string.format("%sground_or_tvar_subst(pred %-10s -> pragma %s %s)\n", + [s(Prefix), s(PredTVarStr), s(VoGKindStr), s(VoGStr)], Str). + +:- func dump_type_subst(tvarset, string, type_subst) = string. + +dump_type_subst(TVarSet, Suffix, Subst) = Str :- + Subst = one_or_more(HeadTVarSubst, TailTVarSubsts), + TVarSubstStrs = list.map(dump_tvar_subst(TVarSet, " "), + [HeadTVarSubst | TailTVarSubsts]), + string.format("type_subst(\n%s)%s", + [s(string.append_list(TVarSubstStrs)), s(Suffix)], Str). + +:- func dump_tvar_subst(tvarset, string, tvar_subst) = string. + +dump_tvar_subst(TVarSet, Prefix, TVarSubst) = Str :- + TVarSubst = tvar_subst(TVar, Type), + TVarStr = mercury_var_to_string_vs(TVarSet, print_name_and_num, TVar), + TypeStr = mercury_type_to_string(TVarSet, print_name_and_num, Type), + string.format("%stvar_subst(%-10s -> %s)\n", + [s(Prefix), s(TVarStr), s(TypeStr)], Str). + +:- func dump_tvar_rename(tvarset, tvarset, string, pragma_to_pred_tvar) + = string. + +dump_tvar_rename(PragmaTVarSet, PredTVarSet, Prefix, PragmaToPredTVar) = Str :- + PragmaToPredTVar = pragma_to_pred_tvar(PragmaTVar, PredTVar), + Print = print_name_and_num, + PragmaTVarStr = mercury_var_to_string_vs(PragmaTVarSet, Print, PragmaTVar), + PredTVarStr = mercury_var_to_string_vs(PredTVarSet, Print, PredTVar), + string.format("%spragma_to_pred_tvar_rename(%-10s -> %s)\n", + [s(Prefix), s(PragmaTVarStr), s(PredTVarStr)], Str). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% add_pragma_type_spec(TypeSpec, !ModuleInfo, !QualInfo, !Specs) :- TypeSpec = decl_pragma_type_spec_info(PFUMM, SymName, _, _, _, _, @@ -129,7 +1322,7 @@ add_pragma_type_spec_for_pred(TypeSpec, PredId, globals.lookup_bool_option(Globals, smart_recompilation, Smart), % XXX Should check whether smart recompilation has been disabled? ( if - MaybeSpecProcs = ok5(SpecProcTable0, SpecProcIds, + MaybeSpecProcs = ok6(SpecProcTable0, ApplicableModes, SpecProcIds, UserArity, PredFormArity, PFUMM), % Even if we aren't doing type specialization, we need to create % the interface procedures for local predicates to check the @@ -147,7 +1340,7 @@ add_pragma_type_spec_for_pred(TypeSpec, PredId, then add_type_spec_version_of_pred(PredId, PredInfo0, PredFormArity, TypeSpec, TVarSet, Types, ExistQVars, ClassContext, - SpecProcTable0, SpecProcIds, + SpecProcTable0, ApplicableModes, SpecPredId, SpecPredStatus, !ModuleInfo), record_type_specialization(TypeSpec, PredId, SpecPredId, SpecPredStatus, SpecProcIds, RenamedSubst, TVarSet, PFUMM, @@ -156,28 +1349,28 @@ add_pragma_type_spec_for_pred(TypeSpec, PredId, maybe_record_type_spec_in_qual_info(PredOrFunc, SymName, UserArity, SpecPredStatus, TypeSpec, !QualInfo) else - !:Specs = get_any_errors5(MaybeSpecProcs) ++ !.Specs + !:Specs = get_any_errors6(MaybeSpecProcs) ++ !.Specs ) ; MaybeSubstResult = error5(SubstSpecs), !:Specs = SubstSpecs ++ !.Specs ). -:- func subst_desc(pair(tvar, mer_type)) = pair(int, mer_type). +:- func tvar_subst_desc(tvar_subst) = pair(int, mer_type). -subst_desc(TVar - Type) = var_to_int(TVar) - Type. +tvar_subst_desc(tvar_subst(TVar, Type)) = var_to_int(TVar) - Type. :- pred add_type_spec_version_of_pred(pred_id::in, pred_info::in, pred_form_arity::in, decl_pragma_type_spec_info::in, tvarset::in, list(mer_type)::in, existq_tvars::in, - univ_exist_constraints::in, proc_table::in, list(proc_id)::in, + univ_exist_constraints::in, proc_table::in, clause_applicable_modes::in, pred_id::out, pred_status::out, module_info::in, module_info::out) is det. add_type_spec_version_of_pred(PredId, PredInfo0, PredFormArity, TSInfo0, - TVarSet, Types, ExistQVars, ClassContext, SpecProcTable0, SpecProcIds, - SpecPredId, SpecPredStatus, !ModuleInfo) :- + TVarSet, Types, ExistQVars, Constraints, SpecProcTable0, + ApplicableModes, SpecPredId, SpecPredStatus, !ModuleInfo) :- TSInfo0 = decl_pragma_type_spec_info(PFUMM0, SymName, SpecModuleName, - Subst, TVarSet0, _ExpandedItems, Context, _SeqNum), + Subst, TVarSet0, _ExpandedItems, _PragmaContext, _SeqNum), % Remove any imported structure sharing and reuse information % for the original procedure as they won't be (directly) @@ -193,10 +1386,11 @@ add_type_spec_version_of_pred(PredId, PredInfo0, PredFormArity, TSInfo0, make_n_fresh_vars("HeadVar__", PredFormArityInt, ArgVars, ArgVarSet0, ArgVarSet), + pred_info_get_context(PredInfo0, PredContext), goal_info_init(GoalInfo0), set_of_var.list_to_set(ArgVars, NonLocals), goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo1), - goal_info_set_context(Context, GoalInfo1, GoalInfo), + goal_info_set_context(PredContext, GoalInfo1, GoalInfo), % We don't record the called predicate as used -- it is only used % if there is some other call. This call is only used to make @@ -206,8 +1400,7 @@ add_type_spec_version_of_pred(PredId, PredInfo0, PredFormArity, TSInfo0, PredOrFunc = pred_info_is_pred_or_func(PredInfo0), construct_pred_or_func_call(PredId, PredOrFunc, SymName, ArgVars, GoalInfo, Goal), - Clause = clause(selected_modes(SpecProcIds), Goal, - impl_lang_mercury, Context, []), + Clause = clause(ApplicableModes, Goal, impl_lang_mercury, PredContext, []), % XXX We could use explicit type qualifications here for the % argument types, but explicit type qualification doesn't work % correctly with type inference due to a bug somewhere in @@ -242,15 +1435,15 @@ add_type_spec_version_of_pred(PredId, PredInfo0, PredFormArity, TSInfo0, Transform = tn_pragma_type_spec(MaybePredOrFunc0, TVarSet0, Subst), make_transformed_pred_name(UnqualName, Transform, SpecName), pred_info_get_origin(PredInfo0, OrigOrigin), - SubstDesc = one_or_more.map(subst_desc, Subst), + SubstDesc = one_or_more.map(tvar_subst_desc, Subst), PredTransform = pred_transform_pragma_type_spec(SubstDesc), Origin = origin_pred_transform(PredTransform, OrigOrigin, PredId), MaybeCurUserDecl = maybe.no, GoalType = goal_not_for_promise(np_goal_type_none), pred_info_get_var_name_remap(PredInfo0, VarNameRemap), pred_info_init(PredOrFunc, SpecModuleName, SpecName, PredFormArity, - Context, Origin, SpecPredStatus, MaybeCurUserDecl, GoalType, - Markers, Types, TVarSet, ExistQVars, ClassContext, Proofs, + PredContext, Origin, SpecPredStatus, MaybeCurUserDecl, GoalType, + Markers, Types, TVarSet, ExistQVars, Constraints, Proofs, ConstraintMap, Clauses, VarNameRemap, SpecPredInfo0), pred_info_set_proc_table(SpecProcTable, SpecPredInfo0, SpecPredInfo), module_info_get_predicate_table(!.ModuleInfo, PredTable0), @@ -266,8 +1459,8 @@ record_type_specialization(TSInfo0, PredId, SpecPredId, SpecPredStatus, SpecProcIds, RenamedSubst, TVarSet, PFUMM, !ModuleInfo) :- % Record the type specialisation in the module_info. module_info_get_type_spec_info(!.ModuleInfo, TypeSpecInfo0), - TypeSpecInfo0 = type_spec_info(ProcsToSpec0, ForceVersions0, - SpecMap0, PragmaMap0), + TypeSpecInfo0 = type_spec_info(ProcsToSpec0, ForceVersions0, SpecMap0, + PragmaMap0), list.map( ( pred(ProcId::in, PredProcId::out) is det :- PredProcId = proc(PredId, ProcId) @@ -287,7 +1480,7 @@ record_type_specialization(TSInfo0, PredId, SpecPredId, SpecPredStatus, ^ tspec_pfumm := PFUMM) ^ tspec_tsubst := RenamedSubst) ^ tspec_tvarset := TVarSet), - multi_map.set(PredId, TSInfo, PragmaMap0, PragmaMap), + one_or_more_map.add(PredId, TSInfo, PragmaMap0, PragmaMap), TypeSpecInfo = type_spec_info(ProcsToSpec, ForceVersions, SpecMap, PragmaMap), module_info_set_type_spec_info(TypeSpecInfo, !ModuleInfo). @@ -330,7 +1523,9 @@ maybe_record_type_spec_in_qual_info(PredOrFunc, SymName, UserArity, PredStatus, handle_pragma_type_spec_subst(PredInfo0, TVarSet0, Subst, Context, MaybeSubstResult) :- SubstList = one_or_more_to_list(Subst), - assoc_list.keys(SubstList, VarsToSub), + GetTVarType = + ( pred(tvar_subst(TVar, Type)::in, TVar::out, Type::out) is det ), + list.map2(GetTVarType, SubstList, VarsToSub, SubstTypes0), find_duplicate_list_elements(VarsToSub, MultiSubstVars0), ( MultiSubstVars0 = [_ | _], @@ -352,7 +1547,6 @@ handle_pragma_type_spec_subst(PredInfo0, TVarSet0, Subst, Context, % Check that the substitution is not recursive. set.list_to_set(VarsToSub, VarsToSubSet), - assoc_list.values(SubstList, SubstTypes0), type_vars_in_types(SubstTypes0, TVarsInSubstTypes0), set.list_to_set(TVarsInSubstTypes0, TVarsInSubstTypes), @@ -389,9 +1583,12 @@ handle_pragma_type_spec_subst(PredInfo0, TVarSet0, Subst, Context, apply_rec_subst_to_type_list(TypeSubst, Types0, Types), apply_rec_subst_to_univ_exist_constraints(TypeSubst, ClassContext0, ClassContext), - det_list_to_one_or_more(SubAL, RenamedSubst), + PairToTVarSubst = + ( func(TVar - Type) = tvar_subst(TVar, Type) ), + RenamedSubsts = list.map(PairToTVarSubst, SubAL), + det_list_to_one_or_more(RenamedSubsts, OoMRenamedSubsts), MaybeSubstResult = ok5(TVarSet, Types, ExistQVars, - ClassContext, RenamedSubst) + ClassContext, OoMRenamedSubsts) ; SubExistQVars = [_ | _], report_subst_existq_tvars(PredInfo0, Context, @@ -412,6 +1609,8 @@ handle_pragma_type_spec_subst(PredInfo0, TVarSet0, Subst, Context, ) ). +%---------------------% + :- pred find_duplicate_list_elements(list(T)::in, list(T)::out) is det. find_duplicate_list_elements([], []). @@ -423,6 +1622,8 @@ find_duplicate_list_elements([H | T], DupVars) :- DupVars = DupVars0 ). +%---------------------------------------------------------------------------% + :- pred report_subst_existq_tvars(pred_info::in, prog_context::in, list(tvar)::in, error_spec::out) is det. @@ -495,14 +1696,16 @@ report_variables(SubExistQVars, VarSet) = [words(choose_number(SubExistQVars, "variable", "variables")), quote(mercury_vars_to_name_only_vs(VarSet, SubExistQVars))]. +%---------------------------------------------------------------------------% + % Check that the mode list for a `:- pragma type_spec' declaration % specifies a known procedure. % :- pred handle_pragma_type_spec_modes(module_info::in, pred_id::in, pred_info::in, proc_table::in, tvarset::in, prog_context::in, pred_func_or_unknown_maybe_modes::in, - maybe5(proc_table, list(proc_id), user_arity, pred_form_arity, - pred_func_or_unknown_maybe_modes)::out) + maybe6(proc_table, clause_applicable_modes, list(proc_id), user_arity, + pred_form_arity, pred_func_or_unknown_maybe_modes)::out) is det. handle_pragma_type_spec_modes(ModuleInfo, PredId, PredInfo, ProcTable, TVarSet, @@ -528,14 +1731,14 @@ handle_pragma_type_spec_modes(ModuleInfo, PredId, PredInfo, ProcTable, TVarSet, SpecProcTable = map.singleton(ProcId, ProcInfo), user_arity_pred_form_arity(PredOrFunc, UserArity, PredFormArity), - MaybeSpecProcs = ok5(SpecProcTable, [ProcId], - UserArity, PredFormArity, PFUMM) + MaybeSpecProcs = ok6(SpecProcTable, selected_modes([ProcId]), + [ProcId], UserArity, PredFormArity, PFUMM) else varset.coerce(TVarSet, VarSet), DescPieces = [pragma_decl("type_spec"), words("declaration")], report_undeclared_mode_error(ModuleInfo, PredId, PredInfo, VarSet, ArgModes, DescPieces, Context, [], Specs), - MaybeSpecProcs = error5(Specs) + MaybeSpecProcs = error6(Specs) ) ; ModesOrArity = moa_arity(UserArity), @@ -543,8 +1746,8 @@ handle_pragma_type_spec_modes(ModuleInfo, PredId, PredInfo, ProcTable, TVarSet, % is to be type specialized. map.keys(ProcTable, ProcIds), user_arity_pred_form_arity(PredOrFunc, UserArity, PredFormArity), - MaybeSpecProcs = ok5(ProcTable, ProcIds, UserArity, PredFormArity, - PFUMM) + MaybeSpecProcs = ok6(ProcTable, all_modes, ProcIds, + UserArity, PredFormArity, PFUMM) ) ; PFUMM0 = pfumm_unknown(UserArity), @@ -559,8 +1762,8 @@ handle_pragma_type_spec_modes(ModuleInfo, PredId, PredInfo, ProcTable, TVarSet, PFUMM = pfumm_function(moa_arity(UserArity)) ), user_arity_pred_form_arity(PredOrFunc, UserArity, PredFormArity), - MaybeSpecProcs = ok5(ProcTable, ProcIds, UserArity, PredFormArity, - PFUMM) + MaybeSpecProcs = ok6(ProcTable, all_modes, ProcIds, + UserArity, PredFormArity, PFUMM) ). :- pred reset_imported_structure_sharing_reuse( @@ -570,6 +1773,6 @@ reset_imported_structure_sharing_reuse(!ProcInfo) :- proc_info_reset_imported_structure_sharing(!ProcInfo), proc_info_reset_imported_structure_reuse(!ProcInfo). -%----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% :- end_module hlds.make_hlds.add_pragma.add_pragma_type_spec. -%----------------------------------------------------------------------------% +%---------------------------------------------------------------------------% diff --git a/compiler/check_import_accessibility.m b/compiler/check_import_accessibility.m index 3418cb6d3..60097f141 100644 --- a/compiler/check_import_accessibility.m +++ b/compiler/check_import_accessibility.m @@ -767,7 +767,7 @@ find_any_missing_ancestor_imports(CurrentModule, ParentOrAncestor, % Is ParentModule the same as CurrentModule, or a parent % or an ancestor of CurrentModule? If yes, then CurrentModule % imports it implicitly. - is_submodule(CurrentModule, ParentModule) + is_same_module_or_submodule(CurrentModule, ParentModule) ) then true diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m index 5466eb110..15e6c8e99 100644 --- a/compiler/check_typeclass.m +++ b/compiler/check_typeclass.m @@ -2347,7 +2347,7 @@ report_abstract_instance_without_concrete(ClassId, InstanceDefn, !Specs) :- ClassNameString = sym_name_to_string(ClassName), Types = InstanceDefn ^ instdefn_types, TVarSet = InstanceDefn ^ instdefn_tvarset, - TypesStr = mercury_type_list_to_string(TVarSet, Types), + TypesStr = mercury_types_to_string(TVarSet, print_name_only, Types), string.format("%s(%s)", [s(ClassNameString), s(TypesStr)], InstanceName), Pieces = [words("Error: this abstract instance declaration"), words("for"), quote(InstanceName), @@ -2724,7 +2724,7 @@ instance_name(WhichTypes, Limit, Quals, ClassId, InstanceDefn) Types0, Types) ), TVarSet = InstanceDefn ^ instdefn_tvarset, - TypesStr = mercury_type_list_to_string(TVarSet, Types), + TypesStr = mercury_types_to_string(TVarSet, print_name_only, Types), string.format("%s(%s)", [s(ClassNameStr), s(TypesStr)], InstanceName) ). diff --git a/compiler/convert_parse_tree.m b/compiler/convert_parse_tree.m index eb81e5ff0..40e518bf3 100644 --- a/compiler/convert_parse_tree.m +++ b/compiler/convert_parse_tree.m @@ -1161,6 +1161,7 @@ classify_plain_opt_items([Item | Items], !TypeDefns, !ForeignEnums, ( DeclPragma = decl_pragma_obsolete_pred(_) ; DeclPragma = decl_pragma_obsolete_proc(_) ; DeclPragma = decl_pragma_format_call(_) + ; DeclPragma = decl_pragma_type_spec_constr(_) ; DeclPragma = decl_pragma_oisu(_) ), Pieces = [words("A .opt file may not contain")] ++ @@ -1400,6 +1401,7 @@ classify_trans_opt_items([Item | Items], !TermInfos, !Term2Infos, ; DeclPragma = decl_pragma_obsolete_proc(_) ; DeclPragma = decl_pragma_format_call(_) ; DeclPragma = decl_pragma_type_spec(_) + ; DeclPragma = decl_pragma_type_spec_constr(_) ; DeclPragma = decl_pragma_oisu(_) ), Pieces = [words("A .trans_opt file may not contain")] ++ diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m index aade7e2b9..797809e6b 100644 --- a/compiler/equiv_type.m +++ b/compiler/equiv_type.m @@ -1513,6 +1513,12 @@ replace_in_abstract_instance_info(ModuleName, MaybeRecord, TypeEqvMap, _, replace_in_decl_pragma_info(ModuleName, MaybeRecord, TypeEqvMap, InstEqvMap, DeclPragma0, DeclPragma, !RecompInfo, !UsedModules, Specs) :- ( + DeclPragma0 = decl_pragma_type_spec_constr(TypeSpecConstr0), + replace_in_decl_pragma_type_spec_constr(ModuleName, MaybeRecord, + TypeEqvMap, InstEqvMap, TypeSpecConstr0, TypeSpecConstr, + !RecompInfo, !UsedModules, Specs), + DeclPragma = decl_pragma_type_spec_constr(TypeSpecConstr) + ; DeclPragma0 = decl_pragma_type_spec(TypeSpec0), replace_in_decl_pragma_type_spec(ModuleName, MaybeRecord, TypeEqvMap, InstEqvMap, TypeSpec0, TypeSpec, @@ -1532,6 +1538,55 @@ replace_in_decl_pragma_info(ModuleName, MaybeRecord, TypeEqvMap, InstEqvMap, Specs = [] ). +:- pred replace_in_decl_pragma_type_spec_constr(module_name::in, + maybe_record_sym_name_use::in, type_eqv_map::in, inst_eqv_map::in, + decl_pragma_type_spec_constr_info::in, + decl_pragma_type_spec_constr_info::out, + maybe(recompilation_info)::in, maybe(recompilation_info)::out, + used_modules::in, used_modules::out, list(error_spec)::out) is det. + +replace_in_decl_pragma_type_spec_constr(ModuleName, MaybeRecord, + TypeEqvMap, _InstEqvMap, TypeSpecInfoConstr0, TypeSpecInfoConstr, + !RecompInfo, !UsedModules, []) :- + TypeSpecInfoConstr0 = decl_pragma_type_spec_constr_info(PragmaModuleName, + OoMConstraints0, ApplyToSupers, OoMSubsts0, TVarSet0, ItemIds0, + Context, SeqNum), + % XXX I (zs) don't understand the purpose of the test in the code that + % sets ExpandedItems0 in replace_in_decl_pragma_type_spec below. + % The commit that added that code (the commit by Simon that added + % the initial implementation of smart recompilation) does not mention + % any rationale either. I cannot copy that test since there is no PredName + % here. So this setting of ExpandedItems0 here is just a guess. Whether + % it is a correct guess or not will matter only once smart recompilation + % is completed, in the fullness of time. + OoMConstraints0 = one_or_more(HeadConstraint0, TailConstraints0), + ExpandedItems0 = eqv_expand_info(ModuleName, ItemIds0), + replace_in_var_or_ground_constraint_location(MaybeRecord, TypeEqvMap, + HeadConstraint0, HeadConstraint, TVarSet0, TVarSet1, + ExpandedItems0, ExpandedItems1, !UsedModules), + list.map_foldl3( + replace_in_var_or_ground_constraint_location(MaybeRecord, TypeEqvMap), + TailConstraints0, TailConstraints, TVarSet1, TVarSet2, + ExpandedItems1, ExpandedItems2, !UsedModules), + OoMConstraints = one_or_more(HeadConstraint, TailConstraints), + OoMSubsts0 = one_or_more(HeadSubst0, TailSubsts0), + replace_in_subst(MaybeRecord, TypeEqvMap, + HeadSubst0, HeadSubst, TVarSet2, TVarSet3, + ExpandedItems2, ExpandedItems3, !UsedModules), + list.map_foldl3(replace_in_subst(MaybeRecord, TypeEqvMap), + TailSubsts0, TailSubsts, TVarSet3, TVarSet, + ExpandedItems3, ExpandedItems, !UsedModules), + OoMSubsts = one_or_more(HeadSubst, TailSubsts), + ( + ExpandedItems = no_eqv_expand_info, + ItemIds = ItemIds0 + ; + ExpandedItems = eqv_expand_info(_, ItemIds) + ), + TypeSpecInfoConstr = decl_pragma_type_spec_constr_info(PragmaModuleName, + OoMConstraints, ApplyToSupers, OoMSubsts, TVarSet, ItemIds, + Context, SeqNum). + :- pred replace_in_decl_pragma_type_spec(module_name::in, maybe_record_sym_name_use::in, type_eqv_map::in, inst_eqv_map::in, decl_pragma_type_spec_info::in, decl_pragma_type_spec_info::out, @@ -1552,11 +1607,8 @@ replace_in_decl_pragma_type_spec(ModuleName, MaybeRecord, else ExpandedItems0 = eqv_expand_info(ModuleName, ItemIds0) ), - Subst0 = one_or_more(HeadSubst0, TailSubsts0), - replace_in_subst(MaybeRecord, TypeEqvMap, - HeadSubst0, HeadSubst, TailSubsts0, TailSubsts, + replace_in_subst(MaybeRecord, TypeEqvMap, Subst0, Subst, TVarSet0, TVarSet, ExpandedItems0, ExpandedItems, !UsedModules), - Subst = one_or_more(HeadSubst, TailSubsts), ( ExpandedItems = no_eqv_expand_info, ItemIds = ItemIds0 @@ -2093,14 +2145,14 @@ replace_in_type_list_location_circ_2(_MaybeRecord, _TypeEqvMap, _Seen, [], [], unchanged, !ContainsCirc, !TVarSet, !EquivTypeInfo, !UsedModules). replace_in_type_list_location_circ_2(MaybeRecord, TypeEqvMap, Seen, - List0 @ [Type0 | Types0], List, Changed, !Circ, !TVarSet, + Types0 @ [HeadType0 | TailTypes0], Types, Changed, !Circ, !TVarSet, !EquivTypeInfo, !UsedModules) :- replace_in_type_maybe_record_use_2(MaybeRecord, TypeEqvMap, Seen, - Type0, Type, HeadChanged, HeadCirc, !TVarSet, + HeadType0, HeadType, HeadChanged, HeadCirc, !TVarSet, !EquivTypeInfo, !UsedModules), set.union(HeadCirc, !Circ), replace_in_type_list_location_circ_2(MaybeRecord, TypeEqvMap, Seen, - Types0, Types, TailChanged, !Circ, !TVarSet, + TailTypes0, TailTypes, TailChanged, !Circ, !TVarSet, !EquivTypeInfo, !UsedModules), ( if ( HeadChanged = changed @@ -2108,10 +2160,10 @@ replace_in_type_list_location_circ_2(MaybeRecord, TypeEqvMap, Seen, ) then Changed = changed, - List = [Type | Types] + Types = [HeadType | TailTypes] else Changed = unchanged, - List = List0 + Types = Types0 ). %---------------------------------------------------------------------------% @@ -2215,6 +2267,44 @@ replace_in_prog_constraint_location(MaybeRecord, TypeEqvMap, ArgTypes0, ArgTypes, _, _, !TVarSet, !EquivTypeInfo, !UsedModules), Constraint = constraint(ClassName, ArgTypes). +%---------------------% + +:- pred replace_in_var_or_ground_constraint_location( + maybe_record_sym_name_use::in, type_eqv_map::in, + var_or_ground_constraint::in, var_or_ground_constraint::out, + tvarset::in, tvarset::out, eqv_expand_info::in, eqv_expand_info::out, + used_modules::in, used_modules::out) is det. + +replace_in_var_or_ground_constraint_location(MaybeRecord, TypeEqvMap, + Constraint0, Constraint, !TVarSet, !EquivTypeInfo, !UsedModules) :- + Constraint0 = var_or_ground_constraint(ClassName, Args0, Context), + list.map_foldl3( + replace_in_var_or_ground_type_location(MaybeRecord, TypeEqvMap), + Args0, Args, !TVarSet, !EquivTypeInfo, !UsedModules), + Constraint = var_or_ground_constraint(ClassName, Args, Context). + +:- pred replace_in_var_or_ground_type_location(maybe_record_sym_name_use::in, + type_eqv_map::in, var_or_ground_type::in, var_or_ground_type::out, + tvarset::in, tvarset::out, eqv_expand_info::in, eqv_expand_info::out, + used_modules::in, used_modules::out) is det. + +replace_in_var_or_ground_type_location(MaybeRecord, TypeEqvMap, + Arg0, Arg, !TVarSet, !EquivTypeInfo, !UsedModules) :- + ( + Arg0 = type_var_name(_, _), + Arg = Arg0 + ; + Arg0 = ground_type(GroundType0), + Type0 = coerce(GroundType0), + replace_in_type_maybe_record_use(MaybeRecord, TypeEqvMap, + Type0, Type, _, !TVarSet, !EquivTypeInfo, !UsedModules), + ( if type_is_ground(Type, GroundType) then + Arg = ground_type(GroundType) + else + unexpected($pred, "expanded ground type is not ground") + ) + ). + %---------------------------------------------------------------------------% :- pred replace_in_class_interface(maybe_record_sym_name_use::in, @@ -2281,26 +2371,39 @@ replace_in_class_decl(MaybeRecord, TypeEqvMap, InstEqvMap, Decl0, Decl, %---------------------------------------------------------------------------% :- pred replace_in_subst(maybe_record_sym_name_use::in, type_eqv_map::in, - pair(tvar, mer_type)::in, pair(tvar, mer_type)::out, - assoc_list(tvar, mer_type)::in, assoc_list(tvar, mer_type)::out, + type_subst::in, type_subst::out, tvarset::in, tvarset::out, eqv_expand_info::in, eqv_expand_info::out, used_modules::in, used_modules::out) is det. -replace_in_subst(MaybeRecord, TypeEqvMap, - HeadVar - HeadType0, HeadVar - HeadType, +replace_in_subst(MaybeRecord, TypeEqvMap, Subst0, Subst, + !TVarSet, !ExpandedItems, !UsedModules) :- + Subst0 = one_or_more(HeadSubst0, TailSubsts0), + replace_in_tvar_substs(MaybeRecord, TypeEqvMap, + HeadSubst0, HeadSubst, TailSubsts0, TailSubsts, + !TVarSet, !ExpandedItems, !UsedModules), + Subst = one_or_more(HeadSubst, TailSubsts). + +:- pred replace_in_tvar_substs(maybe_record_sym_name_use::in, type_eqv_map::in, + tvar_subst::in, tvar_subst::out, + list(tvar_subst)::in, list(tvar_subst)::out, + tvarset::in, tvarset::out, eqv_expand_info::in, eqv_expand_info::out, + used_modules::in, used_modules::out) is det. + +replace_in_tvar_substs(MaybeRecord, TypeEqvMap, + tvar_subst(HeadVar, HeadType0), tvar_subst(HeadVar, HeadType), TailVarsTypes0, TailVarsTypes, - !TVarSet, !EquivTypeInfo, !UsedModules) :- + !TVarSet, !ExpandedItems, !UsedModules) :- replace_in_type_maybe_record_use(MaybeRecord, TypeEqvMap, - HeadType0, HeadType, _, !TVarSet, !EquivTypeInfo, !UsedModules), + HeadType0, HeadType, _, !TVarSet, !ExpandedItems, !UsedModules), ( TailVarsTypes0 = [], TailVarsTypes = [] ; TailVarsTypes0 = [HeadTailVarType0 | TailTailVarsTypes0], - replace_in_subst(MaybeRecord, TypeEqvMap, + replace_in_tvar_substs(MaybeRecord, TypeEqvMap, HeadTailVarType0, HeadTailVarType, TailTailVarsTypes0, TailTailVarsTypes, - !TVarSet, !EquivTypeInfo, !UsedModules), + !TVarSet, !ExpandedItems, !UsedModules), TailVarsTypes = [HeadTailVarType | TailTailVarsTypes] ). diff --git a/compiler/handle_options.m b/compiler/handle_options.m index 7b802bfd3..bc41849a9 100644 --- a/compiler/handle_options.m +++ b/compiler/handle_options.m @@ -2297,6 +2297,7 @@ handle_stack_layout_options(!Globals, OT_OptDups0, OT_OptDups, % transitive_optimization % warn_wrong_module_name % warn_unused_interface_imports + % inform_generated_type_spec_pragmas % :- pred handle_opmode_implications(op_mode::in, globals::in, globals::out) is det. @@ -2304,6 +2305,8 @@ handle_stack_layout_options(!Globals, OT_OptDups0, OT_OptDups, handle_opmode_implications(OpMode, !Globals) :- % Disable `--smart-recompilation' unless we are generating target code. globals.lookup_bool_option(!.Globals, smart_recompilation, Smart0), + globals.lookup_bool_option(!.Globals, inform_generated_type_spec_pragmas, + Inform0), ( OpMode = opm_top_args(OpModeArgs, _), % Disable --line-numbers when building the `.int', `.opt', etc. files, @@ -2334,7 +2337,8 @@ handle_opmode_implications(OpMode, !Globals) :- globals.set_option(generate_item_version_numbers, bool(no), !Globals) ), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ; OpModeArgs = opma_augment(OpModeAugment), ( @@ -2343,7 +2347,8 @@ handle_opmode_implications(OpMode, !Globals) :- globals.lookup_bool_option(!.Globals, halt_at_warn_make_opt, HaltAtWarn), globals.set_option(halt_at_warn, bool(HaltAtWarn), !Globals), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ; OpModeAugment = opmau_make_trans_opt, globals.set_option(transitive_optimization, bool(yes), @@ -2352,39 +2357,65 @@ handle_opmode_implications(OpMode, !Globals) :- globals.lookup_bool_option(!.Globals, halt_at_warn_make_opt, HaltAtWarn), globals.set_option(halt_at_warn, bool(HaltAtWarn), !Globals), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ; ( OpModeAugment = opmau_make_analysis_registry ; OpModeAugment = opmau_make_xml_documentation ; OpModeAugment = opmau_typecheck_only - ; OpModeAugment = opmau_errorcheck_only ), - Smart = bool.no + Smart = bool.no, + Inform = bool.no + ; + OpModeAugment = opmau_errorcheck_only, + Smart = bool.no, + % We execute all the tests in tests/warnings with + % --errorcheck-only. + Inform = Inform0 ; OpModeAugment = opmau_generate_code(_), - Smart = Smart0 + Smart = Smart0, + Inform = Inform0 ) ; ( OpModeArgs = opma_generate_dependencies(_) ; OpModeArgs = opma_generate_dependency_file ; OpModeArgs = opma_convert_to_mercury ), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ) ; OpMode = opm_top_generate_source_file_mapping, % Without an existing source file mapping, there is no "right" % module name. globals.set_option(warn_wrong_module_name, bool(no), !Globals), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ; ( OpMode = opm_top_generate_standalone_interface(_) ; OpMode = opm_top_query(_) ; OpMode = opm_top_make ), - Smart = bool.no + Smart = bool.no, + Inform = bool.no ), - globals.set_option(smart_recompilation, bool(Smart), !Globals). + % We do this here instead of replacing all the "Smart = bool.no"s above + % with a call to globals.set_option, because this way, we would get an + % error message from the compiler if we added a new op_mode and failed to + % explicitly consider what the value of Smart should be in its switch arm. + ( if Smart = Smart0 then + true + else + globals.set_option(smart_recompilation, bool(Smart), !Globals) + ), + % Thet consideration applies here as well. + ( if Inform = Inform0 then + true + else + globals.set_option(inform_generated_type_spec_pragmas, bool(Inform), + !Globals) + ). %---------------------% diff --git a/compiler/hlds_class.m b/compiler/hlds_class.m index 6209d1e33..5aed0d9fb 100644 --- a/compiler/hlds_class.m +++ b/compiler/hlds_class.m @@ -62,6 +62,12 @@ classdefn_vars :: list(tvar), % SuperClasses. + % + % Every type appearing in every superclass constraint must be + % either a type variable, or a ground type; types containing + % both type variables and type constructors are not allowed. + % This is enforced by parse_superclass_constraints in + % parse_class.m. classdefn_supers :: list(prog_constraint), % Functional dependencies. diff --git a/compiler/hlds_module.m b/compiler/hlds_module.m index 1e7f87834..d0c9dabc9 100644 --- a/compiler/hlds_module.m +++ b/compiler/hlds_module.m @@ -53,6 +53,7 @@ :- import_module maybe. :- import_module multi_map. :- import_module one_or_more. +:- import_module one_or_more_map. :- import_module pair. :- import_module set. :- import_module set_tree234. @@ -106,6 +107,9 @@ table_struct_attrs :: table_attributes ). +:- type type_spec_pragma_map == + one_or_more_map(pred_id, decl_pragma_type_spec_info). + % List of procedures for which there are user-requested type % specializations, and a list of predicates which should be processed % by higher_order.m to ensure the production of those versions. @@ -117,7 +121,7 @@ % Set of predicates which need to be processed by % higher_order.m to produce those specialized versions. - must_process_preds :: set(pred_id), + must_process_preds :: set(pred_id), % Map from predicates for which the user requested a type % specialization to the list of predicates which must be @@ -128,8 +132,7 @@ % Type spec pragmas to be placed in the `.opt' file if a % predicate becomes exported. - pragma_map :: multi_map(pred_id, - decl_pragma_type_spec_info) + pragma_map :: type_spec_pragma_map ). % Once filled in by simplify_proc.m (for all non-lambda procedures) diff --git a/compiler/hlds_out_typeclass_table.m b/compiler/hlds_out_typeclass_table.m index 5567669c5..68200ce3d 100644 --- a/compiler/hlds_out_typeclass_table.m +++ b/compiler/hlds_out_typeclass_table.m @@ -65,8 +65,8 @@ write_classes(Info, Stream, ClassTable, !IO) :- pair(class_id, hlds_class_defn)::in, io::di, io::uo) is det. write_class_defn(Info, Stream, ClassId - ClassDefn, !IO) :- - ClassDefn = hlds_class_defn(_, TVarSet, _, Vars, Constraints, FunDeps, - _, _, MethodInfos, Context, _), + ClassDefn = hlds_class_defn(_, TVarSet, _, Vars, SuperClassConstraints, + FunDeps, _, _, MethodInfos, Context, _), io.format(Stream, "\n%% %s:\n", [s(class_id_to_string(ClassId))], !IO), maybe_output_context_comment(Stream, 0u, "", Context, !IO), @@ -84,12 +84,12 @@ write_class_defn(Info, Stream, ClassId - ClassDefn, !IO) :- io.write_string(Stream, "% Functional dependencies:\n", !IO), list.foldl(hlds_output_fundep(Stream, IndentStr), FunDeps, !IO), - io.write_string(Stream, "% Constraints:\n", !IO), + io.write_string(Stream, "% Superclass constraints:\n", !IO), list.foldl( hlds_output_constraint(Stream, IndentStr, TVarSet, VarNamePrint), - Constraints, !IO), + SuperClassConstraints, !IO), - io.write_string(Stream, "% Class Methods:\n", !IO), + io.write_string(Stream, "% Class methods:\n", !IO), list.foldl(write_method_info(Stream, IndentStr), MethodInfos, !IO). :- pred hlds_output_fundep(io.text_output_stream::in, string::in, diff --git a/compiler/intermod.m b/compiler/intermod.m index 0d538e5ae..27a83a844 100644 --- a/compiler/intermod.m +++ b/compiler/intermod.m @@ -110,7 +110,6 @@ :- import_module list. :- import_module map. :- import_module maybe. -:- import_module multi_map. :- import_module one_or_more. :- import_module one_or_more_map. :- import_module pair. @@ -857,8 +856,8 @@ intermod_gather_pred_marker_pragmas_loop(PredOrFunc, PredSymName, UserArity, intermod_gather_pred_type_spec_pragmas(ModuleInfo, PredId, TypeSpecs) :- module_info_get_type_spec_info(ModuleInfo, TypeSpecInfo), PragmaMap = TypeSpecInfo ^ pragma_map, - ( if multi_map.search(PragmaMap, PredId, TypeSpecsPrime) then - TypeSpecs = TypeSpecsPrime + ( if one_or_more_map.search(PragmaMap, PredId, OoMTypeSpecs) then + TypeSpecs = one_or_more_to_list(OoMTypeSpecs) else TypeSpecs = [] ). diff --git a/compiler/item_util.m b/compiler/item_util.m index f83a95548..ee131cfb4 100644 --- a/compiler/item_util.m +++ b/compiler/item_util.m @@ -1572,6 +1572,10 @@ decl_pragma_desc_pieces(Pragma) = Pieces :- ; Pragma = decl_pragma_format_call(_), Pieces = [pragma_decl("format_call"), words("declaration")] + ; + Pragma = decl_pragma_type_spec_constr(_), + Pieces = [pragma_decl("type_spec_constrained_preds"), + words("declaration")] ; Pragma = decl_pragma_type_spec(_), Pieces = [pragma_decl("type_spec"), words("declaration")] diff --git a/compiler/make_hlds_passes.m b/compiler/make_hlds_passes.m index 3341e82a4..129e74b43 100644 --- a/compiler/make_hlds_passes.m +++ b/compiler/make_hlds_passes.m @@ -200,7 +200,7 @@ parse_tree_to_hlds(ProgressStream, AugCompUnit, Globals, DumpBaseFileName, InstDefns, ModeDefns, PredDecls, ModeDecls, Promises, Typeclasses, Instances, Initialises, Finalises, Mutables, TypeRepnMap, ForeignEnums, ForeignExportEnums, - DeclPragmas, DeclMarkers, DeclTypeSpec, + DeclPragmas, DeclMarkers, DeclTypeSpecConstr, DeclTypeSpec, DeclTermination, DeclTermination2, DeclSharing, DeclReuse, ImplPragmas, ImplMarkers, GenUnusedArgs, GenExceptions, GenTrailing, GenMMTabling, @@ -529,7 +529,9 @@ parse_tree_to_hlds(ProgressStream, AugCompUnit, Globals, DumpBaseFileName, % This times does have to be after we have processed all predicate % and mode declarations, since several pragmas do refer to predicates % or to modes of predicates. - add_decl_pragmas(DeclPragmas, + add_decl_pragmas(ProgressStream, DeclPragmas, + !ModuleInfo, !QualInfo, !Specs), + add_decl_pragmas_type_spec_constr(ProgressStream, DeclTypeSpecConstr, !ModuleInfo, !QualInfo, !Specs), add_decl_pragmas_type_spec(DeclTypeSpec, !ModuleInfo, !QualInfo, !Specs), diff --git a/compiler/make_hlds_separate_items.m b/compiler/make_hlds_separate_items.m index 2bfd5d0c0..3224cd586 100644 --- a/compiler/make_hlds_separate_items.m +++ b/compiler/make_hlds_separate_items.m @@ -81,6 +81,7 @@ list(item_foreign_export_enum_info)::out, ims_list(item_decl_pragma_info)::out, ims_list(item_decl_marker_info)::out, + list(decl_pragma_type_spec_constr_info)::out, list(decl_pragma_type_spec_info)::out, list(decl_pragma_termination_info)::out, list(decl_pragma_termination2_info)::out, @@ -137,6 +138,8 @@ ia_fees :: cord(item_foreign_export_enum_info), ia_decl_pragmas :: ims_cord(item_decl_pragma_info), ia_decl_marker :: ims_cord(item_decl_marker_info), + ia_decl_type_spec_constr + :: cord(decl_pragma_type_spec_constr_info), ia_decl_type_spec :: cord(decl_pragma_type_spec_info), ia_decl_term :: cord(decl_pragma_termination_info), ia_decl_term2 :: cord(decl_pragma_termination2_info), @@ -161,7 +164,8 @@ separate_items_in_aug_comp_unit(AugCompUnit, InclMap, Avails, FIMs, Promises, TypeClasses, Instances, Initialises, Finalises, Mutables, TypeRepnMap, ForeignEnums, ForeignExportEnums, - DeclPragmas, DeclMarkers, DeclPragmasTypeSpec, + DeclPragmas, DeclMarkers, + DeclPragmasTypeSpecConstr, DeclPragmasTypeSpec, DeclPragmasTermInfo, DeclPragmasTerm2Info, DeclPragmasSharing, DeclPragmasReuse, ImplPragmas, ImplMarkers, GenPragmasUnusedArgs, GenPragmasExceptions, @@ -184,7 +188,8 @@ separate_items_in_aug_comp_unit(AugCompUnit, InclMap, Avails, FIMs, cord.init, cord.init, cord.init, cord.init, cord.init, cord.init, - cord.init, cord.init, cord.init, + cord.init, cord.init, + cord.init, cord.init, cord.init, cord.init, cord.init, cord.init, cord.init, cord.init, @@ -230,7 +235,8 @@ separate_items_in_aug_comp_unit(AugCompUnit, InclMap, Avails, FIMs, PredDeclsCord, ModeDeclsCord, ClausesCord, ForeignProcsCord, ForeignEnumsCord, ForeignExportEnumsCord, - DeclPragmasCord, DeclMarkersCord, DeclPragmasTypeSpecCord, + DeclPragmasCord, DeclMarkersCord, + DeclPragmasTypeSpecConstrCord, DeclPragmasTypeSpecCord, DeclPragmasTermInfoCord, DeclPragmasTerm2InfoCord, DeclPragmasSharingCord, DeclPragmasReuseCord, ImplPragmasCord, ImplMarkersCord, @@ -258,6 +264,7 @@ separate_items_in_aug_comp_unit(AugCompUnit, InclMap, Avails, FIMs, ForeignExportEnums = cord.list(ForeignExportEnumsCord), DeclPragmas = cord.list(DeclPragmasCord), DeclMarkers = cord.list(DeclMarkersCord), + DeclPragmasTypeSpecConstr = cord.list(DeclPragmasTypeSpecConstrCord), DeclPragmasTypeSpec = cord.list(DeclPragmasTypeSpecCord), DeclPragmasTermInfo = cord.list(DeclPragmasTermInfoCord), DeclPragmasTerm2Info = cord.list(DeclPragmasTerm2InfoCord), @@ -426,7 +433,8 @@ acc_parse_tree_module_src(ParseTreeModuleSrc, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -521,7 +529,8 @@ acc_parse_tree_module_src(ParseTreeModuleSrc, !Acc) :- AccInstDefns, AccModeDefns, AccTypeClasses, AccInstances, AccPredDecls, AccModeDecls, AccClauses, AccForeignProcs, AccForeignEnums, AccForeignExportEnums, - AccDeclPragmas, AccDeclMarkers, AccDeclPragmasTypeSpec0, + AccDeclPragmas, AccDeclMarkers, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas, AccImplMarkers, @@ -569,7 +578,8 @@ acc_parse_tree_int0(ParseTreeInt0, ReadWhy0, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -649,7 +659,8 @@ acc_parse_tree_int0(ParseTreeInt0, ReadWhy0, !Acc) :- AccInstDefns, AccModeDefns, AccTypeClasses, AccInstances, AccPredDecls, AccModeDecls, AccClauses0, AccForeignProcs0, AccForeignEnums, AccForeignExportEnums0, - AccDeclPragmas, AccDeclMarkers, AccDeclPragmasTypeSpec0, + AccDeclPragmas, AccDeclMarkers, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -722,7 +733,8 @@ acc_parse_tree_int1(ParseTreeInt1, ReadWhy1, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -787,7 +799,8 @@ acc_parse_tree_int1(ParseTreeInt1, ReadWhy1, !Acc) :- AccInstDefns, AccModeDefns, AccTypeClasses, AccInstances, AccPredDecls, AccModeDecls, AccClauses0, AccForeignProcs0, AccForeignEnums, AccForeignExportEnums0, - AccDeclPragmas, AccDeclMarkers, AccDeclPragmasTypeSpec0, + AccDeclPragmas, AccDeclMarkers, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -838,7 +851,8 @@ acc_parse_tree_int2(ParseTreeInt2, ReadWhy2, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -891,7 +905,8 @@ acc_parse_tree_int2(ParseTreeInt2, ReadWhy2, !Acc) :- AccInstDefns, AccModeDefns, AccTypeClasses, AccInstances, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -921,7 +936,8 @@ acc_parse_tree_plain_opt(ParseTreePlainOpt, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -982,7 +998,8 @@ acc_parse_tree_plain_opt(ParseTreePlainOpt, !Acc) :- AccInstDefns, AccModeDefns, AccTypeClasses, AccInstances, AccPredDecls, AccModeDecls, AccClauses, AccForeignProcs, AccForeignEnums, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers, AccDeclPragmasTypeSpec, + AccDeclPragmas0, AccDeclMarkers, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec, AccDeclPragmasTermInfo, AccDeclPragmasTerm2Info, AccDeclPragmasSharing, AccDeclPragmasReuse, AccImplPragmas0, AccImplMarkers, @@ -1006,7 +1023,8 @@ acc_parse_tree_trans_opt(ParseTreeTransOpt, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -1035,7 +1053,8 @@ acc_parse_tree_trans_opt(ParseTreeTransOpt, !Acc) :- AccInstDefns0, AccModeDefns0, AccTypeClasses0, AccInstances0, AccPredDecls0, AccModeDecls0, AccClauses0, AccForeignProcs0, AccForeignEnums0, AccForeignExportEnums0, - AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpec0, + AccDeclPragmas0, AccDeclMarkers0, + AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, AccDeclPragmasTermInfo, AccDeclPragmasTerm2Info, AccDeclPragmasSharing, AccDeclPragmasReuse, AccImplPragmas0, AccImplMarkers0, diff --git a/compiler/maybe_error.m b/compiler/maybe_error.m index af7d132d8..c0902781c 100644 --- a/compiler/maybe_error.m +++ b/compiler/maybe_error.m @@ -41,6 +41,10 @@ ---> error5(E) ; ok5(T1, T2, T3, T4, T5). +:- type maybe6(T1, T2, T3, T4, T5, T6, E) + ---> error6(E) + ; ok6(T1, T2, T3, T4, T5, T6). + :- type maybe1(T1) == maybe1(T1, list(error_spec)). :- type maybe2(T1, T2) == @@ -51,6 +55,8 @@ maybe4(T1, T2, T3, T4, list(error_spec)). :- type maybe5(T1, T2, T3, T4, T5) == maybe5(T1, T2, T3, T4, T5, list(error_spec)). +:- type maybe6(T1, T2, T3, T4, T5, T6) == + maybe6(T1, T2, T3, T4, T5, T6, list(error_spec)). %---------------------% @@ -74,6 +80,10 @@ ---> error5(ground) ; ok5(I1, I2, I3, I4, I5). +:- inst maybe6(I1, I2, I3, I4, I5, I6) for maybe6/7 + ---> error6(ground) + ; ok6(I1, I2, I3, I4, I5, I6). + %---------------------% :- func get_any_errors1(maybe1(T1)) = list(error_spec). @@ -81,6 +91,7 @@ :- func get_any_errors3(maybe3(T1, T2, T3)) = list(error_spec). :- func get_any_errors4(maybe4(T1, T2, T3, T4)) = list(error_spec). :- func get_any_errors5(maybe5(T1, T2, T3, T4, T5)) = list(error_spec). +:- func get_any_errors6(maybe6(T1, T2, T3, T4, T5, T6)) = list(error_spec). :- func get_any_errors_warnings2(maybe2(T1, list(warning_spec))) = list(error_spec). @@ -90,6 +101,8 @@ list(error_spec). :- func get_any_errors_warnings5(maybe5(T1, T2, T3, T4, list(warning_spec))) = list(error_spec). +:- func get_any_errors_warnings6(maybe6(T1, T2, T3, T4, T5, + list(warning_spec))) = list(error_spec). :- pred project_ok1(maybe1(T1)::in, T1::out) is semidet. :- pred det_project_ok1(maybe1(T1)::in, T1::out) is det. @@ -121,6 +134,9 @@ get_any_errors4(error4(Specs)) = Specs. get_any_errors5(ok5(_, _, _, _, _)) = []. get_any_errors5(error5(Specs)) = Specs. +get_any_errors6(ok6(_, _, _, _, _, _)) = []. +get_any_errors6(error6(Specs)) = Specs. + %---------------------% get_any_errors_warnings2(ok2(_, Specs)) = Specs. @@ -135,6 +151,9 @@ get_any_errors_warnings4(error4(Specs)) = Specs. get_any_errors_warnings5(ok5(_, _, _, _, Specs)) = Specs. get_any_errors_warnings5(error5(Specs)) = Specs. +get_any_errors_warnings6(ok6(_, _, _, _, _, Specs)) = Specs. +get_any_errors_warnings6(error6(Specs)) = Specs. + %---------------------% project_ok1(Maybe1, Item) :- diff --git a/compiler/module_qual.qual_errors.m b/compiler/module_qual.qual_errors.m index 85190046f..10f9d8567 100644 --- a/compiler/module_qual.qual_errors.m +++ b/compiler/module_qual.qual_errors.m @@ -54,6 +54,13 @@ % The identity of the entity the constraint is on: % whether it is predicate or function, its name, and its arity. pf_sym_name_arity + ) + ; mqcec_type_spec_constr(prog_context, + % The constraint occurs in a type_spec_constraint pragma + % at the given location. The pragma has nothing that can serve + % as its "name" that is more useful than the id of the module + % to which it applies. + module_name ). :- type mq_error_context @@ -461,6 +468,10 @@ mq_constraint_error_context_to_pieces(ConstraintErrorContext, Start = "on", Pieces = [words("declaration of"), unqual_pf_sym_name_pred_form_arity(PFSymNameArity)] + ; + ConstraintErrorContext = mqcec_type_spec_constr(Context, _ModuleName), + Start = "in", + Pieces = [pragma_decl("type_spec_constrained_preds")] ). :- pred mq_error_context_to_pieces(mq_error_context::in, diff --git a/compiler/module_qual.qualify_items.m b/compiler/module_qual.qualify_items.m index 9f3a763f2..124b77d6c 100644 --- a/compiler/module_qual.qualify_items.m +++ b/compiler/module_qual.qualify_items.m @@ -70,6 +70,7 @@ :- import_module parse_tree.module_qual.qual_errors. :- import_module parse_tree.prog_data_foreign. :- import_module parse_tree.prog_data_pragma. +:- import_module parse_tree.prog_type_test. :- import_module int. :- import_module one_or_more. @@ -1415,6 +1416,8 @@ qualify_prog_constraints(InInt, ConstraintErrorContext, ExistCs0, ExistCs, !Info, !Specs), Constraints = univ_exist_constraints(UnivCs, ExistCs). +%---------------------% + :- pred qualify_prog_constraint_list(mq_in_interface::in, mq_constraint_error_context::in, list(prog_constraint)::in, list(prog_constraint)::out, @@ -1448,6 +1451,70 @@ qualify_prog_constraint(InInt, ContainingErrorContext, qualify_type_list(InInt, ErrorContext, Types0, Types, !Info, !Specs), Constraint = constraint(ClassName, Types). +%---------------------% + +:- pred qualify_var_or_ground_constraint_list(mq_in_interface::in, + mq_constraint_error_context::in, + list(var_or_ground_constraint)::in, list(var_or_ground_constraint)::out, + mq_info::in, mq_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + +qualify_var_or_ground_constraint_list(_InInt, _ConstraintErrorContext, + [], [], !Info, !Specs). +qualify_var_or_ground_constraint_list(InInt, ConstraintErrorContext, + [Constraint0 | Constraints0], [Constraint | Constraints], + !Info, !Specs) :- + qualify_var_or_ground_constraint(InInt, ConstraintErrorContext, + Constraint0, Constraint, !Info, !Specs), + qualify_var_or_ground_constraint_list(InInt, ConstraintErrorContext, + Constraints0, Constraints, !Info, !Specs). + +:- pred qualify_var_or_ground_constraint(mq_in_interface::in, + mq_constraint_error_context::in, + var_or_ground_constraint::in, var_or_ground_constraint::out, + mq_info::in, mq_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + +qualify_var_or_ground_constraint(InInt, ContainingErrorContext, + Constraint0, Constraint, !Info, !Specs) :- + Constraint0 = var_or_ground_constraint(ClassName0, Types0, Context), + list.length(Types0, Arity), + OutsideContext = mqec_typeclass_constraint_name(ContainingErrorContext), + qualify_class_name(InInt, OutsideContext, + mq_id(ClassName0, Arity), ClassName, !Info, !Specs), + ErrorContext = mqec_typeclass_constraint(ClassName0, Arity, + ContainingErrorContext), + qualify_var_or_ground_type_list(InInt, ErrorContext, Types0, Types, + !Info, !Specs), + Constraint = var_or_ground_constraint(ClassName, Types, Context). + +:- pred qualify_var_or_ground_type_list(mq_in_interface::in, + mq_error_context::in, + list(var_or_ground_type)::in, list(var_or_ground_type)::out, + mq_info::in, mq_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + +qualify_var_or_ground_type_list(_, _, [], [], !Info, !Specs). +qualify_var_or_ground_type_list(InInt, ErrorContext, + [Arg0 | Args0], [Arg | Args], !Info, !Specs) :- + ( + Arg0 = type_var_name(_, _), + Arg = Arg0 + ; + Arg0 = ground_type(GroundType0), + Type0 = coerce(GroundType0), + qualify_type(InInt, ErrorContext, Type0, Type, !Info, !Specs), + ( if type_is_ground(Type, GroundType) then + Arg = ground_type(GroundType) + else + unexpected($pred, "qualified ground type is not ground") + ) + ), + qualify_var_or_ground_type_list(InInt, ErrorContext, + Args0, Args, !Info, !Specs). + +%---------------------% + :- pred qualify_class_name(mq_in_interface::in, mq_error_context::in, mq_id::in, sym_name::out, mq_info::in, mq_info::out, list(error_spec)::in, list(error_spec)::out) is det. @@ -1613,6 +1680,29 @@ qualify_instance_method(DefaultModuleName, InstanceMethod0, InstanceMethod) :- module_qualify_item_decl_pragma(InInt, Pragma0, Pragma, !Info, !Specs) :- ( + Pragma0 = decl_pragma_type_spec_constr(TypeSpecConstrInfo0), + TypeSpecConstrInfo0 = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints0, ApplyToSupers, OoMSubsts0, TVarSet, Items, + Context, SeqNum), + ConstraintErrorContext = mqcec_type_spec_constr(Context, ModuleName), + OoMConstraints0 = one_or_more(HeadConstraint0, TailConstraints0), + qualify_var_or_ground_constraint(InInt, ConstraintErrorContext, + HeadConstraint0, HeadConstraint, !Info, !Specs), + qualify_var_or_ground_constraint_list(InInt, ConstraintErrorContext, + TailConstraints0, TailConstraints, !Info, !Specs), + OoMConstraints = one_or_more(HeadConstraint, TailConstraints), + ErrorContext = mqec_pragma_decl(Context, Pragma0), + OoMSubsts0 = one_or_more(HeadSubst0, TailSubsts0), + qualify_type_subst(InInt, ErrorContext, + HeadSubst0, HeadSubst, !Info, !Specs), + list.map_foldl2(qualify_type_subst(InInt, ErrorContext), + TailSubsts0, TailSubsts, !Info, !Specs), + OoMSubsts = one_or_more(HeadSubst, TailSubsts), + TypeSpecConstrInfo = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints, ApplyToSupers, OoMSubsts, TVarSet, Items, + Context, SeqNum), + Pragma = decl_pragma_type_spec_constr(TypeSpecConstrInfo) + ; Pragma0 = decl_pragma_type_spec(TypeSpecInfo0), TypeSpecInfo0 = decl_pragma_type_spec_info(PFUMM0, PredName, SpecPredName, Subst0, TVarSet, Items, Context, SeqNum), @@ -1645,10 +1735,7 @@ module_qualify_item_decl_pragma(InInt, Pragma0, Pragma, !Info, !Specs) :- PFUMM0 = pfumm_unknown(_Arity), PFUMM = PFUMM0 ), - Subst0 = one_or_more(HeadSubst0, TailSubsts0), - qualify_type_spec_subst(InInt, ErrorContext, - HeadSubst0, HeadSubst, TailSubsts0, TailSubsts, !Info, !Specs), - Subst = one_or_more(HeadSubst, TailSubsts), + qualify_type_subst(InInt, ErrorContext, Subst0, Subst, !Info, !Specs), TypeSpecInfo = decl_pragma_type_spec_info(PFUMM, PredName, SpecPredName, Subst, TVarSet, Items, Context, SeqNum), Pragma = decl_pragma_type_spec(TypeSpecInfo) @@ -1812,24 +1899,33 @@ qualify_pragma_var(InInt, ErrorContext, PragmaVar0, PragmaVar, qualify_mode(InInt, ErrorContext, Mode0, Mode, !Info, !Specs), PragmaVar = pragma_var(Var, Name, Mode, Box). -:- pred qualify_type_spec_subst(mq_in_interface::in, mq_error_context::in, - pair(tvar, mer_type)::in, pair(tvar, mer_type)::out, - assoc_list(tvar, mer_type)::in, assoc_list(tvar, mer_type)::out, - mq_info::in, mq_info::out, +:- pred qualify_type_subst(mq_in_interface::in, mq_error_context::in, + type_subst::in, type_subst::out, mq_info::in, mq_info::out, list(error_spec)::in, list(error_spec)::out) is det. -qualify_type_spec_subst(InInt, ErrorContext, +qualify_type_subst(InInt, ErrorContext, Subst0, Subst, !Info, !Specs) :- + Subst0 = one_or_more(HeadSubst0, TailSubsts0), + qualify_tvar_substs(InInt, ErrorContext, + HeadSubst0, HeadSubst, TailSubsts0, TailSubsts, !Info, !Specs), + Subst = one_or_more(HeadSubst, TailSubsts). + +:- pred qualify_tvar_substs(mq_in_interface::in, mq_error_context::in, + tvar_subst::in, tvar_subst::out, + list(tvar_subst)::in, list(tvar_subst)::out, mq_info::in, mq_info::out, + list(error_spec)::in, list(error_spec)::out) is det. + +qualify_tvar_substs(InInt, ErrorContext, HeadSubst0, HeadSubst, TailSubsts0, TailSubsts, !Info, !Specs) :- - HeadSubst0 = Var - Type0, + HeadSubst0 = tvar_subst(Var, Type0), % XXX We could pass a more specific error context. qualify_type(InInt, ErrorContext, Type0, Type, !Info, !Specs), - HeadSubst = Var - Type, + HeadSubst = tvar_subst(Var, Type), ( TailSubsts0 = [], TailSubsts = [] ; TailSubsts0 = [HeadTailSubst0 | TailTailSubsts0], - qualify_type_spec_subst(InInt, ErrorContext, + qualify_tvar_substs(InInt, ErrorContext, HeadTailSubst0, HeadTailSubst, TailTailSubsts0, TailTailSubsts, !Info, !Specs), TailSubsts = [HeadTailSubst | TailTailSubsts] diff --git a/compiler/options.m b/compiler/options.m index 9463fcbec..2e9e0da1e 100644 --- a/compiler/options.m +++ b/compiler/options.m @@ -241,6 +241,7 @@ ; inform_suboptimal_packing ; print_error_spec_id ; inform_ignored_pragma_errors + ; inform_generated_type_spec_pragmas % Verbosity options ; verbose @@ -1321,6 +1322,7 @@ optdef(oc_warn, inform_inferred_modes, bool(yes)). optdef(oc_warn, inform_suboptimal_packing, bool(no)). optdef(oc_warn, print_error_spec_id, bool(no)). optdef(oc_warn, inform_ignored_pragma_errors, bool(no)). +optdef(oc_warn, inform_generated_type_spec_pragmas, bool(no)). % Verbosity options. @@ -2244,6 +2246,8 @@ long_option("inform-inferred-modes", inform_inferred_modes). long_option("inform-suboptimal-packing", inform_suboptimal_packing). long_option("print-error-spec-id", print_error_spec_id). long_option("inform-ignored-pragma-errors", inform_ignored_pragma_errors). +long_option("inform-generated-type-spec-pragmas", + inform_generated_type_spec_pragmas). % verbosity options long_option("verbose", verbose). @@ -3245,6 +3249,8 @@ long_option("warn-obsolete-transform-2023-07-03", compiler_sufficiently_recent). long_option("gen-dep-ints-2023-10-15", compiler_sufficiently_recent). +long_option("tscp-2024-02-07", + compiler_sufficiently_recent). long_option("experiment", experiment). long_option("experiment1", experiment1). long_option("experiment2", experiment2). @@ -4448,6 +4454,10 @@ options_help_warning(Stream, !IO) :- % "\tPrint an informational message for each otherwise-ignored error", % "\tthat reports an inability to find the procedure that a pragma", % "\trefers to." +% "--inform-generated-type-spec-pragmas", +% "\tPrint an informational message for each type_spec pragma that" +% "\tthe compiler generates to implement a type_spec_constrained_pred" +% "\tpragma.", ], !IO). :- pred options_help_verbosity(io.text_output_stream::in, diff --git a/compiler/parse_class.m b/compiler/parse_class.m index ccffd83f0..d728dcb44 100644 --- a/compiler/parse_class.m +++ b/compiler/parse_class.m @@ -65,7 +65,10 @@ :- import_module parse_tree.parse_inst_mode_name. :- import_module parse_tree.parse_item. :- import_module parse_tree.parse_sym_name. +:- import_module parse_tree.parse_tree_out_info. +:- import_module parse_tree.parse_tree_out_inst. :- import_module parse_tree.parse_tree_out_term. +:- import_module parse_tree.parse_tree_out_type. :- import_module parse_tree.parse_type_name. :- import_module parse_tree.parse_util. :- import_module parse_tree.prog_item. @@ -290,46 +293,77 @@ parse_superclass_constraints(_ModuleName, VarSet, ConstraintsTerm, Result) :- ( Result0 = ok1(one_or_more(HeadArbConstraint, TailArbConstraints)), ArbitraryConstraints = [HeadArbConstraint | TailArbConstraints], - collect_simple_and_fundep_constraints(ArbitraryConstraints, - SimpleConstraints, FunDeps, BadConstraints), + collect_superclass_constraints(VarSet, ArbitraryConstraints, + SimpleConstraints, FunDeps, BadConstraintSpecs), ( - BadConstraints = [], + BadConstraintSpecs = [], Result = ok2(SimpleConstraints, FunDeps) ; - BadConstraints = [_ | _], - Pieces = [words("Error: constraints on class declarations"), - words("may only constrain type variables and ground types."), - nl], - Spec = simplest_spec($pred, severity_error, - phase_term_to_parse_tree, - get_term_context(ConstraintsTerm), Pieces), - Result = error2([Spec]) + BadConstraintSpecs = [_ | _], + Result = error2(BadConstraintSpecs) ) ; Result0 = error1(Specs), Result = error2(Specs) ). -:- pred collect_simple_and_fundep_constraints(list(arbitrary_constraint)::in, +:- pred collect_superclass_constraints(varset::in, + list(arbitrary_constraint)::in, list(prog_constraint)::out, list(prog_fundep)::out, - list(arbitrary_constraint)::out) is det. + list(error_spec)::out) is det. -collect_simple_and_fundep_constraints([], [], [], []). -collect_simple_and_fundep_constraints([Constraint | Constraints], - !:SimpleConstraints, !:FunDeps, !:BadConstraints) :- - collect_simple_and_fundep_constraints(Constraints, - !:SimpleConstraints, !:FunDeps, !:BadConstraints), +collect_superclass_constraints(_, [], [], [], []). +collect_superclass_constraints(VarSet, [Constraint | Constraints], + !:SimpleConstraints, !:FunDeps, !:Specs) :- + collect_superclass_constraints(VarSet, Constraints, + !:SimpleConstraints, !:FunDeps, !:Specs), ( - Constraint = simple(SimpleConstraint), - !:SimpleConstraints = [SimpleConstraint | !.SimpleConstraints] + Constraint = ac_type_constraint(TypeConstraint, + _VoGTypes, NonVarNonGroundTypes, Context), + ( + NonVarNonGroundTypes = [], + !:SimpleConstraints = [TypeConstraint | !.SimpleConstraints] + ; + NonVarNonGroundTypes = [_ | _], + varset.coerce(VarSet, TVarSet), + TypeConstraint = constraint(SuperClassName, _), + BadTypeStrs = list.map( + mercury_type_to_string(TVarSet, print_name_only), + NonVarNonGroundTypes), + BadTypesStr = list_to_quoted_pieces(BadTypeStrs), + ( + NonVarNonGroundTypes = [_], + BadTypePieces = [words("The type")] ++ BadTypesStr ++ + [words("is neither."), nl] + ; + NonVarNonGroundTypes = [_, _ | _], + BadTypePieces = [words("The types")] ++ BadTypesStr ++ + [words("are neither."), nl] + ), + Pieces = [words("Error: in a superclass constraint,"), + words("all the argument types of the superclass,"), + words("which in this case is"), + unqual_sym_name(SuperClassName), suffix(","), + words("must be either type variables or ground types.")] ++ + BadTypePieces, + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, Context, Pieces), + !:Specs = [Spec | !.Specs] + ) ; - Constraint = fundep(FunDep), + Constraint = ac_inst_constraint(InstVar, Inst, Context), + varset.coerce(VarSet, InstVarSet), + InstConstraintStr = mercury_constrained_inst_vars_to_string( + output_mercury, InstVarSet, set.make_singleton_set(InstVar), Inst), + Pieces = [words("Error: a class declaration"), + words("may not contain an inst constraint such as"), + quote(InstConstraintStr), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree, + Context, Pieces), + !:Specs = [Spec | !.Specs] + ; + Constraint = ac_fundep(FunDep, _), !:FunDeps = [FunDep | !.FunDeps] - ; - ( Constraint = non_simple(_) - ; Constraint = inst_constraint(_, _) - ), - !:BadConstraints = [Constraint | !.BadConstraints] ). :- pred parse_unconstrained_class(module_name::in, tvarset::in, term::in, @@ -511,10 +545,10 @@ parse_derived_instance(ModuleName, TVarSet, NameTerm, ConstraintsTerm, maybe1(list(prog_constraint))::out) is det. parse_instance_constraints(ModuleName, VarSet, ConstraintsTerm, Result) :- - Pieces = [words("Error: constraints on instance declarations"), + NonSimplePieces = [words("Error: constraints on instance declarations"), words("may only constrain type variables and ground types."), nl], - parse_simple_class_constraints(ModuleName, VarSet, ConstraintsTerm, Pieces, - Result). + parse_simple_class_constraints(ModuleName, VarSet, ConstraintsTerm, + NonSimplePieces, Result). :- pred parse_underived_instance(module_name::in, tvarset::in, term::in, prog_context::in, item_seq_num::in, maybe1(item_instance_info)::out) @@ -771,17 +805,17 @@ report_unexpected_method_term(VarSet, MethodTerm) = Spec :- % parse_class_constraints(ModuleName, VarSet, ConstraintsTerm, Result) :- - Pieces = [words("Sorry, not implemented:"), + NonSimplePieces = [words("Sorry, not implemented:"), words("constraints may only constrain type variables"), words("and ground types."), nl], - parse_simple_class_constraints(ModuleName, VarSet, ConstraintsTerm, Pieces, - Result). + parse_simple_class_constraints(ModuleName, VarSet, ConstraintsTerm, + NonSimplePieces, Result). :- pred parse_simple_class_constraints(module_name::in, varset::in, term::in, list(format_piece)::in, maybe1(list(prog_constraint))::out) is det. -parse_simple_class_constraints(_ModuleName, VarSet, ConstraintsTerm, Pieces, - Result) :- +parse_simple_class_constraints(_ModuleName, VarSet, ConstraintsTerm, + NonSimplePieces, Result) :- parse_arbitrary_constraints(VarSet, ConstraintsTerm, Result0), ( Result0 = ok1(one_or_more(HeadArbConstraint, TailArbConstraints)), @@ -795,9 +829,9 @@ parse_simple_class_constraints(_ModuleName, VarSet, ConstraintsTerm, Pieces, % to list allows an empty list. Result = ok1([HeadConstraint | TailConstraints]) else + Context = get_term_context(ConstraintsTerm), Spec = simplest_spec($pred, severity_error, - phase_term_to_parse_tree, - get_term_context(ConstraintsTerm), Pieces), + phase_term_to_parse_tree, Context, NonSimplePieces), Result = error1([Spec]) ) ; @@ -808,7 +842,7 @@ parse_simple_class_constraints(_ModuleName, VarSet, ConstraintsTerm, Pieces, :- pred get_simple_constraint(arbitrary_constraint::in, prog_constraint::out) is semidet. -get_simple_constraint(simple(Constraint), Constraint). +get_simple_constraint(ac_type_constraint(Constraint, _, [], _), Constraint). parse_class_and_inst_constraints(_ModuleName, VarSet, ConstraintsTerm, Result) :- @@ -845,34 +879,34 @@ collect_class_and_inst_constraints([Constraint | Constraints], collect_class_and_inst_constraints(Constraints, !:ProgConstraints, !:FunDeps, !:InstVarSub), ( - ( Constraint = simple(ProgConstraint) - ; Constraint = non_simple(ProgConstraint) - ), + Constraint = ac_type_constraint(ProgConstraint, _, _, _), !:ProgConstraints = [ProgConstraint | !.ProgConstraints] ; - Constraint = inst_constraint(InstVar, Inst), + Constraint = ac_inst_constraint(InstVar, Inst, _), map.set(InstVar, Inst, !InstVarSub) ; - Constraint = fundep(FunDep), + Constraint = ac_fundep(FunDep, _), !:FunDeps = [FunDep | !.FunDeps] ). :- type arbitrary_constraint - ---> simple(prog_constraint) - % A class constraint whose arguments are either variables - % or ground terms. + ---> ac_type_constraint(prog_constraint, list(var_or_ground_type), + list(mer_type), prog_context) + % A constraint consisting of a typeclass name applied to one + % or more types. The second argument lists the types that are + % either type variables or ground types; the third argument lists + % the types that are neither. (Superclass constraints, and the + % constraints in type_spec_constrained_preds pragmas, may have + % only type variables and ground types as arguments.) - ; non_simple(prog_constraint) - % An arbitrary class constraint not matching the description - % of "simple". + ; ac_inst_constraint(inst_var, mer_inst, prog_context) + % A constraint on an inst variable. Its principal functor is + % '=<'/2. - ; inst_constraint(inst_var, mer_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. + ; ac_fundep(prog_fundep, prog_context). + % A functional dependency. Its principal function symbol is '->'/2, + % and both its argument terms contain one or more variables + % separated by commas. :- type arbitrary_constraints == one_or_more(arbitrary_constraint). @@ -919,7 +953,8 @@ parse_arbitrary_constraint_list(VarSet, HeadTerm, TailTerms, Result) :- parse_arbitrary_constraint(VarSet, ConstraintTerm, Result) :- ( if - ConstraintTerm = term.functor(term.atom("=<"), [LHSTerm, RHSTerm], _) + ConstraintTerm = + term.functor(term.atom("=<"), [LHSTerm, RHSTerm], Context) then ( LHSTerm = term.variable(InstVar0, _), @@ -943,7 +978,7 @@ parse_arbitrary_constraint(VarSet, ConstraintTerm, Result) :- MaybeInstVar = ok1(InstVar), MaybeInst = ok1(Inst) then - Result = ok1(inst_constraint(InstVar, Inst)) + Result = ok1(ac_inst_constraint(InstVar, Inst, Context)) else Specs = get_any_errors1(MaybeInstVar) ++ get_any_errors1(MaybeInst), @@ -954,20 +989,21 @@ parse_arbitrary_constraint(VarSet, ConstraintTerm, Result) :- then Result = Result0 else if - try_parse_sym_name_and_args(ConstraintTerm, ClassName, Args0) + try_parse_sym_name_and_args(ConstraintTerm, ClassName, ArgTerms0) then ArgsResultContextPieces = cord.singleton(words("In class constraint:")), parse_types(no_allow_ho_inst_info(wnhii_class_constraint), - VarSet, ArgsResultContextPieces, Args0, ArgsResult), + VarSet, ArgsResultContextPieces, ArgTerms0, ArgsResult), ( - ArgsResult = ok1(Args), - Constraint = constraint(ClassName, Args), - ( if constraint_is_not_simple(Constraint) then - Result = ok1(non_simple(Constraint)) - else - Result = ok1(simple(Constraint)) - ) + ArgsResult = ok1(ArgTypes), + varset.coerce(VarSet, TVarSet), + Constraint = constraint(ClassName, ArgTypes), + classify_types_as_var_ground_or_neither(TVarSet, ArgTypes, + VoGTypes, NonVarNonGroundTypes), + Context = get_term_context(ConstraintTerm), + Result = ok1(ac_type_constraint(Constraint, VoGTypes, + NonVarNonGroundTypes, Context)) ; ArgsResult = error1(Specs), Result = error1(Specs) @@ -983,12 +1019,12 @@ parse_arbitrary_constraint(VarSet, ConstraintTerm, Result) :- :- pred parse_fundep(term::in, maybe1(arbitrary_constraint)::out) is semidet. parse_fundep(Term, Result) :- - Term = term.functor(term.atom("->"), [DomainTerm, RangeTerm], _), + Term = term.functor(term.atom("->"), [DomainTerm, RangeTerm], Context), ( if - parse_fundep_2(DomainTerm, Domain), - parse_fundep_2(RangeTerm, Range) + parse_fundep_side(DomainTerm, Domain), + parse_fundep_side(RangeTerm, Range) then - Result = ok1(fundep(fundep(Domain, Range))) + Result = ok1(ac_fundep(fundep(Domain, Range), Context)) else Pieces = [words("Error: the domain and range"), words("of a functional dependency"), @@ -1000,20 +1036,32 @@ parse_fundep(Term, Result) :- % XXX ITEM_LIST Should return one_or_more(tvar). % -:- pred parse_fundep_2(term::in, list(tvar)::out) is semidet. +:- pred parse_fundep_side(term::in, list(tvar)::out) is semidet. -parse_fundep_2(TypesTerm0, TypeVars) :- +parse_fundep_side(TypesTerm0, TypeVars) :- TypesTerm = term.coerce(TypesTerm0), conjunction_to_list(TypesTerm, TypeTerms), term_subst.term_list_to_var_list(TypeTerms, TypeVars). -:- pred constraint_is_not_simple(prog_constraint::in) is semidet. +:- pred classify_types_as_var_ground_or_neither(tvarset::in, + list(mer_type)::in, + list(var_or_ground_type)::out, list(mer_type)::out) is det. -constraint_is_not_simple(constraint(_ClassName, ArgTypes)) :- - some [ArgType] ( - list.member(ArgType, ArgTypes), - type_is_nonvar(ArgType), - type_is_nonground(ArgType) +classify_types_as_var_ground_or_neither(_, [], [], []). +classify_types_as_var_ground_or_neither(TVarSet, [Type0 | Types0], + !:VarOrGroundTypes, !:NonVarNonGroundTypes) :- + classify_types_as_var_ground_or_neither(TVarSet, Types0, + !:VarOrGroundTypes, !:NonVarNonGroundTypes), + Type1 = strip_kind_annotation(Type0), + Type = coerce(Type1), + ( if Type = type_variable(TVar, _Context) then + varset.lookup_name(TVarSet, TVar, TVarName), + !:VarOrGroundTypes = + [type_var_name(TVar, TVarName) | !.VarOrGroundTypes] + else if type_is_ground(Type, GroundType) then + !:VarOrGroundTypes = [ground_type(GroundType) | !.VarOrGroundTypes] + else + !:NonVarNonGroundTypes = [Type | !.NonVarNonGroundTypes] ). %---------------------------------------------------------------------------% diff --git a/compiler/parse_item.m b/compiler/parse_item.m index 23682cce5..fc5bc075d 100644 --- a/compiler/parse_item.m +++ b/compiler/parse_item.m @@ -1734,7 +1734,7 @@ get_purity_from_attrs(Context, [PurityAttr | PurityAttrs], MaybePurity) :- get_class_context_and_inst_constraints_from_attrs(ModuleName, VarSet, QuantConstrAttrs, ContextPieces, MaybeExistClassInstContext) :- % When we reach here, QuantConstrAttrs contains declaration attributes - % in the outermost to innermost order. + % in outermost to innermost order. % % Constraints and quantifiers should occur in the following order, % outermost to innermost: @@ -1748,14 +1748,14 @@ get_class_context_and_inst_constraints_from_attrs(ModuleName, VarSet, % 5. the decl itself pred or func 700 % % [*] Note that the semantic meaning of `=>' is not quite the same - % as implication; logically speaking it's more like conjunction. + % as implication; logically speaking, it is 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. + % In theory, it could make sense to allow the order of 2 & 3 to be + % swapped, or (in the case of multiple constraints and 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. % % NOTE We do NOT check that the order above is actually followed. % diff --git a/compiler/parse_pragma.m b/compiler/parse_pragma.m index 5058015e0..c6bd9bebc 100644 --- a/compiler/parse_pragma.m +++ b/compiler/parse_pragma.m @@ -54,13 +54,14 @@ :- import_module parse_tree.parse_util. :- import_module parse_tree.prog_data_pragma. :- import_module parse_tree.prog_item. +:- import_module parse_tree.prog_type_scan. +:- import_module parse_tree.prog_type_test. :- import_module cord. :- import_module counter. :- import_module int. :- import_module maybe. :- import_module one_or_more. -:- import_module pair. :- import_module set. :- import_module string. :- import_module term_int. @@ -74,7 +75,7 @@ parse_pragma(ModuleName, VarSet, PragmaTerms, Context, SeqNum, MaybeIOM) :- PragmaContext) then ( if - parse_pragma_type(ModuleName, VarSet, PragmaTerm, + parse_named_pragma(ModuleName, VarSet, PragmaTerm, PragmaName, PragmaArgTerms, PragmaContext, SeqNum, MaybeIOMPrime) then @@ -91,12 +92,14 @@ parse_pragma(ModuleName, VarSet, PragmaTerms, Context, SeqNum, MaybeIOM) :- MaybeIOM = error1([Spec]) ). -:- pred parse_pragma_type(module_name::in, varset::in, term::in, +:- pred parse_named_pragma(module_name::in, varset::in, term::in, string::in, list(term)::in, prog_context::in, item_seq_num::in, maybe1(item_or_marker)::out) is semidet. -parse_pragma_type(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms, +parse_named_pragma(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms, Context, SeqNum, MaybeIOM) :- + % XXX The Context argument is redundant, since we can always compute it + % as get_term_context(ErrorTerm). require_switch_arms_det [PragmaName] ( PragmaName = "source_file", @@ -228,6 +231,10 @@ parse_pragma_type(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms, PragmaName = "unused_args", parse_pragma_unused_args(ModuleName, VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM) + ; + PragmaName = "type_spec_constrained_preds", + parse_pragma_type_spec_constr(ModuleName, VarSet, ErrorTerm, + PragmaTerms, SeqNum, MaybeIOM) ; PragmaName = "type_spec", parse_pragma_type_spec(ModuleName, VarSet, ErrorTerm, @@ -1237,6 +1244,530 @@ parse_oisu_preds_term(ModuleName, VarSet, ArgNum, ExpectedFunctor, Term, MaybePredSpecs = error1([Spec]) ). +%---------------------------------------------------------------------------% +% +% Parse type_spec_constrained_preds pragmas. +% + +:- pred parse_pragma_type_spec_constr(module_name::in, varset::in, term::in, + list(term)::in, item_seq_num::in, + maybe1(item_or_marker)::out) is det. + +parse_pragma_type_spec_constr(ModuleName, VarSet0, ErrorTerm, PragmaTerms, + SeqNum, MaybeIOM) :- + ( if + PragmaTerms = [ConstraintsTerm, ApplyToSupersTerm, TypeSubstsTerm] + then + acc_var_names_in_term(VarSet0, ConstraintsTerm, + set.init, NamedVarNames1), + acc_var_names_in_term(VarSet0, TypeSubstsTerm, + NamedVarNames1, NamedVarNames), + parse_var_or_ground_constraint_list(NamedVarNames, ConstraintsTerm, + Constraints, ConstraintSpecs, + counter.init(1), Counter1, VarSet0, VarSet1), + parse_apply_to_supers(ApplyToSupersTerm, MaybeApplyToSupers), + parse_type_subst_list(NamedVarNames, TypeSubstsTerm, + TypeSubsts, TypeSubstsSpecs, Counter1, _Counter, VarSet1, VarSet), + varset.coerce(VarSet0, TVarSet0), + list.foldl(var_or_ground_constraint_acc_tvars, Constraints, + set.init, ConstraintTVars), + check_type_substs(TVarSet0, ConstraintTVars, TypeSubstsTerm, 1, + TypeSubsts, [], TypeSubstTVarSpecs), + ( if + ConstraintSpecs = [], + MaybeApplyToSupers = ok1(ApplyToSupers), + TypeSubstsSpecs = [], + TypeSubstTVarSpecs = [] + then + det_list_to_one_or_more(Constraints, OoMConstraints), + det_list_to_one_or_more(TypeSubsts, OoMTypeSubsts), + varset.coerce(VarSet, TVarSet), + TypeSpecConstr = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints, ApplyToSupers, OoMTypeSubsts, TVarSet, + set.init, get_term_context(ErrorTerm), SeqNum), + Pragma = decl_pragma_type_spec_constr(TypeSpecConstr), + Item = item_decl_pragma(Pragma), + MaybeIOM = ok1(iom_item(Item)) + else + Specs = ConstraintSpecs ++ get_any_errors1(MaybeApplyToSupers) ++ + TypeSubstsSpecs ++ TypeSubstTVarSpecs, + MaybeIOM = error1(Specs) + ) + else + Pieces = [words("Error: a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration must have three arguments."), nl], + Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree, + get_term_context(ErrorTerm), Pieces), + MaybeIOM = error1([Spec]) + ). + +%---------------------% + +:- pred parse_var_or_ground_constraint_list(set(string)::in, term::in, + list(var_or_ground_constraint)::out, list(error_spec)::out, + counter::in, counter::out, varset::in, varset::out) is det. + +parse_var_or_ground_constraint_list(NamedVarNames, Term, Constraints, Specs, + !Counter, !VarSet) :- + ( if list_term_to_term_list(Term, ConstraintTerms) then + ( + ConstraintTerms = [], + Constraints = [], + Pieces = [words("In the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("error: the list of type class constraints"), + words("must not be empty."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + Specs = [Spec] + ; + ConstraintTerms = [HeadConstraintTerm | TailConstraintTerms], + parse_var_or_ground_constraint_acc(NamedVarNames, + HeadConstraintTerm, cord.init, ConstraintCord1, + [], Specs1, !Counter, !VarSet), + list.foldl4(parse_var_or_ground_constraint_acc(NamedVarNames), + TailConstraintTerms, ConstraintCord1, ConstraintCord, + Specs1, Specs, !Counter, !VarSet), + Constraints = cord.list(ConstraintCord) + ) + else + Constraints = [], + Pieces = [words("In the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("error: expected a list of type class constraints, got"), + quote(describe_error_term(!.VarSet, Term)), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + Specs = [Spec] + ). + +:- pred parse_var_or_ground_constraint_acc(set(string)::in, term::in, + cord(var_or_ground_constraint)::in, cord(var_or_ground_constraint)::out, + list(error_spec)::in, list(error_spec)::out, + counter::in, counter::out, varset::in, varset::out) is det. + +parse_var_or_ground_constraint_acc(NamedVarNames, Term, + !ConstraintCord, !Specs, !Counter, !VarSet) :- + ( if try_parse_sym_name_and_args(Term, ClassSymName, ArgTerms) then + ( + ArgTerms = [], + Pieces = [words("In the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("error: expected a typeclass constraint consisting of"), + words("a class_name applied to one or more argument types,"), + words("got the class name"), + quote(sym_name_to_string(ClassSymName)), + words("without any argument types."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + !:Specs = [Spec | !.Specs] + ; + ArgTerms = [_ | _], + list.foldl2(name_unnamed_vars_in_term(NamedVarNames), + ArgTerms, !Counter, !VarSet), + ContextPieces = cord.from_list( + [words("In the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:")]), + AllowHOInstInfo = + no_allow_ho_inst_info(wnhii_pragma_type_spec_constr), + list.length(ArgTerms, NumArgTerms), + ClassId = class_id(ClassSymName, NumArgTerms), + parse_var_or_ground_types(AllowHOInstInfo, !.VarSet, ContextPieces, + ClassId, ArgTerms, MaybeArgs), + ( + MaybeArgs = ok1(Args), + Context = get_term_context(Term), + Constraint = + var_or_ground_constraint(ClassSymName, Args, Context), + cord.snoc(Constraint, !ConstraintCord) + ; + MaybeArgs = error1(ArgSpecs), + !:Specs = ArgSpecs ++ !.Specs + ) + ) + else + Pieces = [words("Error in the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("expected a typeclass constraint of the form"), + quote("class_name(argtype1, argtype2, ...)"), + words("got"), quote(describe_error_term(!.VarSet, Term)), + suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + !:Specs = [Spec | !.Specs] + ). + +:- pred parse_var_or_ground_types(allow_ho_inst_info::in, varset::in, + cord(format_piece)::in, class_id::in, list(term)::in, + maybe1(list(var_or_ground_type))::out) is det. + +parse_var_or_ground_types(_, _, _, _, [], ok1([])). +parse_var_or_ground_types(AllowHOInstInfo, VarSet, ContextPieces, ClassId, + [HeadTerm | TailTerms], Result) :- + parse_var_or_ground_types(AllowHOInstInfo, VarSet, ContextPieces, ClassId, + TailTerms, TailResult), + parse_type(AllowHOInstInfo, VarSet, ContextPieces, HeadTerm, HeadResult0), + ( + HeadResult0 = ok1(HeadType), + ( if HeadType = type_variable(HeadVar, _) then + varset.coerce(VarSet, TVarSet), + varset.lookup_name(TVarSet, HeadVar, HeadVarName), + HeadArg0 = type_var_name(HeadVar, HeadVarName), + HeadResult = ok1(HeadArg0) + else if type_is_ground(HeadType, HeadGroundType) then + HeadArg0 = ground_type(HeadGroundType), + HeadResult = ok1(HeadArg0) + else + Pieces = [words("Error in the first argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("in the constraint using type class"), + unqual_class_id(ClassId), suffix(","), + quote("expect ground types as arguments,"), + words("got"), quote(describe_error_term(VarSet, HeadTerm)), + suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(HeadTerm), Pieces), + HeadResult = error1([Spec]) + ) + ; + HeadResult0 = error1(HeadSpecs), + HeadResult = error1(HeadSpecs) + ), + ( if + HeadResult = ok1(HeadArg), + TailResult = ok1(TailArgs) + then + Result = ok1([HeadArg | TailArgs]) + else + Specs = get_any_errors1(HeadResult) ++ get_any_errors1(TailResult), + Result = error1(Specs) + ). + +:- pred parse_type_subst_list(set(string)::in, term::in, + list(type_subst)::out, list(error_spec)::out, + counter::in, counter::out, varset::in, varset::out) is det. + +parse_type_subst_list(NamedVarNames, Term, TypeSubsts, Specs, + !Counter, !VarSet) :- + ( if list_term_to_term_list(Term, TypeSubstTerms) then + ( + TypeSubstTerms = [], + TypeSubsts = [], + Pieces = [words("In the third argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("error: the list of type substitutions"), + words("must not be empty."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + Specs = [Spec] + ; + TypeSubstTerms = [HeadTypeSubstTerm | TailTypeSubstTerms], + PrefixPieces = [words("In the third argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), nl], + WNHII = wnhii_pragma_type_spec_constr, + parse_type_subst_acc(WNHII, PrefixPieces, NamedVarNames, + HeadTypeSubstTerm, cord.init, TypeSubstCord1, + [], Specs1, !Counter, !VarSet), + list.foldl4( + parse_type_subst_acc(WNHII, PrefixPieces, NamedVarNames), + TailTypeSubstTerms, TypeSubstCord1, TypeSubstCord, + Specs1, Specs, !Counter, !VarSet), + TypeSubsts = cord.list(TypeSubstCord) + ) + else + TypeSubsts = [], + Pieces = [words("In the third argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), + words("error: expected a list of type substitutions, got"), + quote(describe_error_term(!.VarSet, Term)), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + Specs = [Spec] + ). + +:- pred parse_type_subst_acc(why_no_ho_inst_info::in, list(format_piece)::in, + set(string)::in, term::in, cord(type_subst)::in, cord(type_subst)::out, + list(error_spec)::in, list(error_spec)::out, + counter::in, counter::out, varset::in, varset::out) is det. + +parse_type_subst_acc(WNHII, PrefixPieces, NamedVarNames, Term, + !TypeSubstCord, !Specs, !Counter, !VarSet) :- + parse_type_subst(WNHII, PrefixPieces, NamedVarNames, Term, MaybeTypeSubst, + !Counter, !VarSet), + ( + MaybeTypeSubst = ok1(TypeSubst), + cord.snoc(TypeSubst, !TypeSubstCord) + ; + MaybeTypeSubst = error1(TypeSubstSpecs), + !:Specs = TypeSubstSpecs ++ !.Specs + ). + +:- pred parse_type_subst(why_no_ho_inst_info::in, list(format_piece)::in, + set(string)::in, term::in, maybe1(type_subst)::out, + counter::in, counter::out, varset::in, varset::out) is det. + +parse_type_subst(WNHII, PrefixPieces, NamedVarNames, Term, MaybeTypeSubst, + !Counter, !VarSet) :- + ( if Term = term.functor(atom("subst"), ArgTerms, _) then + ( + ( ArgTerms = [] + ; ArgTerms = [_, _ | _] + ), + Pieces = PrefixPieces ++ + [words("error:"), quote("subst"), + words("must have exactly one argument,"), + words("which should have the form"), nl_indent_delta(1), + quote("[V1 = , ...]"), suffix("."), + nl_indent_delta(-1)], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + MaybeTypeSubst = error1([Spec]) + ; + ArgTerms = [ArgTerm], + ( if list_term_to_term_list(ArgTerm, TypeSubstTerms) then + ( + TypeSubstTerms = [], + Pieces = PrefixPieces ++ + [words("error: the list of type variable"), + words("substitutions must not be empty."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), + Pieces), + MaybeTypeSubst = error1([Spec]) + ; + TypeSubstTerms = [HeadTypeSubstTerm | TailTypeSubstTerms], + VarSet0 = !.VarSet, + name_unnamed_vars_in_term(NamedVarNames, + HeadTypeSubstTerm, !Counter, !VarSet), + list.foldl2(name_unnamed_vars_in_term(NamedVarNames), + TailTypeSubstTerms, !Counter, !VarSet), + parse_tvar_subst_acc(WNHII, PrefixPieces, VarSet0, + HeadTypeSubstTerm, cord.init, TVarSubstCord1, + [], TVarSpecs1), + list.foldl2( + parse_tvar_subst_acc(WNHII, PrefixPieces, VarSet0), + TailTypeSubstTerms, TVarSubstCord1, TVarSubstCord, + TVarSpecs1, TVarSpecs), + ( + TVarSpecs = [], + TVarSubsts = cord.list(TVarSubstCord), + det_list_to_one_or_more(TVarSubsts, TypeSubst), + MaybeTypeSubst = ok1(TypeSubst) + ; + TVarSpecs = [_ | _], + MaybeTypeSubst = error1(TVarSpecs) + ) + ) + else + ErrorTermStr = describe_error_term(!.VarSet, Term), + Pieces = PrefixPieces ++ + [words("error: expected a list of the form,"), + nl_indent_delta(1), + quote("[V1 = , ...]"), suffix(","), + nl_indent_delta(-1), + words("got"), quote(ErrorTermStr), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + MaybeTypeSubst = error1([Spec]) + ) + ) + else + ErrorTermStr = describe_error_term(!.VarSet, Term), + Pieces = PrefixPieces ++ + [words("error: expected a term of the form"), nl_indent_delta(1), + quote("subst([V1 = , ...])"), suffix(","), + nl_indent_delta(-1), + words("got"), quote(ErrorTermStr), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + MaybeTypeSubst = error1([Spec]) + ). + +%---------------------% + +:- pred parse_apply_to_supers(term::in, maybe1(maybe_apply_to_supers)::out) + is det. + +parse_apply_to_supers(Term, MaybeApplyToSupers) :- + ( if + Term = term.functor(Functor, Args, _), + Functor = term.atom(AtomStr), + ( + AtomStr = "do_not_apply_to_superclasses", + ApplyToSupers0 = do_not_apply_to_supers + ; + AtomStr = "apply_to_superclasses", + ApplyToSupers0 = apply_to_supers + ) + then + ( + Args = [], + MaybeApplyToSupers = ok1(ApplyToSupers0) + ; + Args = [_ | _], + Pieces = [words("Error in the second argument of"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), quote(AtomStr), + words("may not have any arguments."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + MaybeApplyToSupers = error1([Spec]) + ) + else + Pieces = [words("Error: the second argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration must be either"), + quote("do_not_apply_to_superclasses"), words("or"), + quote("apply_to_superclasses"), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(Term), Pieces), + MaybeApplyToSupers = error1([Spec]) + ). + +%---------------------% + +:- pred var_or_ground_constraint_acc_tvars(var_or_ground_constraint::in, + set(tvar)::in, set(tvar)::out) is det. + +var_or_ground_constraint_acc_tvars(Constraint, !TVars) :- + Constraint = var_or_ground_constraint(_ClassName, VoGTypes, _Context), + list.foldl(var_or_ground_type_acc_tvars, VoGTypes, !TVars). + +:- pred var_or_ground_type_acc_tvars(var_or_ground_type::in, + set(tvar)::in, set(tvar)::out) is det. + +var_or_ground_type_acc_tvars(VoGType, !TVars) :- + ( + VoGType = type_var_name(TVar, _TVarName), + set.insert(TVar, !TVars) + ; + VoGType = ground_type(_GroundType) + ). + +:- pred check_type_substs(tvarset::in, set(tvar)::in, term::in, int::in, + list(type_subst)::in, list(error_spec)::in, list(error_spec)::out) is det. + +check_type_substs(_, _, _, _, [], !TypeSubstTVarSpecs). +check_type_substs(TVarSet, ConstraintTVars, ErrorTerm, + SubstNum, [TypeSubst | TypeSubsts], !TypeSubstTVarSpecs) :- + check_type_subst(TVarSet, ConstraintTVars, ErrorTerm, + SubstNum, TypeSubst, !TypeSubstTVarSpecs), + check_type_substs(TVarSet, ConstraintTVars, ErrorTerm, + SubstNum + 1, TypeSubsts, !TypeSubstTVarSpecs). + +:- pred check_type_subst(tvarset::in, set(tvar)::in, term::in, int::in, + type_subst::in, list(error_spec)::in, list(error_spec)::out) is det. + +check_type_subst(TVarSet, ConstraintTVars, ErrorTerm, SubstNum, TypeSubst, + !Specs) :- + TypeSubst = one_or_more(HeadTVarSubst, TailTVarSubsts), + check_tvar_subst(TVarSet, ConstraintTVars, HeadTVarSubst, + set.init, BadLHSTVars1, set.init, BadRHSTVars1), + list.foldl2(check_tvar_subst(TVarSet, ConstraintTVars), TailTVarSubsts, + BadLHSTVars1, BadLHSTVars, BadRHSTVars1, BadRHSTVars), + BadLHSTVarList = set.to_sorted_list(BadLHSTVars), + BadRHSTVarList = set.to_sorted_list(BadRHSTVars), + % If a type_spec_constrained_preds pragma contains N substitutions + % in its third argument, then the process of checking those substitutions + % can generate up to 2N error_specs: one for each lhs or rhs in those + % N substitutions. We don't have a context for any part of the third + % argument, just the context of the third argument as a whole (our caller + % passes us the term containing that argument as ErrorTerm). We want to + % generate any error messages for the parts of that third argument + % in an order which matches the order of the complained-about entities + % in that argument, which we achieve through the use of the invis order + % format pieces below. + ( + BadLHSTVarList = [] + ; + BadLHSTVarList = [_HeadBadLHSTVar | TailBadLHSTVars], + ( + TailBadLHSTVars = [], + TheTypeVar = "the left-hand-side type variable", + ItDoesNot = "it does not." + ; + TailBadLHSTVars = [_ | _], + TheTypeVar = "the left-hand-side type variables", + ItDoesNot = "they do not." + ), + BadLHSTVarStrs = + list.map(mercury_var_to_string_vs(TVarSet, print_name_only), + BadLHSTVarList), + BadLHSTVarsPieces = list_to_pieces(BadLHSTVarStrs), + LHSPieces = [invis_order_default_start(SubstNum, "lhs"), + words("Error: in the third argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), nl, + words("in the"), nth_fixed(SubstNum), words("substitution:"), nl, + words(TheTypeVar)] ++ BadLHSTVarsPieces ++ [words("must occur"), + words("in the constraints listed in the first argument,"), + words("but"), words(ItDoesNot), nl], + LHSSpec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(ErrorTerm), LHSPieces), + !:Specs = [LHSSpec | !.Specs] + ), + ( + BadRHSTVarList = [] + ; + BadRHSTVarList = [_HeadBadRHSTVar | TailBadRHSTVars], + ( + TailBadRHSTVars = [], + IsNot = "is not." + ; + TailBadRHSTVars = [_ | _], + IsNot = "are not." + ), + BadRHSTVarStrs = + list.map(mercury_var_to_string_vs(TVarSet, print_name_only), + BadRHSTVarList), + BadRHSTVarsPieces = list_to_pieces(BadRHSTVarStrs), + RHSPieces = [invis_order_default_start(SubstNum, "rhs"), + words("Error: in the third argument of a"), + pragma_decl("type_spec_constrained_preds"), + words("declaration:"), nl, + words("in the"), nth_fixed(SubstNum), words("substitution:"), nl, + words("any type variables that occur on the right hand side"), + words("of a substitution must be anonymous, but")] ++ + BadRHSTVarsPieces ++ [words(IsNot), nl], + RHSSpec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(ErrorTerm), RHSPieces), + !:Specs = [RHSSpec | !.Specs] + ). + +:- pred check_tvar_subst(tvarset::in, set(tvar)::in, tvar_subst::in, + set(tvar)::in, set(tvar)::out, set(tvar)::in, set(tvar)::out) is det. + +check_tvar_subst(TVarSet, ConstraintTVars, TVarSubst, + !BadLHSTVars, !BadRHSTVars) :- + TVarSubst = tvar_subst(LHSTVar, RHSType), + ( if set.contains(ConstraintTVars, LHSTVar) then + true + else + set.insert(LHSTVar, !BadLHSTVars) + ), + set_of_type_vars_in_type(RHSType, RHSTVars), + set.foldl(check_tvar_subst_rhs_tvar(TVarSet), RHSTVars, !BadRHSTVars). + +:- pred check_tvar_subst_rhs_tvar(tvarset::in, tvar::in, + set(tvar)::in, set(tvar)::out) is det. + +check_tvar_subst_rhs_tvar(TVarSet, TVar, !BadRHSTVars) :- + ( if varset.search_name(TVarSet, TVar, _VarName) then + set.insert(TVar, !BadRHSTVars) + else + true + ). + %---------------------------------------------------------------------------% % % Parse type_spec pragmas. @@ -1248,13 +1779,9 @@ parse_oisu_preds_term(ModuleName, VarSet, ArgNum, ExpectedFunctor, Term, parse_pragma_type_spec(ModuleName, VarSet0, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM) :- - ( if - ( PragmaTerms = [PredAndModesTerm, TypeSubnTerm] - ; PragmaTerms = [PredAndModesTerm, TypeSubnTerm, _] - ) - then + ( if PragmaTerms = [PredAndModesTerm, TypeSubstTerm] then ArityOrModesContextPieces = cord.from_list( - [words("In the first argument"), pragma_decl("type_spec"), + [words("In the first argument of"), pragma_decl("type_spec"), words("declaration:"), nl]), parse_pred_pfu_name_arity_maybe_modes(ModuleName, ArityOrModesContextPieces, VarSet0, PredAndModesTerm, @@ -1263,43 +1790,62 @@ parse_pragma_type_spec(ModuleName, VarSet0, ErrorTerm, PragmaTerms, MaybePredOrProcSpec = ok1(PredOrProcSpec), PredOrProcSpec = pred_or_proc_pfumm_name(PFUMM, PredName), - % Give any anonymous variables in TypeSubnTerm names that - % do not conflict with the names of any named variables, - % nor, due to the use of sequence numbers, with each other. - acc_var_names_in_term(VarSet0, TypeSubnTerm, + WNHII = wnhii_pragma_type_spec, + TypeContextPieces = + [words("In the second argument of"), pragma_decl("type_spec"), + words("declaration:"), nl], + acc_var_names_in_term(VarSet0, TypeSubstTerm, set.init, NamedVarNames), - name_unnamed_vars_in_term(NamedVarNames, TypeSubnTerm, - counter.init(1), _, VarSet0, VarSet), - conjunction_to_one_or_more(TypeSubnTerm, TypeSubnTerms), - TypeSubnTerms = one_or_more(HeadSubnTerm, TailSubnTerms), - ( if - parse_type_spec_pair(HeadSubnTerm, HeadTypeSubn), - list.map(parse_type_spec_pair, TailSubnTerms, TailTypeSubns) - then - % The varset is actually a tvarset. - varset.coerce(VarSet, TVarSet), - TypeSubns = one_or_more(HeadTypeSubn, TailTypeSubns), - TypeSpec = decl_pragma_type_spec_info(PFUMM, PredName, - ModuleName, TypeSubns, TVarSet, set.init, Context, SeqNum), - Item = item_decl_pragma(decl_pragma_type_spec(TypeSpec)), - MaybeIOM = ok1(iom_item(Item)) + ( if TypeSubstTerm = term.functor(atom("subst"), _, _) then + parse_type_subst(WNHII, TypeContextPieces, NamedVarNames, + TypeSubstTerm, MaybeTypeSubst, + counter.init(1), _, VarSet0, VarSet), + ( + MaybeTypeSubst = ok1(OoMTVarSubsts), + % The varset is actually a tvarset. + varset.coerce(VarSet, TVarSet), + TypeSpec = decl_pragma_type_spec_info(PFUMM, PredName, + ModuleName, OoMTVarSubsts, TVarSet, + set.init, Context, SeqNum), + Item = item_decl_pragma(decl_pragma_type_spec(TypeSpec)), + MaybeIOM = ok1(iom_item(Item)) + ; + MaybeTypeSubst = error1(TypeSubstSpecs), + MaybeIOM = error1(TypeSubstSpecs) + ) else - TypeSubnTermStr = describe_error_term(VarSet0, TypeSubnTerm), - Pieces = [words("In the second argument of"), - pragma_decl("type_spec"), words("declaration:"), nl, - words("error: expected a type substitution, got"), - quote(TypeSubnTermStr), suffix("."), nl], - TypeSubnContext = get_term_context(TypeSubnTerm), - Spec = simplest_spec($pred, severity_error, - phase_term_to_parse_tree, TypeSubnContext, Pieces), - MaybeIOM = error1([Spec]) + % Give any anonymous variables in TypeSubstTerm names that + % do not conflict with the names of any named variables, + % nor, due to the use of sequence numbers, with each other. + % (In the then branch, this is done by parse_type_subst_acc.) + name_unnamed_vars_in_term(NamedVarNames, TypeSubstTerm, + counter.init(1), _, VarSet0, VarSet), + conjunction_to_one_or_more(TypeSubstTerm, TypeSubstTerms), + TypeSubstTerms = + one_or_more(HeadTypeSubstTerm, TailTypeSubstTerms), + parse_tvar_substs(WNHII, TypeContextPieces, VarSet0, + HeadTypeSubstTerm, TailTypeSubstTerms, + TVarSubsts, [], TypeSpecs), + ( + TypeSpecs = [], + % The varset is actually a tvarset. + varset.coerce(VarSet, TVarSet), + det_list_to_one_or_more(TVarSubsts, OoMTVarSubsts), + TypeSpec = decl_pragma_type_spec_info(PFUMM, PredName, + ModuleName, OoMTVarSubsts, TVarSet, + set.init, Context, SeqNum), + Item = item_decl_pragma(decl_pragma_type_spec(TypeSpec)), + MaybeIOM = ok1(iom_item(Item)) + ; + TypeSpecs = [_ | _], + MaybeIOM = error1(TypeSpecs) + ) ) ; MaybePredOrProcSpec = error1(Specs), MaybeIOM = error1(Specs) ) else - % XXX We allow three as a bootstrapping measure. Pieces = [words("Error: a"), pragma_decl("type_spec"), words("declaration must have two arguments."), nl], Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree, @@ -1307,16 +1853,100 @@ parse_pragma_type_spec(ModuleName, VarSet0, ErrorTerm, PragmaTerms, MaybeIOM = error1([Spec]) ). -:- pred parse_type_spec_pair(term::in, pair(tvar, mer_type)::out) is semidet. +%---------------------------------------------------------------------------% +% +% Utility predicates needed for both type_spec_constrained_preds +% and type_spec pragmas. +% -parse_type_spec_pair(Term, TypeSpec) :- - Term = term.functor(term.atom("="), [TypeVarTerm, SpecTypeTerm], _), - TypeVarTerm = term.variable(TypeVar0, _), - term.coerce_var(TypeVar0, TypeVar), - % XXX We should call parse_type instead. - maybe_parse_type(no_allow_ho_inst_info(wnhii_pragma_type_spec), - SpecTypeTerm, SpecType), - TypeSpec = TypeVar - SpecType. +:- pred parse_tvar_substs(why_no_ho_inst_info::in, list(format_piece)::in, + varset::in, term::in, list(term)::in, list(tvar_subst)::out, + list(error_spec)::in, list(error_spec)::out) is det. + +parse_tvar_substs(WNHII, ContextPieces, VarSet, HeadTerm, TailTerms, + TVarSubsts, !Specs) :- + TVarSubstCord0 = cord.init, + parse_tvar_subst_acc(WNHII, ContextPieces, VarSet, + HeadTerm, TVarSubstCord0, TVarSubstCord1, !Specs), + list.foldl2(parse_tvar_subst_acc(WNHII, ContextPieces, VarSet), + TailTerms, TVarSubstCord1, TVarSubstCord, !Specs), + TVarSubsts = cord.list(TVarSubstCord). + +:- pred parse_tvar_subst_acc(why_no_ho_inst_info::in, list(format_piece)::in, + varset::in, term::in, + cord(tvar_subst)::in, cord(tvar_subst)::out, + list(error_spec)::in, list(error_spec)::out) is det. + +parse_tvar_subst_acc(WNHII, ContextPieces, VarSet, Term, + !TVarSubstCord, !Specs) :- + ( if + Term = term.functor(term.atom(Atom), [TypeVarTerm, TypeTerm], _), + ( Atom = "=", AtomStr = "equals sign" + ; Atom = "=>", AtomStr = "arrow" + ) + then + ( if TypeVarTerm = term.variable(TypeVar0, _) then + RHSPieces = [words("on the right hand side of the"), + words(AtomStr), suffix(":"), nl], + TypeContextPieces = cord.from_list(ContextPieces) ++ + cord.from_list(RHSPieces), + parse_type(no_allow_ho_inst_info(WNHII), VarSet, TypeContextPieces, + TypeTerm, MaybeType), + ( + MaybeType = ok1(Type), + % XXX Having Type be a type variable would not make sense. + % The reference manual does not prohibit it, but it does not + % explicitly allow it either. + % + % The two usual shapes of Type are + % + % - an arity-zero type constructor, and + % - an arity-N type constructor for N > 0 being applied + % to N anonymous variables. + % + % A type containing more than one nested type constructor + % also makes sense. Types containing *named* variables can + % also make sense, but only if each such variable occurs + % exactly once not just in this tvar_subst, but in the list + % of one or more tvar_substs that a type_subst consists of. + % This is because repeated variables restrict the applicability + % of the type substitution in a way + % + % XXX We should consider adding code here to check for + % the cases that do not make sense, *after* documenting + % those restrictions in the reference manual. + term.coerce_var(TypeVar0, TypeVar), + TVarSubst = tvar_subst(TypeVar, Type), + cord.snoc(TVarSubst, !TVarSubstCord) + ; + MaybeType = error1(TypeSpecs), + !:Specs = TypeSpecs ++ !.Specs + ) + else + TypeVarTermStr = describe_error_term(VarSet, TypeVarTerm), + Pieces = ContextPieces ++ + [words("on the left hand side of the"), + words(AtomStr), suffix(":"), nl, + words("error: expected a variable, got"), + quote(TypeVarTermStr), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, + phase_term_to_parse_tree, get_term_context(TypeVarTerm), + Pieces), + !:Specs = [Spec | !.Specs] + ) + else + TermStr = describe_error_term(VarSet, Term), + Pieces = ContextPieces ++ + [words("error: expected a term of the form"), nl_indent_delta(1), + % XXX We should replace the = with => when we start recommending + % that syntax for both type_spec and type_spec_constrained_preds + % pragmas. + quote("V1 = "), suffix(","), nl_indent_delta(-11), + words("got"), quote(TermStr), suffix("."), nl], + Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree, + get_term_context(Term), Pieces), + !:Specs = [Spec | !.Specs] + ). %---------------------% diff --git a/compiler/parse_tree_out_inst.m b/compiler/parse_tree_out_inst.m index a523da332..d6d3f2ac7 100644 --- a/compiler/parse_tree_out_inst.m +++ b/compiler/parse_tree_out_inst.m @@ -51,6 +51,8 @@ %---------------------------------------------------------------------------% +:- func mercury_constrained_inst_vars_to_string(output_lang, inst_varset, + set(inst_var), mer_inst) = string. :- pred mercury_format_constrained_inst_vars(output_lang::in, inst_varset::in, set(inst_var)::in, mer_inst::in, S::in, U::di, U::uo) is det <= pt_output(S, U). @@ -343,6 +345,12 @@ mercury_format_inst_name(Lang, InstVarSet, InstName, S, !U) :- %---------------------------------------------------------------------------% +mercury_constrained_inst_vars_to_string(Lang, InstVarSet, Vars, Inst) = Str :- + State0 = string.builder.init, + mercury_format_constrained_inst_vars(Lang, InstVarSet, Vars, Inst, + string.builder.handle, State0, State), + Str = string.builder.to_string(State). + mercury_format_constrained_inst_vars(Lang, InstVarSet, !.Vars, Inst, S, !U) :- ( if set.remove_least(Var, !Vars) then add_string("(", S, !U), diff --git a/compiler/parse_tree_out_pragma.m b/compiler/parse_tree_out_pragma.m index c5445b962..e59ecd2cf 100644 --- a/compiler/parse_tree_out_pragma.m +++ b/compiler/parse_tree_out_pragma.m @@ -63,6 +63,10 @@ :- pred mercury_format_item_foreign_proc(S::in, output_lang::in, item_foreign_proc_info::in, U::di, U::uo) is det <= pt_output(S, U). +:- pred mercury_format_pragma_type_spec_constr(S::in, output_lang::in, + decl_pragma_type_spec_constr_info::in, U::di, U::uo) is det + <= pt_output(S, U). + :- pred mercury_format_pragma_type_spec(S::in, output_lang::in, decl_pragma_type_spec_info::in, U::di, U::uo) is det <= pt_output(S, U). @@ -166,6 +170,10 @@ mercury_format_item_decl_pragma(Info, Stream, DeclPragma, !IO) :- ; DeclPragma = decl_pragma_format_call(FormatCall), mercury_format_pragma_format_call(FormatCall, Stream, !IO) + ; + DeclPragma = decl_pragma_type_spec_constr(TypeSpecConstr), + mercury_format_pragma_type_spec_constr(Stream, Lang, + TypeSpecConstr, !IO) ; DeclPragma = decl_pragma_type_spec(TypeSpec), mercury_format_pragma_type_spec(Stream, Lang, TypeSpec, !IO) @@ -919,9 +927,29 @@ backend_to_string(Backend) = Str :- % Output a type_spec pragma. % +mercury_format_pragma_type_spec_constr(S, _Lang, TypeSpecConstr, !U) :- + TypeSpecConstr = decl_pragma_type_spec_constr_info(_ModuleName, + OoMConstraints, ApplyToSupers, OoMTypeSubsts, TVarSet, _, _, _), + IndentStr = " ", + add_string(":- pragma type_spec_constrained_preds([", S, !U), + add_list(mercury_format_type_spec_constraint(IndentStr, TVarSet), ",\n", + one_or_more_to_list(OoMConstraints), S, !U), + add_string("\n], ", S, !U), + ( + ApplyToSupers = do_not_apply_to_supers, + add_string("do_not_apply_to_superclasses, ", S, !U) + ; + ApplyToSupers = apply_to_supers, + add_string("apply_to_superclasses, ", S, !U) + ), + add_string("[\n", S, !U), + add_list(mercury_format_type_subst_new(IndentStr, TVarSet), ",\n", + one_or_more_to_list(OoMTypeSubsts), S, !U), + add_string("\n]).\n", S, !U). + mercury_format_pragma_type_spec(S, Lang, TypeSpec, !U) :- TypeSpec = decl_pragma_type_spec_info(PFUMM, PredName, _SpecModuleName, - TypeSubst, VarSet, _, _, _), + TypeSubst, TVarSet, _, _, _), add_string(":- pragma type_spec(", S, !U), ( ( @@ -946,35 +974,78 @@ mercury_format_pragma_type_spec(S, Lang, TypeSpec, !U) :- mercury_format_pred_name_arity(PredName, PredArity, S, !U) ), add_string(", ", S, !U), - % The code that parses type_spec pragmas ensures that all types variables - % in the substitution are named. Therefore there is no reason to print - % variable numbers. In fact, printing variable numbers would be a bug, - % since any code reading the pragma we are now writing out would mistake - % the variable number as part of the variable *name*. See the long comment - % on the tspec_tvarset field of the pragma in prog_item.m. + mercury_format_type_subst_old(TVarSet, TypeSubst, S, !U), + add_string(").\n", S, !U). + +:- pred mercury_format_type_spec_constraint(string::in, tvarset::in, + var_or_ground_constraint::in, S::in, U::di, U::uo) is det + <= pt_output(S, U). + +mercury_format_type_spec_constraint(Prefix, TVarSet, Constraint, S, !U) :- + add_string(Prefix, S, !U), + Constraint = var_or_ground_constraint(Name, Args, _Context), + mercury_format_sym_name(Name, S, !U), + add_string("(", S, !U), + add_list(mercury_format_var_or_ground_type(TVarSet), ", ", + Args, S, !U), + add_string(")", S, !U). + +:- pred mercury_format_var_or_ground_type(tvarset::in, var_or_ground_type::in, + S::in, U::di, U::uo) is det <= pt_output(S, U). + +mercury_format_var_or_ground_type(TVarSet, Arg, S, !U) :- + ( + Arg = type_var_name(_, VarName), + add_string(VarName, S, !U) + ; + Arg = ground_type(GroundType), + Type = coerce(GroundType), + mercury_format_type(TVarSet, print_name_only, Type, S, !U) + ). + +:- pred mercury_format_type_subst_new(string::in, tvarset::in, type_subst::in, + S::in, U::di, U::uo) is det <= pt_output(S, U). + +mercury_format_type_subst_new(Prefix, TVarSet, TypeSubst, S, !U) :- + TypeSubst = one_or_more(HeadTypeSubst, TailTypeSubsts), + add_string(Prefix, S, !U), + add_string("subst([", S, !U), + add_list(mercury_format_tvar_subst(TVarSet), ", ", + [HeadTypeSubst | TailTypeSubsts], S, !U), + add_string("])", S, !U). + +:- pred mercury_format_type_subst_old(tvarset::in, type_subst::in, + S::in, U::di, U::uo) is det <= pt_output(S, U). + +mercury_format_type_subst_old(TVarSet, TypeSubst, S, !U) :- TypeSubst = one_or_more(HeadTypeSubst, TailTypeSubsts), ( TailTypeSubsts = [], % In the common case of there being only type substitution, % do not put unnecessary parentheses around it. - mercury_format_type_subst(VarSet, print_name_only, HeadTypeSubst, - S, !U) + mercury_format_tvar_subst(TVarSet, HeadTypeSubst, S, !U) ; TailTypeSubsts = [_ | _], add_string("(", S, !U), - add_list(mercury_format_type_subst(VarSet, print_name_only), ", ", + add_list(mercury_format_tvar_subst(TVarSet), ", ", [HeadTypeSubst | TailTypeSubsts], S, !U), add_string(")", S, !U) - ), - add_string(").\n", S, !U). + ). -:- pred mercury_format_type_subst(tvarset::in, var_name_print::in, - pair(tvar, mer_type)::in, S::in, U::di, U::uo) is det <= pt_output(S, U). +:- pred mercury_format_tvar_subst(tvarset::in, tvar_subst::in, + S::in, U::di, U::uo) is det <= pt_output(S, U). -mercury_format_type_subst(VarSet, VarNamePrint, Var - Type, S, !U) :- - mercury_format_var_vs(VarSet, VarNamePrint, Var, S, !U), +mercury_format_tvar_subst(VarSet, TVarSubst, S, !U) :- + % The code that parses type_spec pragmas ensures that all type variables + % in the substitution are named. Therefore there is no reason to print + % variable numbers. In fact, printing variable numbers would be a bug, + % since any code reading the pragma we are now writing out would mistake + % the variable number as part of the variable *name*. See the long comment + % on the tspec_tvarset field of the pragma in prog_item.m. + TVarSubst = tvar_subst(Var, Type), + mercury_format_var_vs(VarSet, print_name_only, Var, S, !U), add_string(" = ", S, !U), - mercury_format_type(VarSet, VarNamePrint, Type, S, !U). + mercury_format_type(VarSet, print_name_only, Type, S, !U). %---------------------------------------------------------------------------% % @@ -1605,8 +1676,15 @@ mercury_pred_name_arity_to_string(PredName, UserArity) = Str :- :- pred mercury_format_pred_name_arity(sym_name::in, user_arity::in, S::in, U::di, U::uo) is det <= pt_output(S, U). -mercury_format_pred_name_arity(PredName, user_arity(Arity), S, !U) :- - NGT = next_to_graphic_token, +mercury_format_pred_name_arity(PredName, UserArity, S, !U) :- + mercury_format_pred_name_arity_ngt(next_to_graphic_token, PredName, + UserArity, S, !U). + +:- pred mercury_format_pred_name_arity_ngt(needs_quotes::in, + sym_name::in, user_arity::in, S::in, U::di, U::uo) is det + <= pt_output(S, U). + +mercury_format_pred_name_arity_ngt(NGT, PredName, user_arity(Arity), S, !U) :- mercury_format_bracketed_sym_name_ngt(NGT, PredName, S, !U), add_string("/", S, !U), add_int(Arity, S, !U). @@ -1627,7 +1705,8 @@ mercury_pred_pf_name_arity_to_string(PredOrFunc, PredName, UserArity) = Str :- mercury_format_pred_pf_name_arity(PredOrFunc, PredName, UserArity, S, !U) :- add_string(pred_or_func_to_str(PredOrFunc), S, !U), add_string("(", S, !U), - mercury_format_pred_name_arity(PredName, UserArity, S, !U), + mercury_format_pred_name_arity_ngt(not_next_to_graphic_token, + PredName, UserArity, S, !U), add_string(")", S, !U). :- func mercury_pred_pfu_name_arity_to_string(pred_func_or_unknown, diff --git a/compiler/parse_tree_out_sym_name.m b/compiler/parse_tree_out_sym_name.m index 076828d1a..dc519bd0f 100644 --- a/compiler/parse_tree_out_sym_name.m +++ b/compiler/parse_tree_out_sym_name.m @@ -255,12 +255,25 @@ mercury_output_bracketed_sym_name_ngt(NextToGraphicToken, SymName, mercury_format_bracketed_sym_name_ngt(NextToGraphicToken, SymName, S, !U) :- ( SymName = qualified(ModuleName, Name), + % XXX REDUNDANT PARENS +% ( +% NextToGraphicToken = next_to_graphic_token, +% add_string("(", S, !U) +% ; +% NextToGraphicToken = not_next_to_graphic_token +% ), add_string("(", S, !U), mercury_format_bracketed_sym_name_ngt(next_to_graphic_token, ModuleName, S, !U), add_string(".", S, !U), mercury_format_bracketed_atom(next_to_graphic_token, Name, S, !U), add_string(")", S, !U) +% ( +% NextToGraphicToken = next_to_graphic_token, +% add_string(")", S, !U) +% ; +% NextToGraphicToken = not_next_to_graphic_token +% ) ; SymName = unqualified(Name), mercury_format_bracketed_atom(NextToGraphicToken, Name, S, !U) diff --git a/compiler/parse_tree_out_type.m b/compiler/parse_tree_out_type.m index 942d9acd6..da1242aef 100644 --- a/compiler/parse_tree_out_type.m +++ b/compiler/parse_tree_out_type.m @@ -26,7 +26,8 @@ %---------------------------------------------------------------------------% -:- func mercury_type_list_to_string(tvarset, list(mer_type)) = string. +:- func mercury_types_to_string(tvarset, var_name_print, list(mer_type)) + = string. :- func mercury_type_to_string(tvarset, var_name_print, mer_type) = string. :- pred mercury_output_type(tvarset::in, var_name_print::in, mer_type::in, @@ -92,19 +93,20 @@ %---------------------------------------------------------------------------% -mercury_type_list_to_string(_, []) = "". -mercury_type_list_to_string(VarSet, [Type | Types]) = String :- - HeadString = mercury_type_to_string(VarSet, print_name_only, Type), - TailString = mercury_comma_type_list_to_string(VarSet, Types), - String = HeadString ++ TailString. +mercury_types_to_string(_, _, []) = "". +mercury_types_to_string(VarSet, VarNamePrint, [Type | Types]) = Str :- + HeadStr = mercury_type_to_string(VarSet, VarNamePrint, Type), + TailStr = mercury_comma_types_to_string(VarSet, VarNamePrint, Types), + Str = HeadStr ++ TailStr. -:- func mercury_comma_type_list_to_string(tvarset, list(mer_type)) = string. +:- func mercury_comma_types_to_string(tvarset, var_name_print, list(mer_type)) + = string. -mercury_comma_type_list_to_string(_, []) = "". -mercury_comma_type_list_to_string(VarSet, [Type | Types]) = String :- - HeadString = mercury_type_to_string(VarSet, print_name_only, Type), - TailString = mercury_comma_type_list_to_string(VarSet, Types), - String = ", " ++ HeadString ++ TailString. +mercury_comma_types_to_string(_, _, []) = "". +mercury_comma_types_to_string(VarSet, VarNamePrint, [Type | Types]) = Str :- + HeadStr = mercury_type_to_string(VarSet, VarNamePrint, Type), + TailStr = mercury_comma_types_to_string(VarSet, VarNamePrint, Types), + Str = ", " ++ HeadStr ++ TailStr. %---------------------------------------------------------------------------% diff --git a/compiler/parse_type_name.m b/compiler/parse_type_name.m index 148fcdc88..ef9825fde 100644 --- a/compiler/parse_type_name.m +++ b/compiler/parse_type_name.m @@ -49,6 +49,7 @@ ; wnhii_ctgc_type_selector ; wnhii_pragma_struct_sharing ; wnhii_pragma_struct_reuse + ; wnhii_pragma_type_spec_constr ; wnhii_pragma_type_spec. :- pred maybe_parse_type(allow_ho_inst_info::in, term::in, mer_type::out) @@ -847,6 +848,9 @@ no_ho_inst_allowed_result(ContextPieces, Why, VarSet, Term) = Result :- ; Why = wnhii_pragma_struct_reuse, Place = "a structure_reuse pragma" + ; + Why = wnhii_pragma_type_spec_constr, + Place = "a type_spec_constrained_preds pragma" ; Why = wnhii_pragma_type_spec, Place = "a type_spec pragma" diff --git a/compiler/pred_name.m b/compiler/pred_name.m index b0527f884..5ac3938f1 100644 --- a/compiler/pred_name.m +++ b/compiler/pred_name.m @@ -956,7 +956,8 @@ origin_user_to_user_dev_string(UserOrDev, OriginUser) = Str :- InstanceTypes, _, _), ClassId = class_id(ClassName, _), ClassStr = sym_name_to_string(ClassName), - TypeStrs = mercury_type_list_to_string(varset.init, InstanceTypes), + TypeStrs = mercury_types_to_string(varset.init, print_name_only, + InstanceTypes), ( UserOrDev = user, string.format("instance method %s for `%s(%s)'", @@ -1852,9 +1853,9 @@ type_subst_to_string(VarSet, TypeSubst) = Str :- TVarsStr = string.join_list(", ", TVarStrs), string.format("[%s]", [s(TVarsStr)], Str). -:- func type_var_subst_to_string(tvarset, pair(tvar, mer_type)) = string. +:- func type_var_subst_to_string(tvarset, tvar_subst) = string. -type_var_subst_to_string(VarSet, Var - Type) = Str :- +type_var_subst_to_string(VarSet, tvar_subst(Var, Type)) = Str :- varset.lookup_name(VarSet, Var, VarName), TypeStr = mercury_type_to_string(VarSet, print_name_only, Type), % XXX The use of = here *requires* mangling the names we construct. diff --git a/compiler/prog_data.m b/compiler/prog_data.m index 2a768a1ef..51502ea65 100644 --- a/compiler/prog_data.m +++ b/compiler/prog_data.m @@ -871,6 +871,15 @@ cons_id_is_const_struct(ConsId, ConstNum) :- % A type expression with an explicit kind annotation. % (These are not yet used.) +:- type ground_type =< mer_type + ---> defined_type(sym_name, list(ground_type), kind) + ; builtin_type(builtin_type) + ; tuple_type(list(ground_type), kind) + ; higher_order_type(pred_or_func, list(ground_type), ho_inst_info, + purity, lambda_eval_method) + ; apply_n_type(tvar, list(ground_type), kind) + ; kinded_type(ground_type, kind). + % We could use this subtype in the mercury_nb_type function symbol % of mlds_type in mlds.m. % diff --git a/compiler/prog_data_pragma.m b/compiler/prog_data_pragma.m index eb7c6ef71..6c9be67f9 100644 --- a/compiler/prog_data_pragma.m +++ b/compiler/prog_data_pragma.m @@ -477,9 +477,11 @@ tabled_eval_method_to_table_type(EvalMethod) = TableTypeStr :- % The type substitution for a `pragma type_spec' declaration. % Elsewhere in the compiler we generally use the `tsubst' type - % which is a map rather than an assoc_list. + % which is a map rather than (effectively) an assoc_list. % -:- type type_subst == one_or_more(pair(tvar, mer_type)). +:- type type_subst == one_or_more(tvar_subst). +:- type tvar_subst + ---> tvar_subst(tvar, mer_type). %---------------------------------------------------------------------------% % diff --git a/compiler/prog_item.m b/compiler/prog_item.m index b1edddd2a..d5c14ff5e 100644 --- a/compiler/prog_item.m +++ b/compiler/prog_item.m @@ -1441,6 +1441,12 @@ ---> item_typeclass_info( tc_class_name :: class_name, tc_class_params :: list(tvar), + % The argument list of every superclass constraint + % must be either a type variable, or a ground type. + % This is enforced by parse_superclass_constraints + % in parse_class.m. + % XXX We should consider changing the type of this field + % from list(prog_constraint) to list(var_or_ground_constraint). tc_superclasses :: list(prog_constraint), tc_fundeps :: list(prog_fundep), tc_class_methods :: class_interface, @@ -2471,6 +2477,7 @@ ---> decl_pragma_obsolete_pred(decl_pragma_obsolete_pred_info) ; decl_pragma_obsolete_proc(decl_pragma_obsolete_proc_info) ; decl_pragma_format_call(decl_pragma_format_call_info) + ; decl_pragma_type_spec_constr(decl_pragma_type_spec_constr_info) ; decl_pragma_type_spec(decl_pragma_type_spec_info) ; decl_pragma_oisu(decl_pragma_oisu_info) ; decl_pragma_termination(decl_pragma_termination_info) @@ -2523,6 +2530,64 @@ format_seq_num :: item_seq_num ). +:- type decl_pragma_type_spec_constr_info + ---> decl_pragma_type_spec_constr_info( + % The name of the module from whose (source or interface) file + % we read the type_spec_constrained_preds pragma. This will + % always name the module that contains the pragma, because + % we never put a type_spec_constrained_preds pragma into + % any interface file other than an interface file of the + % module containing the pragma. + tsc_module_name :: module_name, + + % The list of constraints in the first argument of the pragma. + % The pragma asks for the type specialization of any predicates + % whose class context includes any nonempty subset of these + % constraints, and possibly (see the next field) their + % superclasses, as instances. + tsc_constraints :: one_or_more(var_or_ground_constraint), + + % The second argument of the pragma, which specifies whether + % the constraints in the first argument also implicitly specify + % their superclasses, *their* superclasses, and so on. + % If e.g. tc1(A, B, C) has tc2(A, B) as one of its + % superclasses, then a setting of apply_to_supers in this field + % means that the pragma asks us to specialize not only + % predicates whose class context includes tc1(A, char, B) + % (if that is has as its instance of one of the constraints), + % but also e.g. tc2(A, char). + tsc_apply_to_supers :: maybe_apply_to_supers, + + % The third argument of the pragma, which specifies the list + % of type substitutions for which the pragma asks us to create + % type-specialized versions of each predicate that matches + % the requirements described by the first and second args. + % + % Each type var on the left-hand-side of a substitution + % must occur in tsc_constraints, while all type vars that + % occur in a type on the right-hand-side of a substitution + % must be anonymous. These requirements are enforced by the + % code that parses these pragmas. + tsc_tsubst :: one_or_more(type_subst), + + % The varset of the term containing the pragma, coerced + % to being a tvarset (since all variables in the pragma + % are type variables). + % + % All variables in this tvarset have to have explicit names. + % If the original pragma contains anonymous variables, the + % code constructing this decl_pragma_type_spec will give + % those variable names. See the comment on the tspec_tvarset + % field below for the reason behind this requirement. + tsc_tvarset :: tvarset, + + % The equivalence types used. + tsc_items :: set(recomp_item_id), + + tsc_context :: prog_context, + tsc_seq_num :: item_seq_num + ). + :- type decl_pragma_type_spec_info ---> decl_pragma_type_spec_info( tspec_pfumm :: pred_func_or_unknown_maybe_modes, @@ -2532,7 +2597,7 @@ % The name of the module from whose (source or interface) file % we read the type_spec pragma. This will always name - % the module that contain the pragma, because we never put + % the module that contains the pragma, because we never put % a type_spec pragma into any interface file other than % an interface file of the module containing the pragma. tspec_module_name :: module_name, @@ -2580,6 +2645,21 @@ tspec_seq_num :: item_seq_num ). +:- type var_or_ground_constraint + ---> var_or_ground_constraint( + class_name, + list(var_or_ground_type), + prog_context + ). + +:- type var_or_ground_type + ---> type_var_name(tvar, string) + ; ground_type(ground_type). + +:- type maybe_apply_to_supers + ---> do_not_apply_to_supers + ; apply_to_supers. + :- type decl_pragma_oisu_info ---> decl_pragma_oisu_info( oisu_type_ctor :: type_ctor, @@ -3493,6 +3573,9 @@ get_decl_pragma_context(DeclPragma) = Context :- ; DeclPragma = decl_pragma_format_call(FormatCall), Context = FormatCall ^ format_context + ; + DeclPragma = decl_pragma_type_spec_constr(TypeSpecConstr), + Context = TypeSpecConstr ^ tsc_context ; DeclPragma = decl_pragma_type_spec(TypeSpec), Context = TypeSpec ^ tspec_context diff --git a/compiler/prog_item_stats.m b/compiler/prog_item_stats.m index b06a5da00..7aa5e06d7 100644 --- a/compiler/prog_item_stats.m +++ b/compiler/prog_item_stats.m @@ -329,6 +329,7 @@ gather_stats_in_item_decl_pragma(DeclPragma, !ItemStats) :- ; ( DeclPragma = decl_pragma_format_call(_) ; DeclPragma = decl_pragma_type_spec(_) + ; DeclPragma = decl_pragma_type_spec_constr(_) ; DeclPragma = decl_pragma_obsolete_pred(_) ; DeclPragma = decl_pragma_obsolete_proc(_) ; DeclPragma = decl_pragma_oisu(_) diff --git a/compiler/prog_type_test.m b/compiler/prog_type_test.m index 39dc53e4a..cbddd4cd0 100644 --- a/compiler/prog_type_test.m +++ b/compiler/prog_type_test.m @@ -68,9 +68,11 @@ %---------------------------------------------------------------------------% % Succeeds iff the given type is ground (that is, contains no type - % variables). + % variables). The second version returns the input type with a form + % that expresses its groundness in its own type. % :- pred type_is_ground(mer_type::in) is semidet. +:- pred type_is_ground(mer_type::in, ground_type::out) is semidet. % Succeeds iff the given type contains no type variables except % for those in the given list. @@ -174,6 +176,42 @@ type_is_higher_order_details_det(Type, !:Purity, !:PredOrFunc, !:EvalMethod, type_is_ground(Type) :- not type_contains_var(Type, _). +type_is_ground(Type, GroundType) :- + require_complete_switch [Type] + ( + ( Type = type_variable(_TVar, _) + ; Type = apply_n_type(_TVar, _, _) + ), + fail + ; + Type = builtin_type(BuiltinType), + GroundType = builtin_type(BuiltinType) + ; + Type = defined_type(SymName, ArgTypes, Kind), + types_are_ground(ArgTypes, GroundArgTypes), + GroundType = defined_type(SymName, GroundArgTypes, Kind) + ; + Type = tuple_type(ArgTypes, Kind), + types_are_ground(ArgTypes, GroundArgTypes), + GroundType = tuple_type(GroundArgTypes, Kind) + ; + Type = higher_order_type(PorF, ArgTypes, HoInstInfo, Purity, EM), + types_are_ground(ArgTypes, GroundArgTypes), + GroundType = higher_order_type(PorF, GroundArgTypes, HoInstInfo, + Purity, EM) + ; + Type = kinded_type(SubType, Kind), + type_is_ground(SubType, GroundSubType), + GroundType = kinded_type(GroundSubType, Kind) + ). + +:- pred types_are_ground(list(mer_type)::in, list(ground_type)::out) is semidet. + +types_are_ground([], []). +types_are_ground([Type | Types], [GroundType | GroundTypes]) :- + type_is_ground(Type, GroundType), + types_are_ground(Types, GroundTypes). + type_is_ground_except_vars(Type, Except) :- all [TVar] ( type_contains_var(Type, TVar) diff --git a/compiler/prog_type_unify.m b/compiler/prog_type_unify.m index 6ee13fe7c..5ccbdf09c 100644 --- a/compiler/prog_type_unify.m +++ b/compiler/prog_type_unify.m @@ -31,8 +31,8 @@ % No kind checking is done, since it is assumed that kind errors % will be picked up elsewhere. % -:- pred type_unify(mer_type::in, mer_type::in, list(tvar)::in, tsubst::in, - tsubst::out) is semidet. +:- pred type_unify(mer_type::in, mer_type::in, list(tvar)::in, + tsubst::in, tsubst::out) is semidet. :- pred type_unify_list(list(mer_type)::in, list(mer_type)::in, list(tvar)::in, tsubst::in, tsubst::out) is semidet. diff --git a/compiler/recompilation.usage.m b/compiler/recompilation.usage.m index 6315e7658..d178d9e9f 100644 --- a/compiler/recompilation.usage.m +++ b/compiler/recompilation.usage.m @@ -42,6 +42,7 @@ :- import_module mdbcomp.prim_data. :- import_module mdbcomp.sym_name. :- import_module parse_tree.prog_data. +:- import_module parse_tree.prog_data_pragma. :- import_module parse_tree.prog_item. :- import_module parse_tree.prog_type. :- import_module parse_tree.prog_type_test. @@ -799,7 +800,8 @@ find_items_used_by_pred(PredOrFunc, NameArity, PredId - PredModule, !Info) :- % Record items used by `:- pragma type_spec' declarations. module_info_get_type_spec_info(ModuleInfo, TypeSpecInfo), TypeSpecInfo = type_spec_info(_, _, _, PragmaMap), - ( if map.search(PragmaMap, PredId, TypeSpecPragmas) then + ( if map.search(PragmaMap, PredId, OoMTypeSpecPragmas) then + TypeSpecPragmas = one_or_more_to_list(OoMTypeSpecPragmas), list.foldl(find_items_used_by_type_spec, TypeSpecPragmas, !Info) else true @@ -831,7 +833,8 @@ find_items_used_by_type_spec(TypeSpecInfo, !Info) :- ; PFUMM = pfumm_unknown(_Arity) ), - assoc_list.values(one_or_more_to_list(Subst), SubstTypes), + SubstTypes = list.map((func(tvar_subst(_Var, Type)) = Type), + one_or_more_to_list(Subst)), find_items_used_by_types(SubstTypes, !Info). :- pred find_items_used_by_functors(simple_item_set::in, diff --git a/compiler/recompilation.version.m b/compiler/recompilation.version.m index affef21dc..c7c6f0e66 100644 --- a/compiler/recompilation.version.m +++ b/compiler/recompilation.version.m @@ -91,6 +91,7 @@ :- import_module parse_tree.parse_tree_out_term. :- import_module parse_tree.parse_tree_to_term. :- import_module parse_tree.parse_util. +:- import_module parse_tree.prog_data_pragma. :- import_module parse_tree.prog_type. :- import_module parse_tree.prog_type_subst. :- import_module parse_tree.prog_type_unify. @@ -957,6 +958,14 @@ distribute_pragma_items_class_items(MaybePredOrFunc, SymName, Arity, gather_decl_pragma_for_what_pf_id(DeclPragma, MaybePredOrFuncId) :- ( + DeclPragma = decl_pragma_type_spec_constr(_TypeSpecConstr), + % XXX Unlike all the other decl_pragmas, the type_spec_constr + % pragma is not about a single specified predicate or function, + % but about all predicates and functions that have a specified + % set of constraints in their signature. That set is computed later, + % when we add this pragma to the HLDS. + MaybePredOrFuncId = no + ; DeclPragma = decl_pragma_type_spec(TypeSpec), TypeSpec = decl_pragma_type_spec_info(PFUMM, Name, _, _, _, _, _, _), pfumm_to_maybe_pf_arity_maybe_modes(PFUMM, MaybePredOrFunc, @@ -1422,6 +1431,24 @@ is_decl_pragma_changed(DeclPragma1, DeclPragma2, Changed) :- DeclPragma2 = decl_pragma_format_call(FormatCall2), FormatCall1 = decl_pragma_format_call_info(A, B, _, _), FormatCall2 = decl_pragma_format_call_info(A, B, _, _) + ; + DeclPragma1 = decl_pragma_type_spec_constr(TypeSpecConstr1), + DeclPragma2 = decl_pragma_type_spec_constr(TypeSpecConstr2), + TypeSpecConstr1 = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints1, ApplyToSupers1, OoMTypeSubsts1, TVarSet1, + _, _, _), + TypeSpecConstr2 = decl_pragma_type_spec_constr_info(ModuleName, + OoMConstraints2, ApplyToSupers2, OoMTypeSubsts2, TVarSet2, + _, _, _), + ApplyToSupers1 = ApplyToSupers2, + Constraints1 = one_or_more_to_list(OoMConstraints1), + Constraints2 = one_or_more_to_list(OoMConstraints2), + is_any_var_or_ground_constraint_changed(TVarSet1, TVarSet2, + Constraints1, Constraints2, unchanged), + TypeSubsts1 = one_or_more_to_list(OoMTypeSubsts1), + TypeSubsts2 = one_or_more_to_list(OoMTypeSubsts2), + is_any_type_subst_changed(TVarSet1, TVarSet2, + TypeSubsts1, TypeSubsts2, unchanged) ; DeclPragma1 = decl_pragma_type_spec(TypeSpec1), DeclPragma2 = decl_pragma_type_spec(TypeSpec2), @@ -1429,19 +1456,8 @@ is_decl_pragma_changed(DeclPragma1, DeclPragma2, Changed) :- TypeSubst1, TVarSet1, _, _, _), TypeSpec2 = decl_pragma_type_spec_info(PFUMM, Name, SpecName, TypeSubst2, TVarSet2, _, _, _), - assoc_list.keys_and_values(one_or_more_to_list(TypeSubst1), - TVars1, Types1), - assoc_list.keys_and_values(one_or_more_to_list(TypeSubst2), - TVars2, Types2), - % XXX kind inference: - % we assume vars have kind `star'. - KindMap = map.init, - prog_type.var_list_to_type_list(KindMap, TVars1, TVarTypes1), - prog_type.var_list_to_type_list(KindMap, TVars2, TVarTypes2), - type_list_is_unchanged( - TVarSet1, TVarTypes1 ++ Types1, - TVarSet2, TVarTypes2 ++ Types2, - _, _, _) + is_type_subst_changed(TVarSet1, TVarSet2, TypeSubst1, TypeSubst2, + unchanged) ; DeclPragma1 = decl_pragma_oisu(OISU1), DeclPragma2 = decl_pragma_oisu(OISU2), @@ -1616,7 +1632,7 @@ pred_or_func_type_is_unchanged(TVarSet1, ExistQVars1, TypesAndMaybeModes1, AllTypes2 = Types2 ), - type_list_is_unchanged(TVarSet1, AllTypes1, TVarSet2, AllTypes2, + type_list_is_unchanged(TVarSet1, TVarSet2, AllTypes1, AllTypes2, _TVarSet, Renaming, Types2ToTypes1Subst), % Check that the existentially quantified variables are equivalent. @@ -1645,11 +1661,104 @@ pred_or_func_type_is_unchanged(TVarSet1, ExistQVars1, TypesAndMaybeModes1, RenamedConstraints2, SubstConstraints2), Constraints1 = SubstConstraints2. -:- pred type_list_is_unchanged(tvarset::in, list(mer_type)::in, - tvarset::in, list(mer_type)::in, tvarset::out, - tvar_renaming::out, tsubst::out) is semidet. +:- pred is_any_var_or_ground_constraint_changed(tvarset::in, tvarset::in, + list(var_or_ground_constraint)::in, list(var_or_ground_constraint)::in, + maybe_changed::out) is det. -type_list_is_unchanged(TVarSet1, Types1, TVarSet2, Types2, +is_any_var_or_ground_constraint_changed(_, _, [], [], unchanged). +is_any_var_or_ground_constraint_changed(_, _, [], [_ | _], changed). +is_any_var_or_ground_constraint_changed(_, _, [_ | _], [], changed). +is_any_var_or_ground_constraint_changed(TVarSet1, TVarSet2, + [Constraint1 | Constraints1], [Constraint2 | Constraints2], Changed) :- + is_var_or_ground_constraint_changed(TVarSet1, TVarSet2, + Constraint1, Constraint2, HeadChanged), + ( + HeadChanged = changed, + Changed = changed + ; + HeadChanged = unchanged, + is_any_var_or_ground_constraint_changed(TVarSet1, TVarSet2, + Constraints1, Constraints2, Changed) + ). + +:- pred is_var_or_ground_constraint_changed(tvarset::in, tvarset::in, + var_or_ground_constraint::in, var_or_ground_constraint::in, + maybe_changed::out) is det. + +is_var_or_ground_constraint_changed(TVarSet1, TVarSet2, + Constraint1, Constraint2, Changed) :- + Constraint1 = var_or_ground_constraint(ClassName1, Args1, _), + Constraint2 = var_or_ground_constraint(ClassName2, Args2, _), + VarOrGroundToType = + ( pred(Arg::in, Type::out) is det :- + ( + Arg = type_var_name(TVar, _), + Type = type_variable(TVar, kind_star) + ; + Arg = ground_type(GroundType), + Type = coerce(GroundType) + ) + ), + list.map(VarOrGroundToType, Args1, ArgTypes1), + list.map(VarOrGroundToType, Args2, ArgTypes2), + ( if + ClassName1 = ClassName2, + type_list_is_unchanged(TVarSet1, TVarSet2, ArgTypes1, ArgTypes2, + _, _, _) + then + Changed = unchanged + else + Changed = changed + ). + +:- pred is_any_type_subst_changed(tvarset::in, tvarset::in, + list(type_subst)::in, list(type_subst)::in, maybe_changed::out) is det. + +is_any_type_subst_changed(_, _, [], [], unchanged). +is_any_type_subst_changed(_, _, [], [_ | _], changed). +is_any_type_subst_changed(_, _, [_ | _], [], changed). +is_any_type_subst_changed(TVarSet1, TVarSet2, + [TypeSubst1 | TypeSubsts1], [TypeSubst2 | TypeSubsts2], Changed) :- + is_type_subst_changed(TVarSet1, TVarSet2, + TypeSubst1, TypeSubst2, HeadChanged), + ( + HeadChanged = changed, + Changed = changed + ; + HeadChanged = unchanged, + is_any_type_subst_changed(TVarSet1, TVarSet2, + TypeSubsts1, TypeSubsts2, Changed) + ). + +:- pred is_type_subst_changed(tvarset::in, tvarset::in, + type_subst::in, type_subst::in, maybe_changed::out) is det. + +is_type_subst_changed(TVarSet1, TVarSet2, TypeSubst1, TypeSubst2, Changed) :- + GetVarType = + ( pred(tvar_subst(TVar, Type)::in, TVar::out, Type::out) is det ), + list.map2(GetVarType, one_or_more_to_list(TypeSubst1), + TVars1, Types1), + list.map2(GetVarType, one_or_more_to_list(TypeSubst2), + TVars2, Types2), + % XXX kind inference: + % we assume vars have kind `star'. + KindMap = map.init, + prog_type.var_list_to_type_list(KindMap, TVars1, TVarTypes1), + prog_type.var_list_to_type_list(KindMap, TVars2, TVarTypes2), + ( if + type_list_is_unchanged(TVarSet1, TVarSet2, + TVarTypes1 ++ Types1, TVarTypes2 ++ Types2, _, _, _) + then + Changed = unchanged + else + Changed = changed + ). + +:- pred type_list_is_unchanged(tvarset::in, tvarset::in, + list(mer_type)::in, list(mer_type)::in, + tvarset::out, tvar_renaming::out, tsubst::out) is semidet. + +type_list_is_unchanged(TVarSet1, TVarSet2, Types1, Types2, TVarSet, Renaming, Types2ToTypes1Subst) :- tvarset_merge_renaming(TVarSet1, TVarSet2, TVarSet, Renaming), apply_variable_renaming_to_type_list(Renaming, Types2, SubstTypes2), diff --git a/doc/user_guide.texi b/doc/user_guide.texi index 05b3df26f..069d67ee5 100644 --- a/doc/user_guide.texi +++ b/doc/user_guide.texi @@ -7048,6 +7048,13 @@ could be packed more tightly if they were reordered. @c Print an informational message for each otherwise-ignored error @c that reports an inability to find the procedure that a pragma refers to. +@c @sp 1 +@c @item --inform-generated-type-spec-pragmas +@c @findex --inform-generated-type-spec-pragmas +@c Print an informational message for each @code{type_spec pragma} that +@c the compiler generates to implement +@c a @code{type_spec_constrained_pred} pragma. + @end table @node Verbosity options diff --git a/mdbcomp/slice_and_dice.m b/mdbcomp/slice_and_dice.m index d46cf5218..fb7ab4903 100644 --- a/mdbcomp/slice_and_dice.m +++ b/mdbcomp/slice_and_dice.m @@ -976,14 +976,16 @@ format_float(DecimalPlaces, Flt) = :- pred proc_label_is_for_module(string::in, proc_label::in) is semidet. -proc_label_is_for_module(Module, ProcLabel) :- +proc_label_is_for_module(ModuleNameStr, ProcLabel) :- ( - ProcLabel = ordinary_proc_label(_, _, ProcSymModule, _, _, _) + ProcLabel = ordinary_proc_label(_, _, ProcModuleName, _, _, _) ; - ProcLabel = special_proc_label(_, _, ProcSymModule, _, _, _) + ProcLabel = special_proc_label(_, _, ProcModuleName, _, _, _) ), - SymModule = string_to_sym_name(Module), - is_submodule(ProcSymModule, SymModule). + ModuleName = string_to_sym_name(ModuleNameStr), + % XXX Why are we saying that ProcLabel is for ModuleNameStr if it + % specifies the name of a module that is a *submodule* of ModuleNameStr? + is_same_module_or_submodule(ProcModuleName, ModuleName). :- func format_proc_label(proc_label) = string. diff --git a/mdbcomp/sym_name.m b/mdbcomp/sym_name.m index 54da37f4d..3feffef45 100644 --- a/mdbcomp/sym_name.m +++ b/mdbcomp/sym_name.m @@ -100,12 +100,14 @@ % :- pred det_list_to_sym_name(list(string)::in, sym_name::out) is det. - % is_submodule(SymName1, SymName2): + % is_same_module_or_submodule(ModuleName1, ModuleName2): % - % True iff SymName1 is a submodule of SymName2. - % For example mod1.mod2.mod3 is a submodule of mod1.mod2. + % True iff ModuleName1 is either the same as ModuleName2, + % or is a submodule of ModuleName2. For example, mod1.mod2.mod3 + % is a submodule of mod1.mod2. % -:- pred is_submodule(module_name::in, module_name::in) is semidet. +:- pred is_same_module_or_submodule(module_name::in, module_name::in) + is semidet. % Given a symbol name, return its unqualified name. % @@ -333,9 +335,9 @@ list_to_sym_name_loop(RevNames, SymName) :- %---------------------------------------------------------------------------% -is_submodule(SymName, SymName). -is_submodule(qualified(SymNameA, _), SymNameB) :- - is_submodule(SymNameA, SymNameB). +is_same_module_or_submodule(ModuleName, ModuleName). +is_same_module_or_submodule(qualified(ModuleNameA, _), ModuleNameB) :- + is_same_module_or_submodule(ModuleNameA, ModuleNameB). %---------------------------------------------------------------------------% diff --git a/tests/hard_coded/type_spec_modes.m b/tests/hard_coded/type_spec_modes.m index 32f864638..5ff953b17 100644 --- a/tests/hard_coded/type_spec_modes.m +++ b/tests/hard_coded/type_spec_modes.m @@ -21,7 +21,7 @@ :- mode my_unify(out, in) is det. :- pragma no_inline(my_unify/2). -:- pragma type_spec(my_unify(in, in), T = list(int)). +:- pragma type_spec(my_unify(in, in), subst([T = list(int)])). :- pragma type_spec(my_unify(in, in), T = int). :- pragma type_spec(my_unify(in, out), T = int). :- pragma type_spec(my_unify(out, in), T = list(int)). diff --git a/tests/invalid/Mmakefile b/tests/invalid/Mmakefile index 94ea435c0..e8779d85d 100644 --- a/tests/invalid/Mmakefile +++ b/tests/invalid/Mmakefile @@ -79,6 +79,7 @@ BORING_SINGLEMODULE_PROGS = \ bad_pred_arity \ bad_statevar_bad_context \ bad_sv_unify_msg \ + bad_tscp \ bad_type_for_inst \ bind_in_negated \ bind_var_errors \ diff --git a/tests/invalid/bad_tscp.err_exp b/tests/invalid/bad_tscp.err_exp new file mode 100644 index 000000000..9242ca9c6 --- /dev/null +++ b/tests/invalid/bad_tscp.err_exp @@ -0,0 +1,30 @@ +bad_tscp.m:054: Error: in the third argument of a +bad_tscp.m:054: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:054: in the second substitution: +bad_tscp.m:054: any type variables that occur on the right hand side of a +bad_tscp.m:054: substitution must be anonymous, but Y is not. +bad_tscp.m:069: Error: in the third argument of a +bad_tscp.m:069: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:069: in the first substitution: +bad_tscp.m:069: the left-hand-side type variable Unit must occur in the +bad_tscp.m:069: constraints listed in the first argument, but it does not. +bad_tscp.m:069: Error: in the third argument of a +bad_tscp.m:069: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:069: in the first substitution: +bad_tscp.m:069: any type variables that occur on the right hand side of a +bad_tscp.m:069: substitution must be anonymous, but T is not. +bad_tscp.m:069: Error: in the third argument of a +bad_tscp.m:069: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:069: in the second substitution: +bad_tscp.m:069: the left-hand-side type variables Unit and Xyzzy must occur +bad_tscp.m:069: in the constraints listed in the first argument, but they do +bad_tscp.m:069: not. +bad_tscp.m:069: Error: in the third argument of a +bad_tscp.m:069: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:069: in the second substitution: +bad_tscp.m:069: any type variables that occur on the right hand side of a +bad_tscp.m:069: substitution must be anonymous, but U, K and V are not. +bad_tscp.m:072: In the third argument of a +bad_tscp.m:072: `:- pragma type_spec_constrained_preds' declaration: +bad_tscp.m:072: on the left hand side of the arrow: +bad_tscp.m:072: error: expected a variable, got `set(U)'. diff --git a/tests/invalid/bad_tscp.m b/tests/invalid/bad_tscp.m new file mode 100644 index 000000000..7c9153f9a --- /dev/null +++ b/tests/invalid/bad_tscp.m @@ -0,0 +1,79 @@ +%---------------------------------------------------------------------------% +% vim: ts=4 sw=4 et ft=mercury +%---------------------------------------------------------------------------% +% Test the operation of type_spec_constrained_preds pragmas. +% We keep the module name short to make the type_spec pragmas +% that the compiler outputs as informational messages fit on one line. +%---------------------------------------------------------------------------% + +:- module bad_tscp. +:- interface. + +:- import_module io. +:- pred main(io::di, io::uo) is det. + +%---------------------------------------------------------------------------% + +:- implementation. + +:- import_module bool. +:- import_module char. +:- import_module list. +:- import_module term. +:- import_module stream. +:- import_module string. +:- import_module string.builder. + +%---------------------------------------------------------------------------% + +:- typeclass tc1(E, F, G, H) <= (tc2(E, int, H), tc4(float, G)) where []. +:- typeclass tc2(K, L, M) <= (tc3(K, L), tc3(L, M)) where []. +:- typeclass tc3(P, Q) where []. +:- typeclass tc4(S, T) where []. + +:- instance tc1(int, int, int, int) where []. +:- instance tc2(int, int, int) where []. +:- instance tc3(int, int) where []. +:- instance tc4(float, int) where []. + +%---------------------------------------------------------------------------% + +main(!IO) :- + p1(41, 42, 43, 44, N), + io.write_int(N, !IO), + io.nl(!IO), + + io.input_stream(InputStream, !IO), + p2({InputStream, 'a', make_io_error("xyzzy")}, !IO). + +%---------------------------------------------------------------------------% + +:- pragma type_spec_constrained_preds( + [tc1(X1, X2, X3, X4)], + apply_to_superclasses, + [subst([X2 => char, X3 => bool]), + subst([X3 => int, X4 => var(Y)])]). + +:- pred p1(A::in, B::in, C::in, D::in, D::out) is det <= tc1(A, B, C, D). + +p1(_A, _B, _C, !D). + +%---------------------------------------------------------------------------% + +:- pragma type_spec_constrained_preds( + [stream.line_oriented(Stream, State), + stream.unboxed_reader(Stream, char, State, Error), + stream.putback(Stream, char, State, Error)], + apply_to_superclasses, + [subst([Stream => io.text_input_stream, Unit => list(T), + State => io.state, Error => io.error]), + subst([Stream => set(U), Unit => map(K, V), + State => io.state, Error => io.error, Xyzzy => float]), + subst([set(U) => map(K, V)])]). + +:- pred p2({Stream, Unit, Error}::in, State::di, State::uo) is det + <= (stream.line_oriented(Stream, State), + stream.unboxed_reader(Stream, char, State, Error), + stream.putback(Stream, Unit, State, Error)). + +p2({_Stream, _Unit, _Errors}, !State). diff --git a/tests/invalid_nodepend/typeclass_test_3.err_exp b/tests/invalid_nodepend/typeclass_test_3.err_exp index ce5c7a95a..7a17277e5 100644 --- a/tests/invalid_nodepend/typeclass_test_3.err_exp +++ b/tests/invalid_nodepend/typeclass_test_3.err_exp @@ -6,5 +6,5 @@ typeclass_test_3.m:005: than `:- import_module' in its interface section(s). typeclass_test_3.m:005: This would normally be a `:- pred' or `:- func' typeclass_test_3.m:005: declaration, or a `:- type', `:- inst', `:- mode', typeclass_test_3.m:005: `:- typeclass' or `:- instance' definition. -typeclass_test_3.m:008: Error: constraints on class declarations may only -typeclass_test_3.m:008: constrain type variables and ground types. +typeclass_test_3.m:008: Error: a class declaration may not contain an inst +typeclass_test_3.m:008: constraint such as `(T =< blah(X))'. diff --git a/tests/warnings/Mercury.options b/tests/warnings/Mercury.options index 419d39a6b..b4754cf2e 100644 --- a/tests/warnings/Mercury.options +++ b/tests/warnings/Mercury.options @@ -79,3 +79,5 @@ MCFLAGS-warn_self_import = --warn-simple-code MCFLAGS-warn_return = --warn-suspicious-foreign-procs MCFLAGS-warn_succ_ind = --warn-suspicious-foreign-procs MCFLAGS-suspicious_foreign_code = --warn-suspicious-foreign-code + +MCFLAGS-test_tscp = --inform-generated-type-spec-pragmas diff --git a/tests/warnings/Mmakefile b/tests/warnings/Mmakefile index c5020a989..7a545e962 100644 --- a/tests/warnings/Mmakefile +++ b/tests/warnings/Mmakefile @@ -56,6 +56,7 @@ ERRORCHECK_PROGS = \ suspicious_foreign_code \ suspicious_recursion \ table_with_inline \ + test_tscp \ unify_f_g \ unify_x_f_x \ unknown_warning \ diff --git a/tests/warnings/test_tscp.exp b/tests/warnings/test_tscp.exp index db73788cb..76f1fe772 100644 --- a/tests/warnings/test_tscp.exp +++ b/tests/warnings/test_tscp.exp @@ -1,4 +1,16 @@ -% For the type_spec_constrained_pred pragma at test_tscp.m:37, +% For the type_spec_constrained_preds pragma at test_tscp.m:54, % the compiler generated these type_spec pragmas: -% :- pragma type_spec(pred((test_tscp.test)/5), (C = int, D = term.var(V_3))). -% :- pragma type_spec(pred((test_tscp.test)/5), (B = character, C = bool.bool)). +% :- pragma type_spec(pred((test_tscp.p1)/5), (C = int, D = term.var(V_3))). +% :- pragma type_spec(pred((test_tscp.p1)/5), (B = character, C = bool.bool)). +% For the type_spec_constrained_preds pragma at test_tscp.m:66, +% the compiler generated these type_spec pragmas: +% :- pragma type_spec(pred((test_tscp.p2)/3), (Stream = io.text_input_stream, State = io.state, Error = io.error)). +% For the type_spec_constrained_preds pragma at test_tscp.m:74, +% the compiler generated these type_spec pragmas: +% :- pragma type_spec(pred((test_tscp.p2)/3), (Stream = io.text_input_stream, State = io.state, Error = io.error)). +% For the type_spec_constrained_preds pragma at test_tscp.m:100, +% the compiler generated these type_spec pragmas: +% :- pragma type_spec(pred((test_tscp.p3)/2), A = int). +% :- pragma type_spec(pred((test_tscp.p3)/2), B = int). +% :- pragma type_spec(pred((test_tscp.p3)/2), A = float). +% :- pragma type_spec(pred((test_tscp.p3)/2), B = float). diff --git a/tests/warnings/test_tscp.m b/tests/warnings/test_tscp.m index e92644707..e896a2331 100644 --- a/tests/warnings/test_tscp.m +++ b/tests/warnings/test_tscp.m @@ -12,34 +12,98 @@ :- import_module io. :- pred main(io::di, io::uo) is det. +%---------------------------------------------------------------------------% + :- implementation. :- import_module bool. :- import_module char. :- import_module list. :- import_module term. +:- import_module stream. +:- import_module string. +:- import_module string.builder. -main(!IO) :- - test(41, 42, 43, 44, N), - io.write_int(N, !IO), - io.nl(!IO). +%---------------------------------------------------------------------------% :- typeclass tc1(E, F, G, H) <= (tc2(E, int, H), tc4(float, G)) where []. :- typeclass tc2(K, L, M) <= (tc3(K, L), tc3(L, M)) where []. :- typeclass tc3(P, Q) where []. :- typeclass tc4(S, T) where []. +:- typeclass tc5(S) where []. :- instance tc1(int, int, int, int) where []. :- instance tc2(int, int, int) where []. :- instance tc3(int, int) where []. :- instance tc4(float, int) where []. +:- instance tc5(int) where []. +:- instance tc5(float) where []. + +%---------------------------------------------------------------------------% + +main(!IO) :- + p1(41, 42, 43, 44, N), + io.write_int(N, !IO), + io.nl(!IO), + + io.input_stream(InputStream, !IO), + p2({InputStream, 'a', make_io_error("xyzzy")}, !IO). + +%---------------------------------------------------------------------------% :- pragma type_spec_constrained_preds( [tc1(X1, X2, X3, X4)], apply_to_superclasses, [subst([X2 = char, X3 = bool]), - subst([X3 = int, X4 = var(Y)])]). + subst([X3 = int, X4 = var(_)])]). -:- pred test(A::in, B::in, C::in, D::in, D::out) is det <= tc1(A, B, C, D). +:- pred p1(A::in, B::in, C::in, D::in, D::out) is det <= tc1(A, B, C, D). -test(_A, _B, _C, !D). +p1(_A, _B, _C, !D). + +%---------------------------------------------------------------------------% + +:- pragma type_spec_constrained_preds( + [stream.line_oriented(Stream, State), + stream.unboxed_reader(Stream, char, State, Error), + stream.putback(Stream, char, State, Error)], + apply_to_superclasses, + [subst([Stream = io.text_input_stream, + State = io.state, Error = io.error])]). + +:- pragma type_spec_constrained_preds( + [stream.line_oriented(Stream, State), + stream.unboxed_reader(Stream, char, State, Error), + stream.unboxed_reader(Stream, string, State, Error)], + apply_to_superclasses, + [subst([Stream = io.text_input_stream, + State = io.state, Error = io.error])]). + +:- pred p2({Stream, Unit, Error}::in, State::di, State::uo) is det + <= (stream.line_oriented(Stream, State), + stream.unboxed_reader(Stream, char, State, Error), + stream.putback(Stream, Unit, State, Error)). + +p2({_Stream, _Unit, _Errors}, !State). + +%---------------------------------------------------------------------------% + + % For now, we get only non-composed type_spec pragmas: + % + % :- pragma type_spec(pred((test_tscp.p3)/2), A = int). + % :- pragma type_spec(pred((test_tscp.p3)/2), B = int). + % :- pragma type_spec(pred((test_tscp.p3)/2), A = float). + % :- pragma type_spec(pred((test_tscp.p3)/2), B = float). + % + % We don't (yet) get any type_specs that specialize *both* type vars + % at the same time. +:- pragma type_spec_constrained_preds( + [tc5(X)], + do_not_apply_to_superclasses, + [subst([X => int]), subst([X => float])]). + +:- pred p3({A, B}::in, {B, A}::out) is det <= (tc5(A), tc5(B)). + +p3({A, B}, {B, A}). + +%---------------------------------------------------------------------------% diff --git a/vim/syntax/mercury.vim b/vim/syntax/mercury.vim index aa0a78770..affd1b9ce 100644 --- a/vim/syntax/mercury.vim +++ b/vim/syntax/mercury.vim @@ -100,6 +100,7 @@ syn keyword mercuryPragma promise_equivalent_clauses syn keyword mercuryPragma source_file syn keyword mercuryPragma terminates syn keyword mercuryPragma type_spec +syn keyword mercuryPragma type_spec_constrained_preds syn keyword mercuryCInterface foreign_code syn keyword mercuryCInterface foreign_decl