diff --git a/compiler/add_pragma_decl.m b/compiler/add_pragma_decl.m index 5ad7de9b5..061a971ce 100644 --- a/compiler/add_pragma_decl.m +++ b/compiler/add_pragma_decl.m @@ -45,6 +45,10 @@ list(err_spec)::in, list(err_spec)::out, list(warn_spec)::in, list(warn_spec)::out) is det. +:- pred add_decl_pragmas_input_spec(ims_list(decl_pragma_input_spec_info)::in, + module_info::in, module_info::out, + list(err_spec)::in, list(err_spec)::out) is det. + :- pred add_decl_pragmas_termination(list(decl_pragma_termination_info)::in, module_info::in, module_info::out, list(err_spec)::in, list(err_spec)::out) is det. @@ -74,6 +78,7 @@ :- implementation. :- import_module hlds.hlds_data. +:- import_module hlds.hlds_inst_mode. :- import_module hlds.hlds_markers. :- import_module hlds.hlds_pred. :- import_module hlds.make_hlds.add_pragma_type_spec. @@ -86,6 +91,8 @@ :- import_module mdbcomp.prim_data. :- import_module mdbcomp.sym_name. :- import_module parse_tree.maybe_error. +:- import_module parse_tree.parse_tree_out_term. +:- import_module parse_tree.parse_tree_out_type. :- import_module parse_tree.prog_data. :- import_module parse_tree.prog_data_pragma. :- import_module parse_tree.prog_item_pred_proc_id. @@ -95,6 +102,7 @@ :- import_module transform_hlds.term_constr_util. :- import_module transform_hlds.term_util. +:- import_module bag. :- import_module int. :- import_module map. :- import_module maybe. @@ -136,6 +144,13 @@ add_decl_pragmas_type_spec([Pragma | Pragmas], !ModuleInfo, !QualInfo, add_decl_pragmas_type_spec(Pragmas, !ModuleInfo, !QualInfo, !ErrSpecs, !WarnSpecs). +add_decl_pragmas_input_spec([], !ModuleInfo, !ErrSpecsWarnSpecs). +add_decl_pragmas_input_spec([ImsList | ImsLists], !ModuleInfo, !ErrSpecs) :- + ImsList = ims_sub_list(ItemMercuryStatus, Pragmas), + list.foldl2(add_pragma_input_spec(ItemMercuryStatus), Pragmas, + !ModuleInfo, !ErrSpecs), + add_decl_pragmas_input_spec(ImsLists, !ModuleInfo, !ErrSpecs). + add_decl_pragmas_termination([], !ModuleInfo, !ErrSpecs). add_decl_pragmas_termination([Pragma | Pragmas], !ModuleInfo, !ErrSpecs) :- add_pragma_termination(Pragma, !ModuleInfo, !ErrSpecs), @@ -187,6 +202,10 @@ add_decl_pragma(ProgressStream, ItemMercuryStatus, Pragma, Pragma = decl_pragma_type_spec(TypeSpecInfo), add_pragma_type_spec(TypeSpecInfo, !ModuleInfo, !QualInfo, !ErrSpecs, !WarnSpecs) + ; + Pragma = decl_pragma_input_spec(InputSpecInfo), + add_pragma_input_spec(ItemMercuryStatus, InputSpecInfo, + !ModuleInfo, !ErrSpecs) ; Pragma = decl_pragma_oisu(OISUInfo), add_pragma_oisu(OISUInfo, ItemMercuryStatus, !ModuleInfo, !ErrSpecs) @@ -366,6 +385,270 @@ mark_pred_as_format_call(FormatCallInfo, PragmaStatus, !ModuleInfo, %---------------------% +:- pred add_pragma_input_spec(item_mercury_status::in, + decl_pragma_input_spec_info::in, module_info::in, module_info::out, + list(err_spec)::in, list(err_spec)::out) is det. + +add_pragma_input_spec(ItemMercuryStatus, InputSpec, !ModuleInfo, !ErrSpecs) :- + % XXX If we ever want to get smart recompilation working, we may + % have to do something with _RecompIds. What we do for type_spec pragmas + % may, or may not, be appropriate for input spec pragmas as well. + InputSpec = decl_pragma_input_spec_info(ContainingModuleName, Type, + ReplaceOrAdd, OoMInstCtors, OoMInsts, _RecompIds, + TVarSet, Context, _), + some [!InputSpecs] ( + !:InputSpecs = [], + ( + ItemMercuryStatus = item_defined_in_other_module(_) + ; + ItemMercuryStatus = item_defined_in_this_module(ItemExport), + ( + ItemExport = item_export_anywhere, + ( + ReplaceOrAdd = replace_in_mode, + StatusPieces = [words("Error: a"), + pragma_decl("input_spec"), words("declaration"), + words("that occurs in the interface of its module"), + words("is not allowed to specify")] ++ + color_as_incorrect([words("replace_in_mode,")]) ++ + [words("as this would contradict"), + words("the mode declarations of the"), + words("predicates and/or functions"), + words("in its public interface."), nl], + StatusSpec = spec($pred, severity_error, phase_pt2h, + Context, StatusPieces), + !:InputSpecs = [StatusSpec | !.InputSpecs] + ; + ReplaceOrAdd = add_to_in_mode + ) + ; + ( ItemExport = item_export_nowhere + ; ItemExport = item_export_only_submodules + ) + ) + ), + module_info_get_type_table(!.ModuleInfo, TypeTable), + check_input_spec_type(TypeTable, Type, + [], UnknownTypeCtors, [], NonDuTypeCtors, bag.init, TVars), + ( + UnknownTypeCtors = [] + ; + UnknownTypeCtors = [_ | _], + UCtors = choose_number(UnknownTypeCtors, + "constructor", "constructors"), + Have = choose_number(UnknownTypeCtors, "has", "have"), + UDefns = choose_number(UnknownTypeCtors, + "definition", "definitions"), + UnknownPieces = [words("Error: the type"), words(UCtors)] ++ + piece_list_to_color_pieces(color_subject, "and", [], + UnknownTypeCtors) ++ + [words(Have)] ++ + color_as_incorrect([words("no visible"), words(UDefns), + suffix(".")]) ++ + [nl], + UnknownSpec = spec($pred, severity_error, phase_pt2h, + Context, UnknownPieces), + !:InputSpecs = [UnknownSpec | !.InputSpecs] + ), + ( + NonDuTypeCtors = [] + ; + NonDuTypeCtors = [_ | _], + NDefns = choose_number(NonDuTypeCtors, + "definition", "definitions"), + NCtors = choose_number(NonDuTypeCtors, + "constructor", "constructors"), + Are = choose_number(NonDuTypeCtors, "is a", "are"), + Types = choose_number(NonDuTypeCtors, "type", "type"), + NonDuPieces = [words("Error: the"), words(NDefns), + words("of the type"), words(NCtors)] ++ + piece_list_to_color_pieces(color_subject, "and", [], + NonDuTypeCtors) ++ + [words(Are)] ++ + color_as_incorrect([words("not discriminated union"), + words(Types), suffix(".")]) ++ + [nl], + NonDuSpec = spec($pred, severity_error, phase_pt2h, + Context, NonDuPieces), + !:InputSpecs = [NonDuSpec | !.InputSpecs] + ), + bag.to_list_without_duplicates(TVars, AllTVars), + ( + AllTVars = [] + ; + AllTVars = [_ | _], + AllTVarStrs = list.map( + mercury_var_to_string_vs(TVarSet, print_name_only), + AllTVars), + Vars = choose_number(AllTVarStrs, "variable", "variables"), + TVarPieces = [words("Error: the type being specialized")] ++ + color_as_correct([words("must be a ground type,")]) ++ + [words("but it contains the type"), words(Vars)] ++ + fixed_list_to_color_pieces(color_incorrect, + "and", [suffix(".")], AllTVarStrs) ++ + [nl], + TVarSpec = spec($pred, severity_error, phase_pt2h, + Context, TVarPieces), + !:InputSpecs = [TVarSpec | !.InputSpecs] + ), +% XXX We could relax that requirement to allow non-repeated tvars, +% which would make Type effectively a template. However, for that to work, +% input_specialization.m would need to use a more complex method than +% a simple map lookup to test whether an input_spec pragma is applicable +% to a given predicate or function argument. +% +% bag.to_list_only_duplicates(TVars, DupTVars), +% ( +% DupTVars = [] +% ; +% DupTVars = [_ | _], +% DupTVarStrs = list.map( +% mercury_var_to_string_vs(TVarSet, print_name_only), +% DupTVars), +% Vars = choose_number(DupTVarStrs, "variable", "variables"), +% DupTVarPieces = [words("Error: the type"), words(Vars)] ++ +% fixed_list_to_color_pieces(color_subject, "and", [], +% DupTVarStrs) ++ +% [words("occur")] ++ +% color_as_incorrect([words("more than once")]) ++ +% [words("in the type to be input specialized."), +% words("This is not allowed."), nl], +% DupTVarSpec = spec($pred, severity_error, phase_pt2h, +% Context, DupTVarPieces), +% !:InputSpecs = [DupTVarSpec | !.InputSpecs] +% ), + module_info_get_inst_table(!.ModuleInfo, InstTable), + inst_table_get_user_insts(InstTable, UserInstTable), + one_or_more.foldl(check_input_spec_inst_ctor(UserInstTable), + OoMInstCtors, [], _UndefInstCtors), + ( + !.InputSpecs = [], + module_info_get_input_spec_table(!.ModuleInfo, InputSpecTable0), + InputSpecInfo = input_spec_info(ReplaceOrAdd, OoMInsts, Context), + ( if + map.search(InputSpecTable0, ContainingModuleName, InModuleMap0) + then + map.search_insert(Type, InputSpecInfo, MaybeOldInputSpecInfo, + InModuleMap0, InModuleMap), + ( + MaybeOldInputSpecInfo = no, + map.det_update(ContainingModuleName, InModuleMap, + InputSpecTable0, InputSpecTable), + module_info_set_input_spec_table(InputSpecTable, + !ModuleInfo) + ; + MaybeOldInputSpecInfo = yes(OldInputSpecInfo), + OldInputSpecInfo = input_spec_info(_, _, OldContext), + TypeStr = mercury_type_to_string(TVarSet, + print_name_only, Type), + DupDeclPiecesNew = [words("Error: duplicate"), + pragma_decl("input_spec"), words("declaration for")] ++ + color_as_subject([words(TypeStr), suffix(".")]) ++ + [nl], + DupDeclMsgNew = msg(Context, DupDeclPiecesNew), + DupDeclPiecesOld = [words("The previous declaration"), + words("was here."), nl], + DupDeclMsgOld = msg(OldContext, DupDeclPiecesOld), + DupDeclSpec = gen_spec($pred, severity_error, phase_pt2h, + [DupDeclMsgNew, DupDeclMsgOld]), + !:InputSpecs = [DupDeclSpec | !.InputSpecs] + ) + else + map.det_insert(Type, InputSpecInfo, map.init, InModuleMap), + map.det_insert(ContainingModuleName, InModuleMap, + InputSpecTable0, InputSpecTable), + module_info_set_input_spec_table(InputSpecTable, !ModuleInfo) + ) + ; + !.InputSpecs = [_ | _] + ), + !:ErrSpecs = !.InputSpecs ++ !.ErrSpecs + ). + +:- pred check_input_spec_types(type_table::in, list(mer_type)::in, + list(format_piece)::in, list(format_piece)::out, + list(format_piece)::in, list(format_piece)::out, + bag(tvar)::in, bag(tvar)::out) is det. + +check_input_spec_types(_TypeTable, [], + !UnknownTypeCtors, !NonDuTypeCtors, !TVarBag). +check_input_spec_types(TypeTable, [Type | Types], + !UnknownTypeCtors, !NonDuTypeCtors, !TVarBag) :- + check_input_spec_type(TypeTable, Type, + !UnknownTypeCtors, !NonDuTypeCtors, !TVarBag), + check_input_spec_types(TypeTable, Types, + !UnknownTypeCtors, !NonDuTypeCtors, !TVarBag). + +:- pred check_input_spec_type(type_table::in, mer_type::in, + list(format_piece)::in, list(format_piece)::out, + list(format_piece)::in, list(format_piece)::out, + bag(tvar)::in, bag(tvar)::out) is det. + +check_input_spec_type(TypeTable, Type, + !UnknownTypeCtors, !NonDuTypeCtors, !TVarBag) :- + ( + Type = type_variable(TVar, _), + bag.insert(TVar, !TVarBag) + ; + Type = builtin_type(_) + ; + Type = defined_type(SymName, ArgTypes, _Kind), + list.length(ArgTypes, Arity), + TypeCtor = type_ctor(SymName, Arity), + ( if search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn) then + get_type_defn_body(TypeDefn, TypeBody), + ( + TypeBody = hlds_du_type(_) + ; + ( TypeBody = hlds_eqv_type(_) + ; TypeBody = hlds_foreign_type(_) + ; TypeBody = hlds_solver_type(_) + ; TypeBody = hlds_abstract_type(_) + ), + !:NonDuTypeCtors = + [unqual_type_ctor(TypeCtor) | !.NonDuTypeCtors] + ) + else + !:UnknownTypeCtors = + [unqual_type_ctor(TypeCtor) | !.UnknownTypeCtors] + ), + check_input_spec_types(TypeTable, ArgTypes, + !UnknownTypeCtors, !NonDuTypeCtors, !TVarBag) + ; + Type = tuple_type(ArgTypes, _Kind), + check_input_spec_types(TypeTable, ArgTypes, + !UnknownTypeCtors, !NonDuTypeCtors, !TVarBag) + ; + Type = higher_order_type(_PorF, ArgTypes, _HOInstInfo, _Purity), + check_input_spec_types(TypeTable, ArgTypes, + !UnknownTypeCtors, !NonDuTypeCtors, !TVarBag) + ; + Type = apply_n_type(TVar, ArgTypes, _Kind), + bag.insert(TVar, !TVarBag), + check_input_spec_types(TypeTable, ArgTypes, + !UnknownTypeCtors, !NonDuTypeCtors, !TVarBag) + ; + Type = kinded_type(SubType, _Kind), + check_input_spec_type(TypeTable, SubType, + !UnknownTypeCtors, !NonDuTypeCtors, !TVarBag) + ). + +:- pred check_input_spec_inst_ctor(user_inst_table::in, inst_ctor::in, + list(format_piece)::in, list(format_piece)::out) is det. + +check_input_spec_inst_ctor(UserInstTable, InstCtor, !UnknownInstCtors) :- + % XXX Any problems with _InstDefn (for example, it may not be applicable + % to the type of the selected argument) should be reported by the mode + % analysis pass. + ( if map.search(UserInstTable, InstCtor, _InstDefn) then + true + else + !:UnknownInstCtors = + [unqual_inst_ctor(InstCtor) | !.UnknownInstCtors] + ). + +%---------------------% + :- pred add_pragma_oisu(decl_pragma_oisu_info::in, item_mercury_status::in, module_info::in, module_info::out, list(err_spec)::in, list(err_spec)::out) is det. diff --git a/compiler/check_import_accessibility.m b/compiler/check_import_accessibility.m index 7412118cf..2e21216f5 100644 --- a/compiler/check_import_accessibility.m +++ b/compiler/check_import_accessibility.m @@ -461,8 +461,8 @@ record_includes_imports_uses_in_parse_tree_int3(Ancestors, record_includes_imports_uses_in_parse_tree_plain_opt(Ancestors, ParseTreePlainOpt, !AncestorImportUseMap) :- - ParseTreePlainOpt = parse_tree_plain_opt(ModuleName, _, UseMap, - _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _), + ParseTreePlainOpt = parse_tree_plain_opt(ModuleName, _, UseMap, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _), ( if set.contains(Ancestors, ModuleName) then Avails = use_map_to_item_avails(UseMap), record_avails_acc(Avails, !AncestorImportUseMap) diff --git a/compiler/convert_parse_tree.m b/compiler/convert_parse_tree.m index eb0f03c6a..5be10e230 100644 --- a/compiler/convert_parse_tree.m +++ b/compiler/convert_parse_tree.m @@ -1038,7 +1038,8 @@ check_convert_parse_tree_opt_to_plain_opt(ParseTreeOpt, ParseTreePlainOpt, [], InstDefns0, [], ModeDefns0, [], TypeClasses0, [], Instances0, [], PredDecls0, [], RevModeDecls, [], RevClauses0, [], RevForeignProcs, [], Promises0, [], DeclMarkers0, [], ImplMarkers0, - [], TypeSpecs0, [], UnusedArgs0, [], TermInfos0, [], Term2Infos0, + [], TypeSpecs0, [], InputSpecs0, + [], UnusedArgs0, [], TermInfos0, [], Term2Infos0, [], Exceptions0, [], Trailings0, [], MMTablings0, [], Sharings0, [], Reuses0, !Specs), list.sort(TypeDefns0, TypeDefns), @@ -1055,6 +1056,7 @@ check_convert_parse_tree_opt_to_plain_opt(ParseTreeOpt, ParseTreePlainOpt, list.sort(DeclMarkers0, DeclMarkers), list.sort(ImplMarkers0, ImplMarkers), list.sort(TypeSpecs0, TypeSpecs), + list.sort(InputSpecs0, InputSpecs), list.sort(UnusedArgs0, UnusedArgs), list.sort(TermInfos0, TermInfos), list.sort(Term2Infos0, Term2Infos), @@ -1069,7 +1071,8 @@ check_convert_parse_tree_opt_to_plain_opt(ParseTreeOpt, ParseTreePlainOpt, UseMap, FIMSpecs, TypeDefns, ForeignEnums, InstDefns, ModeDefns, TypeClasses, Instances, PredDecls, ModeDecls, Clauses, ForeignProcs, Promises, - DeclMarkers, ImplMarkers, TypeSpecs, UnusedArgs, TermInfos, Term2Infos, + DeclMarkers, ImplMarkers, TypeSpecs, InputSpecs, + UnusedArgs, TermInfos, Term2Infos, Exceptions, Trailings, MMTablings, Sharings, Reuses). :- pred classify_plain_opt_items(list(item)::in, @@ -1088,6 +1091,8 @@ check_convert_parse_tree_opt_to_plain_opt(ParseTreeOpt, ParseTreePlainOpt, list(item_impl_marker_info_opt)::in, list(item_impl_marker_info_opt)::out, list(decl_pragma_type_spec_info)::in, list(decl_pragma_type_spec_info)::out, + list(decl_pragma_input_spec_info)::in, + list(decl_pragma_input_spec_info)::out, list(gen_pragma_unused_args_info)::in, list(gen_pragma_unused_args_info)::out, list(decl_pragma_termination_info)::in, @@ -1108,13 +1113,13 @@ check_convert_parse_tree_opt_to_plain_opt(ParseTreeOpt, ParseTreePlainOpt, classify_plain_opt_items([], !TypeDefns, !ForeignEnums, !InstDefns, !ModeDefns, !TypeClasses, !Instances, !PredDecls, !RevModeDecls, !RevClauses, !RevForeignProcs, !Promises, - !DeclMarkers, !ImplMarkers, !TypeSpecs, + !DeclMarkers, !ImplMarkers, !TypeSpecs, !InputSpecs, !UnusedArgs, !TermInfos, !Term2Infos, !Exceptions, !Trailings, !MMTablings, !Sharings, !Reuses, !Specs). classify_plain_opt_items([Item | Items], !TypeDefns, !ForeignEnums, !InstDefns, !ModeDefns, !TypeClasses, !Instances, !PredDecls, !RevModeDecls, !RevClauses, !RevForeignProcs, !Promises, - !DeclMarkers, !ImplMarkers, !TypeSpecs, + !DeclMarkers, !ImplMarkers, !TypeSpecs, !InputSpecs, !UnusedArgs, !TermInfos, !Term2Infos, !Exceptions, !Trailings, !MMTablings, !Sharings, !Reuses, !Specs) :- ( @@ -1155,6 +1160,9 @@ classify_plain_opt_items([Item | Items], !TypeDefns, !ForeignEnums, ( DeclPragma = decl_pragma_type_spec(TypeSpec), !:TypeSpecs = [TypeSpec | !.TypeSpecs] + ; + DeclPragma = decl_pragma_input_spec(InputSpec), + !:InputSpecs = [InputSpec | !.InputSpecs] ; DeclPragma = decl_pragma_termination(Term), !:TermInfos = [Term | !.TermInfos] @@ -1286,7 +1294,7 @@ classify_plain_opt_items([Item | Items], !TypeDefns, !ForeignEnums, classify_plain_opt_items(Items, !TypeDefns, !ForeignEnums, !InstDefns, !ModeDefns, !TypeClasses, !Instances, !PredDecls, !RevModeDecls, !RevClauses, !RevForeignProcs, !Promises, - !DeclMarkers, !ImplMarkers, !TypeSpecs, + !DeclMarkers, !ImplMarkers, !TypeSpecs, !InputSpecs, !UnusedArgs, !TermInfos, !Term2Infos, !Exceptions, !Trailings, !MMTablings, !Sharings, !Reuses, !Specs). @@ -1413,6 +1421,7 @@ classify_trans_opt_items([Item | Items], !TermInfos, !Term2Infos, ; DeclPragma = decl_pragma_format_call(_) ; DeclPragma = decl_pragma_type_spec(_) ; DeclPragma = decl_pragma_type_spec_constr(_) + ; DeclPragma = decl_pragma_input_spec(_) ; DeclPragma = decl_pragma_oisu(_) ), Pieces = [words("A .trans_opt file may not contain")] ++ diff --git a/compiler/equiv_type_parse_tree.m b/compiler/equiv_type_parse_tree.m index 88ab45893..072f28c3a 100644 --- a/compiler/equiv_type_parse_tree.m +++ b/compiler/equiv_type_parse_tree.m @@ -550,7 +550,7 @@ replace_in_parse_tree_plain_opt(Params, InstDefns0, ModeDefns0, TypeClasses0, Instances0, PredDecls0, ModeDecls0, Clauses, ForeignProcs, Promises, DeclMarkers, ImplMarkers, - TypeSpecs0, UnusedArgs, TermInfos, Term2Infos, + TypeSpecs0, InputSpecs0, UnusedArgs, TermInfos, Term2Infos, Exceptions, Trailings, MMTablings, Sharings, Reuses), InstDefns = InstDefns0, % XXX See the comment at module top. @@ -573,6 +573,9 @@ replace_in_parse_tree_plain_opt(Params, replace_in_list(Params, MaybeRecord, replace_in_decl_pragma_type_spec, TypeSpecs0, TypeSpecs, !RecompInfo, !UsedModules, !Specs), + replace_in_list(Params, MaybeRecord, + replace_in_decl_pragma_input_spec, InputSpecs0, InputSpecs, + !RecompInfo, !UsedModules, !Specs), ParseTreePlainOpt = parse_tree_plain_opt( OptModuleName, OptModuleNameContext, @@ -580,7 +583,7 @@ replace_in_parse_tree_plain_opt(Params, InstDefns, ModeDefns, TypeClasses, Instances, PredDecls, ModeDecls, Clauses, ForeignProcs, Promises, DeclMarkers, ImplMarkers, - TypeSpecs, UnusedArgs, TermInfos, Term2Infos, + TypeSpecs, InputSpecs, UnusedArgs, TermInfos, Term2Infos, Exceptions, Trailings, MMTablings, Sharings, Reuses). :- pred replace_in_parse_tree_trans_opt(equiv_params::in, @@ -1334,6 +1337,11 @@ replace_in_decl_pragma_info(Params, MaybeRecord, DeclPragma0, DeclPragma, replace_in_decl_pragma_type_spec(Params, MaybeRecord, TypeSpec0, TypeSpec, !RecompInfo, !UsedModules, Specs), DeclPragma = decl_pragma_type_spec(TypeSpec) + ; + DeclPragma0 = decl_pragma_input_spec(InputSpec0), + replace_in_decl_pragma_input_spec(Params, MaybeRecord, + InputSpec0, InputSpec, !RecompInfo, !UsedModules, Specs), + DeclPragma = decl_pragma_input_spec(InputSpec) ; ( DeclPragma0 = decl_pragma_obsolete_pred(_) ; DeclPragma0 = decl_pragma_obsolete_proc(_) @@ -1348,6 +1356,8 @@ replace_in_decl_pragma_info(Params, MaybeRecord, DeclPragma0, DeclPragma, Specs = [] ). +%---------------------% + :- pred replace_in_decl_pragma_type_spec_constr(equiv_params::in, maybe_record_sym_name_use::in, decl_pragma_type_spec_constr_info::in, @@ -1397,6 +1407,8 @@ replace_in_decl_pragma_type_spec_constr(Params, MaybeRecord, OoMConstraints, ApplyToSupers, OoMSubsts, TVarSet, GatheredItemIds, Context, SeqNum). +%---------------------% + :- pred replace_in_decl_pragma_type_spec(equiv_params::in, maybe_record_sym_name_use::in, decl_pragma_type_spec_info::in, decl_pragma_type_spec_info::out, @@ -1443,6 +1455,44 @@ replace_in_decl_pragma_type_spec(Params, MaybeRecord, %---------------------% +:- pred replace_in_decl_pragma_input_spec(equiv_params::in, + maybe_record_sym_name_use::in, + decl_pragma_input_spec_info::in, decl_pragma_input_spec_info::out, + maybe(recompilation_info)::in, maybe(recompilation_info)::out, + used_eqv_modules::in, used_eqv_modules::out, list(err_spec)::out) is det. + +replace_in_decl_pragma_input_spec(Params, MaybeRecord, + InputSpecInfo0, InputSpecInfo, + RecompInfo, RecompInfo, !UsedModules, []) :- + % RecompInfo is unused, but its presence is required + % by the interface of replace_in_list. + % + % The XXX at the start of replace_in_decl_pragma_type_spec_constr + % applies here as well. + InputSpecInfo0 = decl_pragma_input_spec_info(ContainingModuleName, + Type0, ReplaceOrAdd, OoMInstCtors, OoMInsts0, + GatheredItemIds0, TVarSet0, Context, SeqNum), + ModuleName = Params ^ ep_module_name, + ItemRecompDeps0 = item_recomp_deps(ModuleName, GatheredItemIds0), + TypeEqvMap = Params ^ ep_type_eqv_map, + replace_in_type_maybe_record_use_ignore_circ(TypeEqvMap, MaybeRecord, + Type0, Type, _, TVarSet0, TVarSet, + ItemRecompDeps0, ItemRecompDeps1, !UsedModules), + InstEqvMap = Params ^ ep_inst_eqv_map, + one_or_more.map_foldl2(replace_in_inst(InstEqvMap, MaybeRecord), + OoMInsts0, OoMInsts, ItemRecompDeps1, ItemRecompDeps, !UsedModules), + ( + ItemRecompDeps = no_item_recomp_deps, + GatheredItemIds = GatheredItemIds0 + ; + ItemRecompDeps = item_recomp_deps(_, GatheredItemIds) + ), + InputSpecInfo = decl_pragma_input_spec_info(ContainingModuleName, + Type, ReplaceOrAdd, OoMInstCtors, OoMInsts, + GatheredItemIds, TVarSet, Context, SeqNum). + +%---------------------% + :- pred replace_in_subst(type_eqv_map::in, maybe_record_sym_name_use::in, type_subst::in, type_subst::out, tvarset::in, tvarset::out, item_recomp_deps::in, item_recomp_deps::out, @@ -1462,24 +1512,22 @@ replace_in_subst(TypeEqvMap, MaybeRecord, Subst0, Subst, tvarset::in, tvarset::out, item_recomp_deps::in, item_recomp_deps::out, used_eqv_modules::in, used_eqv_modules::out) is det. -replace_in_tvar_substs(TypeEqvMap, MaybeRecord, Subst0, Subst, - TailVarsTypes0, TailVarsTypes, - !TVarSet, !ItemRecompDeps, !UsedModules) :- - Subst0 = tvar_subst(HeadVar, HeadType0), +replace_in_tvar_substs(TypeEqvMap, MaybeRecord, HeadSubst0, HeadSubst, + TailSubsts0, TailSubsts, !TVarSet, !ItemRecompDeps, !UsedModules) :- + HeadSubst0 = tvar_subst(HeadVar, HeadType0), replace_in_type_maybe_record_use_ignore_circ(TypeEqvMap, MaybeRecord, HeadType0, HeadType, _, !TVarSet, !ItemRecompDeps, !UsedModules), + HeadSubst = tvar_subst(HeadVar, HeadType), ( - TailVarsTypes0 = [], - TailVarsTypes = [] + TailSubsts0 = [], + TailSubsts = [] ; - TailVarsTypes0 = [HeadTailVarType0 | TailTailVarsTypes0], + TailSubsts0 = [HeadTailSubst0 | TailTailSubsts0], replace_in_tvar_substs(TypeEqvMap, MaybeRecord, - HeadTailVarType0, HeadTailVarType, - TailTailVarsTypes0, TailTailVarsTypes, + HeadTailSubst0, HeadTailSubst, TailTailSubsts0, TailTailSubsts, !TVarSet, !ItemRecompDeps, !UsedModules), - TailVarsTypes = [HeadTailVarType | TailTailVarsTypes] - ), - Subst = tvar_subst(HeadVar, HeadType). + TailSubsts = [HeadTailSubst | TailTailSubsts] + ). %---------------------% diff --git a/compiler/error_spec.m b/compiler/error_spec.m index cdc0a76f1..de0645d80 100644 --- a/compiler/error_spec.m +++ b/compiler/error_spec.m @@ -261,6 +261,7 @@ ; phase_expand_types ; phase_type_check ; phase_inst_check + ; phase_input_spec ; phase_polymorphism ; phase_mode_check(mode_report_control) ; phase_purity_check diff --git a/compiler/error_util.m b/compiler/error_util.m index 4de206986..89a93ecfe 100644 --- a/compiler/error_util.m +++ b/compiler/error_util.m @@ -571,13 +571,13 @@ get_maybe_mode_report_control(phase_module_name) = no. get_maybe_mode_report_control(phase_t2pt) = no. get_maybe_mode_report_control(phase_tim_check) = no. get_maybe_mode_report_control(phase_tim_check_invalid_type) = no. -get_maybe_mode_report_control(phase_tim_check_invalid_inst_mode) - = no. +get_maybe_mode_report_control(phase_tim_check_invalid_inst_mode) = no. get_maybe_mode_report_control(phase_type_repn) = no. get_maybe_mode_report_control(phase_pt2h) = no. get_maybe_mode_report_control(phase_expand_types) = no. get_maybe_mode_report_control(phase_type_check) = no. get_maybe_mode_report_control(phase_inst_check) = no. +get_maybe_mode_report_control(phase_input_spec) = no. get_maybe_mode_report_control(phase_polymorphism) = no. get_maybe_mode_report_control(phase_mode_check(Control)) = yes(Control). get_maybe_mode_report_control(phase_purity_check) = no. diff --git a/compiler/get_dependencies.m b/compiler/get_dependencies.m index 37518ecbb..cc7da52ac 100644 --- a/compiler/get_dependencies.m +++ b/compiler/get_dependencies.m @@ -207,7 +207,7 @@ get_explicit_and_implicit_avail_needs_in_parse_tree_plain_opt( UseMap, _FIMSpecs, _TypeDefns, _ForeignEnums, _InstDefns, _ModeDefns, _TypeClasses, _Instances, _PredDecls, _ModeDecls, _Clauses, _ForeignProcs, _Promises, - _DeclMarkers, _ImplMarkers, _TypeSpecs, + _DeclMarkers, _ImplMarkers, _TypeSpecs, _InputSpecs, _UnusedArgs, _TermInfos, _Term2Infos, _Exceptions, _Trailings, _MMTablings, _Sharings, _Reuses), map.keys_as_set(UseMap, ExplicitModules), @@ -516,7 +516,7 @@ acc_implicit_avail_needs_in_parse_tree_plain_opt(ParseTreePlainOpt, _UsedModuleNames, _FIMSpecs, TypeDefns, _ForeignEnums, _InstDefns, _ModeDefns, _TypeClasses, Instances, _PredDecls, _ModeDecls, Clauses, _ForeignProcs, _Promises, - _DeclMarkers, _ImplMarkers, _TypeSpecs, + _DeclMarkers, _ImplMarkers, _TypeSpecs, _InputSpecs, _UnusedArgs, _TermInfos, _Term2Infos, _Exceptions, _Trailings, _MMTablings, _Sharings, _Reuses), list.foldl(acc_implicit_avail_needs_in_type_defn, diff --git a/compiler/grab_modules.m b/compiler/grab_modules.m index c592e5574..a391b9868 100644 --- a/compiler/grab_modules.m +++ b/compiler/grab_modules.m @@ -1480,7 +1480,7 @@ keep_only_unused_and_reuse_pragmas_in_parse_tree_plain_opt( _UsedModuleNames, _FIMSpecs, _TypeDefns, _ForeignEnums, _InstDefns, _ModeDefns, _TypeClasses, _Instances, _PredDecls, _ModeDecls, _Clauses, _ForeignProcs, _Promises, - _DeclMarkers, _ImplMarkers, _TypeSpecs, + _DeclMarkers, _ImplMarkers, _TypeSpecs, _InputSpecs, UnusedArgs0, _TermInfos, _Term2Infos, _Exceptions, _Trailings, _MMTablings, _Sharings, Reuses0), ( @@ -1499,7 +1499,7 @@ keep_only_unused_and_reuse_pragmas_in_parse_tree_plain_opt( ), ParseTreePlainOpt = parse_tree_plain_opt(ModuleName, ModuleNameContext, map.init, set.init, [], [], [], [], [], [], [], [], [], [], [], - [], [], [], UnusedArgs, [], [], [], [], [], [], Reuses). + [], [], [], [], UnusedArgs, [], [], [], [], [], [], Reuses). :- pred read_plain_opt_files(io.text_output_stream::in, globals::in, bool::in, bool::in, list(module_name)::in, set(module_name)::in, diff --git a/compiler/hlds.m b/compiler/hlds.m index b2cff6a26..3a3b75f36 100644 --- a/compiler/hlds.m +++ b/compiler/hlds.m @@ -75,6 +75,9 @@ % Module for expanding out implementation defined literals. :- include_module implementation_defined_literals. +% Module for specializing procedure modes for specific input values. +:- include_module input_specialization. + % Miscellaneous utilities. :- include_module arg_info. :- include_module code_model. diff --git a/compiler/hlds_markers.m b/compiler/hlds_markers.m index d50c108f2..d6bdbac19 100644 --- a/compiler/hlds_markers.m +++ b/compiler/hlds_markers.m @@ -213,6 +213,13 @@ % the typecheck pass, and it is used (as of this writing) % only by the post-typecheck pass. + ; marker_was_input_specialized + % This predicate had one or more input_spec pragmas applied + % to it. Input specialization splits some procedures into + % two or more procedures, which will have the same item + % sequence numbers as the original procedure. This marker + % tells style_checks.m to allow this. + ; marker_fact_table_semantic_errors. % This predicate has a fact_table pragma for it, so it is % *expected* not to have any clauses in the program itself, but @@ -516,6 +523,7 @@ marker_name(marker_has_require_scope, "has_require_scope"). marker_name(marker_has_incomplete_switch, "has_incomplete_switch"). marker_name(marker_has_format_call, "has_format_call"). marker_name(marker_has_rhs_lambda, "has_rhs_lambda"). +marker_name(marker_was_input_specialized, "was_input_specialized"). marker_name(marker_fact_table_semantic_errors, "fact_table_semantic_errors"). %---------------------------------------------------------------------------% diff --git a/compiler/hlds_module.m b/compiler/hlds_module.m index bc86dceb5..1493fa8b2 100644 --- a/compiler/hlds_module.m +++ b/compiler/hlds_module.m @@ -187,6 +187,15 @@ pragma_map :: type_spec_pragma_map ). +:- type input_spec_table == map(module_name, input_spec_in_module_map). +:- type input_spec_in_module_map == map(mer_type, input_spec_info). +:- type input_spec_info + ---> input_spec_info( + replace_or_add_in_mode, + one_or_more(mer_inst), + prog_context + ). + % Once filled in by simplify_proc.m (for all non-lambda procedures) % and by lambda.m (for procedures created to implement lambda expressions), % this map should have an entry for every procedure that is of interest to @@ -358,6 +367,8 @@ instance_table::out) is det. :- pred module_info_get_type_spec_tables(module_info::in, type_spec_tables::out) is det. +:- pred module_info_get_input_spec_table(module_info::in, + input_spec_table::out) is det. :- pred module_info_get_const_struct_db(module_info::in, const_struct_db::out) is det. :- pred module_info_get_c_j_cs_fims(module_info::in, @@ -470,6 +481,8 @@ module_info::in, module_info::out) is det. :- pred module_info_set_type_spec_tables(type_spec_tables::in, module_info::in, module_info::out) is det. +:- pred module_info_set_input_spec_table(input_spec_table::in, + module_info::in, module_info::out) is det. :- pred module_info_set_const_struct_db(const_struct_db::in, module_info::in, module_info::out) is det. :- pred module_info_set_c_j_cs_fims(c_j_cs_fims::in, @@ -849,6 +862,9 @@ % Data used for user-guided type specialization. msi_type_spec_tables :: type_spec_tables, + % Data used for input-value specialization. + msi_input_spec_table :: input_spec_table, + % The database of constant structures the code generator % will generate independently, outside all the procedures % of the program. @@ -1176,9 +1192,10 @@ module_info_init(Globals, ModuleName, ModuleNameContext, DumpBaseFileName, set.init(TypeSpecForcePreds), map.init(SpecMap), map.init(PragmaMap), - TypeSpecInfo = type_spec_tables(TypeSpecPreds, TypeSpecForcePreds, + TypeSpecTables = type_spec_tables(TypeSpecPreds, TypeSpecForcePreds, SpecMap, PragmaMap), + map.init(InputSpecTable), const_struct_db_init(Globals, ConstStructDb), ForeignImportModules = init_foreign_import_modules, PragmaExportedProcs = cord.init, @@ -1187,7 +1204,8 @@ module_info_init(Globals, ModuleName, ModuleNameContext, DumpBaseFileName, SpecialPredMaps, ClassTable, InstanceTable, - TypeSpecInfo, + TypeSpecTables, + InputSpecTable, ConstStructDb, ForeignImportModules, PragmaExportedProcs), @@ -1412,6 +1430,8 @@ module_info_get_instance_table(MI, X) :- X = MI ^ mi_sub_info ^ msi_instance_table. module_info_get_type_spec_tables(MI, X) :- X = MI ^ mi_sub_info ^ msi_type_spec_tables. +module_info_get_input_spec_table(MI, X) :- + X = MI ^ mi_sub_info ^ msi_input_spec_table. module_info_get_const_struct_db(MI, X) :- X = MI ^ mi_sub_info ^ msi_const_struct_db. module_info_get_c_j_cs_fims(MI, X) :- @@ -1537,6 +1557,8 @@ module_info_set_instance_table(X, !MI) :- !MI ^ mi_sub_info ^ msi_instance_table := X. module_info_set_type_spec_tables(X, !MI) :- !MI ^ mi_sub_info ^ msi_type_spec_tables := X. +module_info_set_input_spec_table(X, !MI) :- + !MI ^ mi_sub_info ^ msi_input_spec_table := X. module_info_set_const_struct_db(X, !MI) :- ( if private_builtin.pointer_equal(X, diff --git a/compiler/input_specialization.m b/compiler/input_specialization.m new file mode 100644 index 000000000..768d4601e --- /dev/null +++ b/compiler/input_specialization.m @@ -0,0 +1,248 @@ +%---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% +% Copyright (C) 2026 The Mercury team. +% This file may only be copied under the terms of the GNU General +% Public License - see the file COPYING in the Mercury distribution. +%---------------------------------------------------------------------------% +% +% File: input_specialization.m. +% Main author: zs. +% +% This file contains code for improving the names of head variables, +% replacing HeadVar__n with user-given names whereever the clauses +% agree on the names. + +:- module hlds.input_specialization. + +:- interface. + +:- import_module hlds.hlds_module. + + % If all clauses give a given head variables the same name, use this name + % instead of the introduced `HeadVar__n' names for the head variables + % in the pred_info. This gives better error messages, more meaningful + % variable names in the debugger and slightly faster compilation. + % +:- pred input_specialize_in_module(module_info::in, module_info::out) is det. + +%---------------------------------------------------------------------------% + +:- implementation. + +:- import_module hlds.hlds_markers. +:- import_module hlds.hlds_pred. +:- import_module hlds.mode_util. +:- import_module libs. +:- import_module libs.maybe_util. +:- import_module mdbcomp. +:- import_module mdbcomp.builtin_modules. +:- import_module mdbcomp.sym_name. +:- import_module parse_tree. +:- import_module parse_tree.prog_data. +:- import_module parse_tree.prog_item_pragma. + +:- import_module int. +:- import_module list. +:- import_module map. +:- import_module one_or_more. +:- import_module require. + +%---------------------------------------------------------------------------% + +input_specialize_in_module(!ModuleInfo) :- + module_info_get_input_spec_table(!.ModuleInfo, InputSpecTable), + module_info_get_valid_pred_ids(!.ModuleInfo, PredIds), + list.foldl(maybe_input_specialize_in_pred(InputSpecTable), PredIds, + !ModuleInfo). + +:- pred maybe_input_specialize_in_pred(input_spec_table::in, pred_id::in, + module_info::in, module_info::out) is det. + +maybe_input_specialize_in_pred(InputSpecTable, PredId, !ModuleInfo) :- + module_info_pred_info(!.ModuleInfo, PredId, PredInfo0), + pred_info_get_module_name(PredInfo0, ModuleName), + ( if map.search(InputSpecTable, ModuleName, InModuleMap) then + input_specialize_in_pred_if_possible(!.ModuleInfo, InModuleMap, + PredInfo0, PredInfo), + module_info_set_pred_info(PredId, PredInfo, !ModuleInfo) + else + true + ). + +:- pred input_specialize_in_pred_if_possible(module_info::in, + input_spec_in_module_map::in, pred_info::in, pred_info::out) is det. + +input_specialize_in_pred_if_possible(ModuleInfo, InModuleMap, !PredInfo) :- + pred_info_get_arg_types(!.PredInfo, ArgTypes), + find_args_to_specialize(InModuleMap, 1, ArgTypes, ArgsToSpec), + ( + ArgsToSpec = [] + % Pieces = [words("Error:")], + % Spec = spec($pred, severity_error, phase_input_spec, Pieces), + % !:Specs = [Spec | !.Specs] + ; + ArgsToSpec = [HeadArgToSpec | TailArgsToSpec], + input_specialize_in_pred(ModuleInfo, HeadArgToSpec, TailArgsToSpec, + !PredInfo) + ). + +:- type arg_to_specialize + ---> arg_to_specialize(int, input_spec_info). + % The argument number, and how to specialize it. + +:- pred find_args_to_specialize(input_spec_in_module_map::in, + int::in, list(mer_type)::in, list(arg_to_specialize)::out) is det. + +find_args_to_specialize(_, _, [], []). +find_args_to_specialize(InModuleMap, ArgNum, [ArgType | ArgTypes], + ArgsToSpec) :- + find_args_to_specialize(InModuleMap, ArgNum + 1, ArgTypes, + ArgsToSpecTail), + % This search works only if the types in input_spec pragmas are ground. + % At the moment, add_pragma_decl.m does require them to be ground. + ( if map.search(InModuleMap, ArgType, InputSpecInfo) then + ArgToSpec = arg_to_specialize(ArgNum, InputSpecInfo), + ArgsToSpec = [ArgToSpec | ArgsToSpecTail] + else + ArgsToSpec = ArgsToSpecTail + ). + +%---------------------------------------------------------------------------% + +:- pred input_specialize_in_pred(module_info::in, + arg_to_specialize::in, list(arg_to_specialize)::in, + pred_info::in, pred_info::out) is det. + +input_specialize_in_pred(ModuleInfo, HeadArgToSpec, TailArgsToSpec, + !PredInfo) :- + HeadArgToSpec = arg_to_specialize(ArgNum, InputSpecInfo), + pred_info_get_proc_table(!.PredInfo, ProcTable0), + map.values(ProcTable0, ProcInfos0), + input_specialize_proc_table_in_given_arg(ModuleInfo, ArgNum, InputSpecInfo, + ProcInfos0, ProcInfos, _Changed), + rebuild_proc_table_loop(0, ProcInfos, map.init, ProcTable), + pred_info_set_proc_table(ProcTable, !PredInfo), + pred_info_get_markers(!.PredInfo, Markers0), + add_marker(marker_was_input_specialized, Markers0, Markers), + pred_info_set_markers(Markers, !PredInfo), + ( + TailArgsToSpec = [] + ; + TailArgsToSpec = [HeadTailArgToSpec | TailTailArgsToSpec], + input_specialize_in_pred(ModuleInfo, + HeadTailArgToSpec, TailTailArgsToSpec, !PredInfo) + ). + +%---------------------------------------------------------------------------% + +:- pred rebuild_proc_table_loop(int::in, list(proc_info)::in, + proc_table::in, proc_table::out) is det. + +rebuild_proc_table_loop(_, [], !ProcTable). +rebuild_proc_table_loop(ProcNum, [ProcInfo | ProcInfos], !ProcTable) :- + proc_id_to_int(ProcId, ProcNum), + map.det_insert(ProcId, ProcInfo, !ProcTable), + rebuild_proc_table_loop(ProcNum + 1, ProcInfos, !ProcTable). + +%---------------------------------------------------------------------------% + +:- pred input_specialize_proc_table_in_given_arg(module_info::in, + int::in, input_spec_info::in, + list(proc_info)::in, list(proc_info)::out, maybe_changed::out) is det. + +input_specialize_proc_table_in_given_arg(_, _, _, [], [], unchanged). +input_specialize_proc_table_in_given_arg(ModuleInfo, ArgNum, InputSpecInfo, + [HeadProcInfo0 | TailProcInfos0], ProcInfos, Changed) :- + proc_info_get_argmodes(HeadProcInfo0, ArgModes), + list.det_index1(ArgModes, ArgNum, SelectedArgMode), + ( if + mode_get_insts_semidet(ModuleInfo, SelectedArgMode, + InitInst, FinalInst), + InitInst = FinalInst, + ( + InitInst = ground(shared, none_or_default_func) + ; + InitInst = defined_inst(user_inst(SymName, [])), + SymName = qualified(mercury_public_builtin_module, Name), + ( Name = "in" ; Name = "input" ) + ) + then + input_specialize_proc_table_in_given_arg(ModuleInfo, ArgNum, + InputSpecInfo, TailProcInfos0, TailProcInfos, _Changed), + InputSpecInfo = input_spec_info(ReplaceOrAdd, OoMInsts, _Context), + SpecInsts = one_or_more_to_list(OoMInsts), + create_input_specialized_proc_infos(ArgNum, ReplaceOrAdd, SpecInsts, + HeadProcInfo0, SpecProcInfos), + ProcInfos = SpecProcInfos ++ TailProcInfos, + Changed = changed + else + input_specialize_proc_table_in_given_arg(ModuleInfo, ArgNum, + InputSpecInfo, TailProcInfos0, TailProcInfos, Changed), + ProcInfos = [HeadProcInfo0 | TailProcInfos] + ). + +:- pred create_input_specialized_proc_infos(int::in, + replace_or_add_in_mode::in, list(mer_inst)::in, + proc_info::in, list(proc_info)::out) is det. + +create_input_specialized_proc_infos(ArgNum, ReplaceOrAdd, SpecInsts, + OrigProcInfo, SpecProcInfos) :- + ( + SpecInsts = [], + ( + ReplaceOrAdd = replace_in_mode, + SpecProcInfos = [] + ; + ReplaceOrAdd = add_to_in_mode, + SpecProcInfos = [OrigProcInfo] + ) + ; + SpecInsts = [HeadSpecInst | TailSpecInsts], + + proc_info_get_argmodes(OrigProcInfo, OrigModes), + HeadSpecArgMode = from_to_mode(HeadSpecInst, HeadSpecInst), + det_replace_nth_element1(ArgNum, HeadSpecArgMode, + OrigModes, HeadSpecModes), + proc_info_set_argmodes(HeadSpecModes, + OrigProcInfo, HeadSpecProcInfo), + create_input_specialized_proc_infos(ArgNum, + ReplaceOrAdd, TailSpecInsts, OrigProcInfo, TailSpecProcInfos), + SpecProcInfos = [HeadSpecProcInfo | TailSpecProcInfos] + ). + +%---------------------------------------------------------------------------% + +% XXX I (zs) think these should be in library/list.m. + +:- pred det_replace_nth_element1(int::in, T::in, list(T)::in, list(T)::out) + is det. + +det_replace_nth_element1(N, NewItem, Items0, Items) :- + ( if replace_nth_element1(N, NewItem, Items0, ItemsPrime) then + Items = ItemsPrime + else + unexpected($pred, "index out of range") + ). + +:- pred replace_nth_element1(int::in, T::in, list(T)::in, list(T)::out) + is semidet. + +replace_nth_element1(N, NewItem, Items0, Items) :- + replace_nth_element0(N - 1, NewItem, Items0, Items). + +:- pred replace_nth_element0(int::in, T::in, list(T)::in, list(T)::out) + is semidet. + +replace_nth_element0(N, NewItem, [Item0 | Items0], [Item | Items]) :- + ( if N = 0 then + Item = NewItem, + Items = Items0 + else + Item = Item0, + replace_nth_element0(N - 1, NewItem, Items0, Items) + ). + +%---------------------------------------------------------------------------% +:- end_module hlds.input_specialization. +%---------------------------------------------------------------------------% diff --git a/compiler/intermod.m b/compiler/intermod.m index ed92cd45f..91cded7f2 100644 --- a/compiler/intermod.m +++ b/compiler/intermod.m @@ -212,7 +212,7 @@ format_opt_file_initial(IntermodInfo, ParseTreePlainOpt, !State) :- then ParseTreePlainOpt = parse_tree_plain_opt(ModuleName, dummy_context, map.init, set.init, [], [], [], [], [], [], [], [], [], [], [], [], - [], [], [], [], [], [], [], [], [], []) + [], [], [], [], [], [], [], [], [], [], []) else format_opt_file_initial_body(IntermodInfo, ParseTreePlainOpt, !State) ). @@ -371,13 +371,15 @@ format_opt_file_initial_body(IntermodInfo, ParseTreePlainOpt, !State) :- Promises = [], DeclMarkers = cord.list(DeclMarkersCord), ImplMarkers = cord.list(ImplMarkersCord), + InputSpecs = [], module_info_get_name(ModuleInfo, ModuleName), ParseTreePlainOpt = parse_tree_plain_opt(ModuleName, dummy_context, UseMap, FIMSpecsSet, TypeDefns, ForeignEnums, InstDefns, ModeDefns, TypeClasses, Instances, PredDecls, ModeDecls, Clauses, ForeignProcs, Promises, - DeclMarkers, ImplMarkers, TypeSpecs, [], [], [], [], [], [], [], []). + DeclMarkers, ImplMarkers, TypeSpecs, InputSpecs, + [], [], [], [], [], [], [], []). %---------------------------------------------------------------------------% @@ -866,6 +868,7 @@ intermod_gather_pred_marker_pragmas_loop(PredOrFunc, PredSymName, UserArity, ; Marker = marker_has_incomplete_switch ; Marker = marker_has_format_call ; Marker = marker_has_rhs_lambda + ; Marker = marker_was_input_specialized ; Marker = marker_fact_table_semantic_errors % Since the inferred declarations are output, these don't need diff --git a/compiler/item_util.m b/compiler/item_util.m index a1c4ef179..a86d5bf3a 100644 --- a/compiler/item_util.m +++ b/compiler/item_util.m @@ -430,6 +430,9 @@ decl_pragma_desc_pieces(Pragma) = Pieces :- ; Pragma = decl_pragma_type_spec(_), Pieces = [pragma_decl("type_spec"), words("declaration")] + ; + Pragma = decl_pragma_input_spec(_), + Pieces = [pragma_decl("input_spec"), words("declaration")] ; Pragma = decl_pragma_oisu(_), Pieces = [pragma_decl("oisu"), words("declaration")] diff --git a/compiler/make_hlds_passes.m b/compiler/make_hlds_passes.m index 4b61a981e..e2510196f 100644 --- a/compiler/make_hlds_passes.m +++ b/compiler/make_hlds_passes.m @@ -211,7 +211,8 @@ parse_tree_to_hlds(ProgressStream, AugCompUnit, Globals, DumpBaseFileName, Promises, Typeclasses, IntInstances, ImpInstances, Initialises, Finalises, Mutables, TypeRepnMap, ForeignEnums, ForeignExportEnums, - DeclPragmas, DeclMarkers, DeclTypeSpecConstr, DeclTypeSpec, + DeclPragmas, DeclMarkers, + DeclTypeSpecConstr, DeclTypeSpec, DeclInputSpec, DeclTermination, DeclTermination2, DeclSharing, DeclReuse, ImplPragmas, ImplMarkers, GenUnusedArgs, GenExceptions, GenTrailing, GenMMTabling, @@ -576,6 +577,8 @@ parse_tree_to_hlds(ProgressStream, AugCompUnit, Globals, DumpBaseFileName, !ModuleInfo, !QualInfo, !ErrSpecs, !WarnSpecs, !InfoSpecs), add_decl_pragmas_type_spec(DeclTypeSpec, !ModuleInfo, !QualInfo, !ErrSpecs, !WarnSpecs), + add_decl_pragmas_input_spec(DeclInputSpec, + !ModuleInfo, !ErrSpecs), add_decl_pragmas_termination(DeclTermination, !ModuleInfo, !ErrSpecs), add_decl_pragmas_termination2(DeclTermination2, diff --git a/compiler/make_hlds_separate_items.m b/compiler/make_hlds_separate_items.m index ecb1cb833..43c026ed9 100644 --- a/compiler/make_hlds_separate_items.m +++ b/compiler/make_hlds_separate_items.m @@ -90,6 +90,7 @@ ims_list(item_decl_marker_info)::out, list(decl_pragma_type_spec_constr_info)::out, list(decl_pragma_type_spec_info)::out, + ims_list(decl_pragma_input_spec_info)::out, list(decl_pragma_termination_info)::out, list(decl_pragma_termination2_info)::out, list(decl_pragma_struct_sharing_info)::out, @@ -154,6 +155,7 @@ ia_decl_type_spec_constr :: cord(decl_pragma_type_spec_constr_info), ia_decl_type_spec :: cord(decl_pragma_type_spec_info), + ia_decl_input_spec :: ims_cord(decl_pragma_input_spec_info), ia_decl_term :: cord(decl_pragma_termination_info), ia_decl_term2 :: cord(decl_pragma_termination2_info), ia_decl_str_sharing :: cord(decl_pragma_struct_sharing_info), @@ -178,7 +180,7 @@ separate_items_in_aug_comp_unit(AugCompUnit, InclMap, Avails, FIMs, Initialises, Finalises, Mutables, TypeRepnMap, ForeignEnums, ForeignExportEnums, DeclPragmas, DeclMarkers, - DeclPragmasTypeSpecConstr, DeclPragmasTypeSpec, + DeclPragmasTypeSpecConstr, DeclPragmasTypeSpec, DeclPragmasInputSpec, DeclPragmasTermInfo, DeclPragmasTerm2Info, DeclPragmasSharing, DeclPragmasReuse, ImplPragmas, ImplMarkers, GenPragmasUnusedArgs, GenPragmasExceptions, @@ -202,7 +204,7 @@ 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, @@ -251,6 +253,7 @@ separate_items_in_aug_comp_unit(AugCompUnit, InclMap, Avails, FIMs, DeclPragmasCord, DeclMarkersCord, DeclPragmasTypeSpecConstrCord, DeclPragmasTypeSpecCord, + DeclPragmasInputSpecCord, DeclPragmasTermInfoCord, DeclPragmasTerm2InfoCord, DeclPragmasSharingCord, DeclPragmasReuseCord, ImplPragmasCord, ImplMarkersCord, @@ -281,6 +284,7 @@ separate_items_in_aug_comp_unit(AugCompUnit, InclMap, Avails, FIMs, DeclMarkers = cord.list(DeclMarkersCord), DeclPragmasTypeSpecConstr = cord.list(DeclPragmasTypeSpecConstrCord), DeclPragmasTypeSpec = cord.list(DeclPragmasTypeSpecCord), + DeclPragmasInputSpec = cord.list(DeclPragmasInputSpecCord), DeclPragmasTermInfo = cord.list(DeclPragmasTermInfoCord), DeclPragmasTerm2Info = cord.list(DeclPragmasTerm2InfoCord), DeclPragmasSharing = cord.list(DeclPragmasSharingCord), @@ -451,6 +455,7 @@ acc_parse_tree_module_src(ParseTreeModuleSrc, !Acc) :- AccForeignEnums0, AccForeignExportEnums0, AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, + AccDeclPragmasInputSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -548,6 +553,7 @@ acc_parse_tree_module_src(ParseTreeModuleSrc, !Acc) :- AccForeignEnums, AccForeignExportEnums, AccDeclPragmas, AccDeclMarkers, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, + AccDeclPragmasInputSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas, AccImplMarkers, @@ -598,6 +604,7 @@ acc_parse_tree_int0(ParseTreeInt0, ReadWhy0, !Acc) :- AccForeignEnums0, AccForeignExportEnums0, AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, + AccDeclPragmasInputSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -680,6 +687,7 @@ acc_parse_tree_int0(ParseTreeInt0, ReadWhy0, !Acc) :- AccForeignEnums, AccForeignExportEnums0, AccDeclPragmas, AccDeclMarkers, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, + AccDeclPragmasInputSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -769,6 +777,7 @@ acc_parse_tree_int1(ParseTreeInt1, ReadWhy1, !Acc) :- AccForeignEnums0, AccForeignExportEnums0, AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, + AccDeclPragmasInputSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -836,6 +845,7 @@ acc_parse_tree_int1(ParseTreeInt1, ReadWhy1, !Acc) :- AccForeignEnums, AccForeignExportEnums0, AccDeclPragmas, AccDeclMarkers, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, + AccDeclPragmasInputSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -889,6 +899,7 @@ acc_parse_tree_int2(ParseTreeInt2, ReadWhy2, !Acc) :- AccForeignEnums0, AccForeignExportEnums0, AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, + AccDeclPragmasInputSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -944,6 +955,7 @@ acc_parse_tree_int2(ParseTreeInt2, ReadWhy2, !Acc) :- AccForeignEnums0, AccForeignExportEnums0, AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, + AccDeclPragmasInputSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -965,7 +977,8 @@ acc_parse_tree_plain_opt(ParseTreePlainOpt, !Acc) :- UseMap, FIMSpecs, TypeDefns, ForeignEnums, InstDefns, ModeDefns, TypeClasses, Instances, PredDecls, ModeDecls, Clauses, ForeignProcs, Promises, - DeclMarkers, ImplMarkers, TypeSpecs, UnusedArgs, TermInfos, Term2Infos, + DeclMarkers, ImplMarkers, TypeSpecs, InputSpecs, + UnusedArgs, TermInfos, Term2Infos, Exceptions, Trailings, MMTablings, Sharings, Reuses), !.Acc = item_accumulator(AccAvails0, AccFIMs0, @@ -976,6 +989,7 @@ acc_parse_tree_plain_opt(ParseTreePlainOpt, !Acc) :- AccForeignEnums0, AccForeignExportEnums0, AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, + AccDeclPragmasInputSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -1012,6 +1026,8 @@ acc_parse_tree_plain_opt(ParseTreePlainOpt, !Acc) :- AccDeclMarkers0, AccDeclMarkers), AccDeclPragmasTypeSpec = AccDeclPragmasTypeSpec0 ++ cord.from_list(TypeSpecs), + acc_ims_list(ItemMercuryStatus, InputSpecs, + AccDeclPragmasInputSpec0, AccDeclPragmasInputSpec), AccDeclPragmasTermInfo = AccDeclPragmasTermInfo0 ++ cord.from_list(TermInfos), AccDeclPragmasTerm2Info = AccDeclPragmasTerm2Info0 ++ @@ -1040,6 +1056,7 @@ acc_parse_tree_plain_opt(ParseTreePlainOpt, !Acc) :- AccForeignEnums, AccForeignExportEnums0, AccDeclPragmas0, AccDeclMarkers, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec, + AccDeclPragmasInputSpec, AccDeclPragmasTermInfo, AccDeclPragmasTerm2Info, AccDeclPragmasSharing, AccDeclPragmasReuse, AccImplPragmas0, AccImplMarkers, @@ -1066,6 +1083,7 @@ acc_parse_tree_trans_opt(ParseTreeTransOpt, !Acc) :- AccForeignEnums0, AccForeignExportEnums0, AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, + AccDeclPragmasInputSpec0, AccDeclPragmasTermInfo0, AccDeclPragmasTerm2Info0, AccDeclPragmasSharing0, AccDeclPragmasReuse0, AccImplPragmas0, AccImplMarkers0, @@ -1097,6 +1115,7 @@ acc_parse_tree_trans_opt(ParseTreeTransOpt, !Acc) :- AccForeignEnums0, AccForeignExportEnums0, AccDeclPragmas0, AccDeclMarkers0, AccDeclPragmasTypeSpecConstr0, AccDeclPragmasTypeSpec0, + AccDeclPragmasInputSpec0, AccDeclPragmasTermInfo, AccDeclPragmasTerm2Info, AccDeclPragmasSharing, AccDeclPragmasReuse, AccImplPragmas0, AccImplMarkers0, diff --git a/compiler/mercury_compile_front_end.m b/compiler/mercury_compile_front_end.m index a5a6634fd..55c48fce3 100644 --- a/compiler/mercury_compile_front_end.m +++ b/compiler/mercury_compile_front_end.m @@ -134,6 +134,7 @@ :- import_module hlds.hlds_pred. :- import_module hlds.hlds_statistics. :- import_module hlds.implementation_defined_literals. +:- import_module hlds.input_specialization. :- import_module libs.file_util. :- import_module libs.globals. :- import_module libs.optimization_options. @@ -358,7 +359,12 @@ frontend_pass_after_typecheck(ProgressStream, ErrorStream, OpModeAugment, subst_implementation_defined_literals(ProgressStream, ErrorStream, Verbose, Stats, !HLDS, !MaybeWrittenSpecs, !IO), maybe_dump_hlds(ProgressStream, !.HLDS, 25, - "implementation_defined_literals", !DumpInfo, !IO), + "impl_defined_literals", !DumpInfo, !IO), + + maybe_apply_input_specialization(ProgressStream, ErrorStream, + Verbose, Stats, !HLDS, !MaybeWrittenSpecs, !IO), + maybe_dump_hlds(ProgressStream, !.HLDS, 27, + "input_spec", !DumpInfo, !IO), ( if !.FoundError = no, @@ -785,6 +791,30 @@ subst_implementation_defined_literals(ProgressStream, ErrorStream, %---------------------------------------------------------------------------% +:- pred maybe_apply_input_specialization(io.text_output_stream::in, + io.text_output_stream::in, bool::in, bool::in, + module_info::in, module_info::out, + maybe_written_specs::in, maybe_written_specs::out, io::di, io::uo) is det. + +maybe_apply_input_specialization(ProgressStream, ErrorStream, Verbose, Stats, + !HLDS, !MaybeWrittenSpecs, !IO) :- + module_info_get_input_spec_table(!.HLDS, InputSpecTable), + ( if map.is_empty(InputSpecTable) then + true + else + module_info_get_globals(!.HLDS, Globals), + maybe_write_not_yet_written_specs(ErrorStream, Globals, Verbose, + !MaybeWrittenSpecs, !IO), + maybe_write_string(ProgressStream, Verbose, + "% Performing input specialization...\n", !IO), + maybe_flush_output(ProgressStream, Verbose, !IO), + input_specialize_in_module(!HLDS), + maybe_write_string(ProgressStream, Verbose, "% done.\n", !IO), + maybe_report_stats(ProgressStream, Stats, !IO) + ). + +%---------------------------------------------------------------------------% + :- pred main_polymorphism_pass(io.text_output_stream::in, io.text_output_stream::in, bool::in, bool::in, list(pred_id)::out, maybe_safe_to_continue::out, diff --git a/compiler/module_qual.qualify_items.m b/compiler/module_qual.qualify_items.m index e07a8942d..e25b40d21 100644 --- a/compiler/module_qual.qualify_items.m +++ b/compiler/module_qual.qualify_items.m @@ -1920,6 +1920,19 @@ module_qualify_item_decl_pragma(InInt, Pragma0, Pragma, !Info) :- TypeSpecInfo = decl_pragma_type_spec_info(PFUMM, PredName, SpecPredName, Subst, TVarSet, Items, Context, SeqNum), Pragma = decl_pragma_type_spec(TypeSpecInfo) + ; + Pragma0 = decl_pragma_input_spec(InputSpecInfo0), + InputSpecInfo0 = decl_pragma_input_spec_info(ContainingModuleName, + Type0, ReplaceOrAdd, OoMInstCtors, OoMInsts0, + RecompItems, TVarSet, Context, SeqNum), + ErrorContext = mqec_pragma_decl(Context, Pragma0), + qualify_type(InInt, ErrorContext, Type0, Type, !Info), + one_or_more.map_foldl(qualify_inst(InInt, ErrorContext), + OoMInsts0, OoMInsts, !Info), + InputSpecInfo = decl_pragma_input_spec_info(ContainingModuleName, + Type, ReplaceOrAdd, OoMInstCtors, OoMInsts, + RecompItems, TVarSet, Context, SeqNum), + Pragma = decl_pragma_input_spec(InputSpecInfo) ; Pragma0 = decl_pragma_oisu(OISUInfo0), OISUInfo0 = decl_pragma_oisu_info(TypeCtor0, CreatorPreds, diff --git a/compiler/notes/compiler_design.html b/compiler/notes/compiler_design.html index d754d5b73..bca6f28b2 100644 --- a/compiler/notes/compiler_design.html +++ b/compiler/notes/compiler_design.html @@ -1276,6 +1276,15 @@ is done after copying clauses to procedures, though it is not clear whether this is by design or by accident. This part is done by polymorphism_post_copy.m.
  • +input_specialization.m implements +any input_spec pragmas that occur in the compilation unit +by looking for mode declarations containing a generic "in" mode +for arguments of types identified in such pragmas, +constructing (usually) two or more mode declarations that each contain +a more specific "in(inst)" modes for the same argument, +and then either replacing the original mode declaration with the new ones, +or adding the new ones in front of the old one. +
  • The mode analyser consists of several analysis modules and a whole bunch of service modules.

    diff --git a/compiler/options.m b/compiler/options.m index 4e1531fb4..9358fce3c 100644 --- a/compiler/options.m +++ b/compiler/options.m @@ -5665,7 +5665,8 @@ optdb(oc_dev_ctrl, compiler_sufficiently_recent, bool(no), "subtype-int2-2025-07-07", "inrange-2025-10-01", "scout-disj-2025-11-15", - "subtype-int2-2026-08-09"], [ + "subtype-int2-2026-08-09", + "input-spec-2026-08-14"], [ w("Is the compiler sufficiently recent to contain the new feature"), w("or bugfix referred to by each name?")])). % These options are provided for use by implementors who want to compare diff --git a/compiler/parse_pragma.m b/compiler/parse_pragma.m index c76699dca..4c1a03104 100644 --- a/compiler/parse_pragma.m +++ b/compiler/parse_pragma.m @@ -253,6 +253,10 @@ parse_named_pragma(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms, PragmaName = "type_spec", parse_pragma_type_spec(ModuleName, VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM) + ; + PragmaName = "input_spec", + parse_pragma_input_spec(ModuleName, VarSet, ErrorTerm, + PragmaTerms, Context, SeqNum, MaybeIOM) ; PragmaName = "fact_table", parse_pragma_fact_table(ModuleName, VarSet, ErrorTerm, @@ -2122,6 +2126,141 @@ name_anonymous_variable(NamedVarNames, AnonVar, !Counter, !VarSet) :- varset.name_var(AnonVar, VarName, !VarSet) ). +%---------------------------------------------------------------------------% +% +% Parse input_spec pragmas. +% + +:- pred parse_pragma_input_spec(module_name::in, varset::in, term::in, + list(term)::in, prog_context::in, item_seq_num::in, + maybe1(item_or_marker)::out) is det. + +parse_pragma_input_spec(ModuleName, VarSet, ErrorTerm, PragmaTerms, + Context, SeqNum, MaybeIOM) :- + ( if PragmaTerms = [TypeTerm, ReplaceOrAddTerm, InstsTerm] then + TypeContextPieces = cord.from_list( + [words("In the first argument of"), pragma_decl("input_spec"), + words("declaration:"), nl]), + parse_type(no_allow_ho_inst_info(wnhii_pragma_input_spec), + VarSet, TypeContextPieces, TypeTerm, MaybeType), + ( if + ReplaceOrAddTerm = term.functor(atom(RoAStr), [], _), + ( RoAStr = "replace_in_mode", ReplaceOrAdd0 = replace_in_mode + ; RoAStr = "add_to_in_mode", ReplaceOrAdd0 = add_to_in_mode + ) + then + MaybeReplaceOrAdd = ok1(ReplaceOrAdd0) + else + ReplaceOrAddTermStr = mercury_term_to_string_vs(VarSet, + print_name_only, ReplaceOrAddTerm), + RoAPieces = [words("In the second argument of"), + pragma_decl("input_spec"), words("declaration:"), nl, + words("error: expected either")] ++ + color_as_correct([fixed("replace_in_mode")]) ++ + [words("or")] ++ + color_as_correct([fixed("add_to_in_mode,")]) ++ + [words("got")] ++ + color_as_incorrect([words(ReplaceOrAddTermStr), + suffix(".")]) ++ + [nl], + RoASpec = spec($pred, severity_error, phase_t2pt, + get_term_context(ReplaceOrAddTerm), RoAPieces), + MaybeReplaceOrAdd = error1(one_or_more(RoASpec, [])) + ), + ( if list_term_to_term_list(InstsTerm, InstTerms) then + list.filter_map(term_to_inst_ctor, InstTerms, + InstCtors, BadInstTerms), + ( + BadInstTerms = [], + ( + InstCtors = [], + NoInstPieces = [words("In the third argument of"), + pragma_decl("input_spec"), words("declaration:"), nl, + words("error: expected a")] ++ + color_as_correct( + [words("nonempty list of inst names,")]) ++ + [words("got an")] ++ + color_as_incorrect([words("empty list.")]) ++ + [nl], + NoInstSpec = spec($pred, severity_error, phase_t2pt, + get_term_context(InstsTerm), NoInstPieces), + MaybeOoMInstCtors = error1(one_or_more(NoInstSpec, [])) + ; + InstCtors = [HeadInstCtor | TailInstCtors], + OoMInstCtors0 = one_or_more(HeadInstCtor, TailInstCtors), + MaybeOoMInstCtors = ok1(OoMInstCtors0) + ) + ; + BadInstTerms = [_ | _], + BadInstTermStrs = list.map( + mercury_term_to_string_vs(VarSet, print_name_only), + BadInstTerms), + BadInstTermPieces = + list.map((func(S) = words(S)), BadInstTermStrs), + NotInstName = choose_number(BadInstTermPieces, + "is not an inst name", "are not inst names"), + BadInstPieces = [words("In the third argument of"), + pragma_decl("input_spec"), words("declaration:"), nl, + words("error: expected a nonempty")] ++ + color_as_correct([words("list of inst names,")]) ++ + [words("but")] ++ + piece_list_to_color_pieces(color_incorrect, "and", [], + BadInstTermPieces) ++ + [words(NotInstName), suffix("."), nl], + BadInstSpec = spec($pred, severity_error, phase_t2pt, + get_term_context(InstsTerm), BadInstPieces), + MaybeOoMInstCtors = error1(one_or_more(BadInstSpec, [])) + ) + else + InstsTermStr = mercury_term_to_string_vs(VarSet, + print_name_only, InstsTerm), + ListPieces = [words("In the third argument of"), + pragma_decl("input_spec"), words("declaration:"), nl, + words("error: expected a nonempty")] ++ + color_as_correct([words("list of inst names,")]) ++ + [words("got")] ++ + color_as_incorrect([words(InstsTermStr), suffix(".")]) ++ + [nl], + ListSpec = spec($pred, severity_error, phase_t2pt, + get_term_context(InstsTerm), ListPieces), + MaybeOoMInstCtors = error1(one_or_more(ListSpec, [])) + ), + ( if + MaybeType = ok1(Type), + MaybeReplaceOrAdd = ok1(ReplaceOrAdd), + MaybeOoMInstCtors = ok1(OoMInstCtors) + then + InstCtorToInst = + (func(inst_ctor(SN, _)) = defined_inst(user_inst(SN, []))), + OoMInsts = one_or_more.map(InstCtorToInst, OoMInstCtors), + varset.coerce(VarSet, TVarSet), + InputSpec = decl_pragma_input_spec_info(ModuleName, Type, + ReplaceOrAdd, OoMInstCtors, OoMInsts, + set.init, TVarSet, Context, SeqNum), + Item = item_decl_pragma(decl_pragma_input_spec(InputSpec)), + MaybeIOM = ok1(iom_item(Item)) + else + Specs = get_any_errors1(MaybeType) ++ + get_any_errors1(MaybeReplaceOrAdd) ++ + get_any_errors1(MaybeOoMInstCtors), + det_list_to_one_or_more(Specs, OoMSpecs), + MaybeIOM = error1(OoMSpecs) + ) + % parse_tvar_substs(WNHII, TypeContextPieces, VarSet0, + % HeadTypeSubstTerm, TailTypeSubstTerms, + % TVarSubsts, [], TypeSpecs) + else + Spec = report_pragma_arity_error(ErrorTerm, "input_spec", + "three arguments"), + MaybeIOM = error1(one_or_more(Spec, [])) + ). + +:- pred term_to_inst_ctor(term::in, inst_ctor::out) is semidet. + +term_to_inst_ctor(Term, InstCtor) :- + Term = term.functor(atom(Name), [], _), + InstCtor = inst_ctor(unqualified(Name), 0). + %---------------------------------------------------------------------------% % % Parse fact_table pragmas. @@ -2294,6 +2433,10 @@ report_pragma_arity_error(ErrorTerm, PragmaName, ArgNumsStr) = Spec :- else AAn = "a" ), + % We used to use the code above, but what follows AAn in the output + % is not PragmaName, but ":- pragma PragmaName", which always starts + % with consonant, and specifically with "p". + % AAn = "a", Pieces = [words("Error:"), words(AAn)] ++ color_as_subject([pragma_decl(PragmaName), words("declaration")]) ++ [words("must have")] ++ diff --git a/compiler/parse_tree_out.m b/compiler/parse_tree_out.m index 271d50ee0..758d3f637 100644 --- a/compiler/parse_tree_out.m +++ b/compiler/parse_tree_out.m @@ -861,7 +861,8 @@ mercury_format_parse_tree_plain_opt(Info, S, ParseTree, !U) :- UseMap, FIMSpecs, TypeDefns, ForeignEnums, InstDefns, ModeDefns, TypeClasses, Instances, PredDecls, ModeDecls, Clauses, ForeignProcs, Promises, - DeclMarkers, ImplMarkers, TypeSpecs, UnusedArgs, Terms, Term2s, + DeclMarkers, ImplMarkers, TypeSpecs, InputSpecs, + UnusedArgs, Terms, Term2s, Exceptions, Trailings, MMTablings, Sharings, Reuses), Lang = get_output_lang(Info), add_string("% .opt file\n", S, !U), @@ -909,6 +910,7 @@ mercury_format_parse_tree_plain_opt(Info, S, ParseTree, !U) :- list.foldl(mercury_format_item_impl_marker(S), coerce(ImplMarkers), !U), list.foldl(mercury_format_pragma_type_spec(S, Lang), TypeSpecs, !U), + list.foldl(mercury_format_pragma_input_spec(S, Lang), InputSpecs, !U), list.foldl(mercury_format_item_clause(Info, S), Clauses, !U), list.foldl(mercury_format_item_foreign_proc(S, Lang), ForeignProcs, !U), list.foldl(mercury_format_item_promise(Info, S), Promises, !U), diff --git a/compiler/parse_tree_out_pragma.m b/compiler/parse_tree_out_pragma.m index 064f9bf4a..84d2595d4 100644 --- a/compiler/parse_tree_out_pragma.m +++ b/compiler/parse_tree_out_pragma.m @@ -76,6 +76,9 @@ :- 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). +:- pred mercury_format_pragma_input_spec(S::in, output_lang::in, + decl_pragma_input_spec_info::in, U::di, U::uo) is det <= pt_output(S, U). + :- pred mercury_format_pragma_unused_args(S::in, gen_pragma_unused_args_info::in, U::di, U::uo) is det <= pt_output(S, U). @@ -190,6 +193,9 @@ mercury_format_item_decl_pragma(Info, Stream, DeclPragma, !IO) :- ; DeclPragma = decl_pragma_type_spec(TypeSpec), mercury_format_pragma_type_spec(Stream, Lang, TypeSpec, !IO) + ; + DeclPragma = decl_pragma_input_spec(InputSpec), + mercury_format_pragma_input_spec(Stream, Lang, InputSpec, !IO) ; DeclPragma = decl_pragma_oisu(OISU), mercury_format_pragma_oisu(OISU, Stream, !IO) @@ -1073,6 +1079,43 @@ mercury_format_tvar_subst(VarSet, TVarSubst, S, !U) :- add_string(" = ", S, !U), mercury_format_type(VarSet, print_name_only, Type, S, !U). +%---------------------------------------------------------------------------% +% +% Output an input_spec pragma. +% + +mercury_format_pragma_input_spec(S, _Lang, InputSpec, !U) :- + InputSpec = decl_pragma_input_spec_info(_ContainingModuleName, + Type, ReplaceOrAdd, OoMInstCtors, _OoMInsts, _, TVarSet, _, _), + Instctors = one_or_more_to_list(OoMInstCtors), + InstStrs0 = list.map(get_zero_arity_inst_ctor_name, Instctors), + list.sort(InstStrs0, InstStrs), + InstsStr = string.join_list(", ", InstStrs), + IndentStr = " ", + add_string(":- pragma input_spec(", S, !U), + mercury_format_type(TVarSet, print_name_only, Type, S, !U), + add_string(", ", S, !U), + ( + ReplaceOrAdd = replace_in_mode, + add_string("replace_in_mode,\n", S, !U) + ; + ReplaceOrAdd = add_to_in_mode, + add_string("add_to_in_mode,\n", S, !U) + ), + add_string(IndentStr, S, !U), + add_string("[", S, !U), + add_string(InstsStr, S, !U), + add_string("]).\n", S, !U). + +:- func get_zero_arity_inst_ctor_name(inst_ctor) = string. + +get_zero_arity_inst_ctor_name(inst_ctor(SymName, Arity)) = Str :- + ( if Arity = 0 then + Str = sym_name_to_string(SymName) + else + unexpected($pred, "nonzero arity") + ). + %---------------------------------------------------------------------------% % % Output an unused_args pragma. diff --git a/compiler/parse_type_name.m b/compiler/parse_type_name.m index 84edec09a..9282fecca 100644 --- a/compiler/parse_type_name.m +++ b/compiler/parse_type_name.m @@ -48,7 +48,8 @@ ; wnhii_pragma_struct_sharing ; wnhii_pragma_struct_reuse ; wnhii_pragma_type_spec_constr - ; wnhii_pragma_type_spec. + ; wnhii_pragma_type_spec + ; wnhii_pragma_input_spec. :- pred maybe_parse_type(allow_ho_inst_info::in, term::in, mer_type::out) is semidet. @@ -954,6 +955,9 @@ no_ho_inst_allowed_desc(WNHII, Place, WhyNot) :- ; WNHII = wnhii_pragma_type_spec, Place = "a type_spec pragma" + ; + WNHII = wnhii_pragma_input_spec, + Place = "an input_spec pragma" ), WhyNot = wna_by_design ). diff --git a/compiler/prog_item_pragma.m b/compiler/prog_item_pragma.m index c20a9b365..6bfe4e948 100644 --- a/compiler/prog_item_pragma.m +++ b/compiler/prog_item_pragma.m @@ -40,6 +40,7 @@ ; 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_input_spec(decl_pragma_input_spec_info) ; decl_pragma_oisu(decl_pragma_oisu_info) ; decl_pragma_termination(decl_pragma_termination_info) ; decl_pragma_termination2(decl_pragma_termination2_info) @@ -224,6 +225,102 @@ %---------------------% +:- type decl_pragma_input_spec_info + ---> decl_pragma_input_spec_info( + % This pragma tells the compiler to replace code + % that switches on values of a control type at runtime + % with code that switches on those values at compile time. + % + % Given a type such as + % + % :- type action + % ---> hoist_nested_funcs + % ; chain_gc_stack_frames. + % + % and its insts + % + % :- inst hoist for action/0 + % ---> hoist_nested_funcs. + % :- inst chain for action/0 + % ---> chain_gc_stack_frames. + % + % input_spec pragma for type action with insts + % hoist and chain can replace a mode that contains + % an "in" argument of the action type with two modes + % that contain "in(hoist)" and "in(chain)" respectively. + % This effectively allows switches on that argument + % to be performed at compile time. (This is a real example + % from ml_elim_nested.m.) + + % The name of the module that this pragma occurs in. + % The pragma applies to the predicates and functions + % defined in this module, and *only* those defined + % in this module. + % + % If and when we start --intermod-opt to include + % input_spec pragmas in .opt files, we may also + % need to record the section (interface vs implementation) + % in which the pragma occurred. + ispec_module_name :: module_name, + + % We input specialize arguments of this type. + ispec_arg_type :: mer_type, + + % Do we replace the generic "in" mode with the set of + % specialized "in(inst_n)" modes, or do keep the old "in" + % mode as well? Only the latter preserves the ability to call + % the transformed predicate or function without knowing + % which of the specialized insts is applicable. + ispec_replace_or_add :: replace_or_add_in_mode, + + % The insts we specialize arguments of the selected type for. + % The pragma in the code contains each inst_ctor as simply + % a name; the parser adds the arity, which will be zero. + % (Input specialization is not applicable to any inst_ctor + % that takes any arguments.) + % + % We keep each inst_ctor in two forms: an inst_ctor, + % and an inst that applies that inst_ctor to the empty list + % of arguments. + % + % Both forms start out as just containing the inst name + % that the program contains, and then both get module + % qualified along with the test of the compilation unit. + % The difference between them is that the inst form + % then also gets any inst equivalences in it expanded out. + % It is the inst form that input_specialization.m uses + % to actually implement the pragma, but for writing out + % the pragma, we want the non-equivalence-expanded form + % (since the expansion result can change if the set of + % visible inst equivalences changes.) + ispec_spec_inst_ctors :: one_or_more(inst_ctor), + ispec_spec_insts :: one_or_more(mer_inst), + + % The equivalence types and insts used. + % + % At the moment, we gather this info, but then ignore it. + % For smart recompilation to work, we need to fix the latter. + ispec_items :: set(recomp_item_id), + + ispec_tvarset :: tvarset, + % We do not need an inst_varset. + + ispec_context :: prog_context, + ispec_seq_num :: item_seq_num + ). + + % Do we want to *replace* the "in" mode with the specialized + % "in(inst1)", "in(inst2)" modes, or do we want to *add* them? + % + % Note that add_to_in_mode is the only allowed value if the pragma + % occurs in the interface (and therefore applies to predicates + % in the interface). +:- type replace_or_add_in_mode + ---> replace_in_mode + ; add_to_in_mode. + +%---------------------% + :- type decl_pragma_oisu_info ---> decl_pragma_oisu_info( oisu_type_ctor :: type_ctor, @@ -599,6 +696,9 @@ get_decl_pragma_context(DeclPragma) = Context :- ; DeclPragma = decl_pragma_type_spec(TypeSpec), Context = TypeSpec ^ tspec_context + ; + DeclPragma = decl_pragma_input_spec(InputSpec), + Context = InputSpec ^ ispec_context ; DeclPragma = decl_pragma_oisu(OISU), Context = OISU ^ oisu_context diff --git a/compiler/prog_item_stats.m b/compiler/prog_item_stats.m index 3c993f048..7fcd53561 100644 --- a/compiler/prog_item_stats.m +++ b/compiler/prog_item_stats.m @@ -332,6 +332,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_input_spec(_) ; DeclPragma = decl_pragma_obsolete_pred(_) ; DeclPragma = decl_pragma_obsolete_proc(_) ; DeclPragma = decl_pragma_oisu(_) diff --git a/compiler/prog_parse_tree.m b/compiler/prog_parse_tree.m index ea7d09e77..e010dab64 100644 --- a/compiler/prog_parse_tree.m +++ b/compiler/prog_parse_tree.m @@ -633,6 +633,7 @@ ptpo_decl_markers :: list(item_decl_marker_info_opt), ptpo_impl_markers :: list(item_impl_marker_info_opt), ptpo_type_specs :: list(decl_pragma_type_spec_info), + ptpo_input_specs :: list(decl_pragma_input_spec_info), ptpo_unused_args :: list(gen_pragma_unused_args_info), ptpo_termination :: list(decl_pragma_termination_info), ptpo_termination2 :: list(decl_pragma_termination2_info), diff --git a/compiler/recompilation.version.m b/compiler/recompilation.version.m index e93fb6f3d..e972e6852 100644 --- a/compiler/recompilation.version.m +++ b/compiler/recompilation.version.m @@ -976,6 +976,12 @@ gather_decl_pragma_for_what_pf_id(DeclPragma, MaybePredOrFuncId) :- % set of constraints in their signature. That set is computed later, % when we add this pragma to the HLDS. MaybePredOrFuncId = no + ; + DeclPragma = decl_pragma_input_spec(_InputSpec), + % XXX Like decl_pragma_type_spec_constr, this kind of pragma + % applies to all predicates/functions that have arguments + % of the specified type. + MaybePredOrFuncId = no ; DeclPragma = decl_pragma_type_spec(TypeSpec), TypeSpec = decl_pragma_type_spec_info(PFUMM, Name, _, _, _, _, _, _), @@ -1469,6 +1475,17 @@ is_decl_pragma_changed(DeclPragma1, DeclPragma2, Changed) :- TypeSubst2, TVarSet2, _, _, _), is_type_subst_changed(TVarSet1, TVarSet2, TypeSubst1, TypeSubst2, unchanged) + ; + DeclPragma1 = decl_pragma_input_spec(TypeSpec1), + DeclPragma2 = decl_pragma_input_spec(TypeSpec2), + TypeSpec1 = decl_pragma_input_spec_info(ContainingModule, + Type1, ReplaceOrAdd, OoMInstCtors, OoMInsts, _, + TVarSet1, _, _), + TypeSpec2 = decl_pragma_input_spec_info(ContainingModule, + Type2, ReplaceOrAdd, OoMInstCtors, OoMInsts, _, + TVarSet2, _, _), + type_list_is_unchanged(TVarSet1, TVarSet2, [Type1], [Type2], + _, _, _) ; DeclPragma1 = decl_pragma_oisu(OISU1), DeclPragma2 = decl_pragma_oisu(OISU2), diff --git a/compiler/style_checks.m b/compiler/style_checks.m index bd3dfb638..00194998e 100644 --- a/compiler/style_checks.m +++ b/compiler/style_checks.m @@ -74,6 +74,7 @@ :- import_module hlds.hlds_clauses. :- import_module hlds.hlds_error_util. +:- import_module hlds.hlds_markers. :- import_module hlds.hlds_pred. :- import_module hlds.pred_table. :- import_module libs. @@ -565,7 +566,7 @@ report_any_inc_gaps(PredInfo, FirstINC, SecondINC, LaterINCs, ( if ( % The usual case: a predicate declaration followed immediately - % by one or more mode declaration for the predicate. + % by one or more mode declarations for the predicate. FirstItemNumber + 1 = SecondItemNumber ; % If the predicate has a predmode declaration, then @@ -574,6 +575,10 @@ report_any_inc_gaps(PredInfo, FirstINC, SecondINC, LaterINCs, FirstProcNum = 0, FirstItemNumber = SecondItemNumber, LaterINCs = [] + ; + FirstItemNumber = SecondItemNumber, + pred_info_get_markers(PredInfo, Markers), + marker_is_present(Markers, marker_was_input_specialized) ) then true diff --git a/compiler/table_gen.m b/compiler/table_gen.m index 137e8ddb4..20b47c1d4 100644 --- a/compiler/table_gen.m +++ b/compiler/table_gen.m @@ -2256,6 +2256,7 @@ keep_marker(marker_has_require_scope) = yes. keep_marker(marker_has_incomplete_switch) = yes. keep_marker(marker_has_format_call) = yes. keep_marker(marker_has_rhs_lambda) = yes. +keep_marker(marker_was_input_specialized) = yes. keep_marker(marker_fact_table_semantic_errors) = no. %---------------------------------------------------------------------------% diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile index feb11639e..8a5d3a180 100644 --- a/tests/hard_coded/Mmakefile +++ b/tests/hard_coded/Mmakefile @@ -466,6 +466,7 @@ ORDINARY_PROGS = \ test_foreign_proc \ test_imported_no_tag \ test_infinity \ + test_input_spec \ test_int_hash \ test_keys_and_values \ test_map_filter \ diff --git a/tests/hard_coded/test_input_spec.exp b/tests/hard_coded/test_input_spec.exp new file mode 100644 index 000000000..2adf0f587 --- /dev/null +++ b/tests/hard_coded/test_input_spec.exp @@ -0,0 +1,10 @@ + +CtrlA = 400, CtrlB = 4000 +AuxAC = 403, AuxAD = 406 +AuxBC = 4003, AuxBD = 4006 +AuxXC = 13, AuxXD = 16 + +CtrlA = 500, CtrlB = 5000 +AuxAC = 503, AuxAD = 506 +AuxBC = 5003, AuxBD = 5006 +AuxXC = 10003, AuxXD = 10006 diff --git a/tests/hard_coded/test_input_spec.m b/tests/hard_coded/test_input_spec.m new file mode 100644 index 000000000..72d58cd7a --- /dev/null +++ b/tests/hard_coded/test_input_spec.m @@ -0,0 +1,104 @@ +%---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% +% +% Test the operation of input_spec pragmas. +% +%---------------------------------------------------------------------------% + +:- module test_input_spec. +:- interface. + +:- import_module io. + +:- pred main(io::di, io::uo) is det. + +%---------------------------------------------------------------------------% + +:- implementation. + +:- import_module int. +:- import_module list. +:- import_module string. + +%---------------------------------------------------------------------------% + +main(!IO) :- + test(4, !IO), + test(5, !IO). + +%---------------------------------------------------------------------------% + +:- type control + ---> ctrl_a + ; ctrl_b. + +:- inst ctrl_a for control/0 + ---> ctrl_a. +:- inst ctrl_b for control/0 + ---> ctrl_b. + +:- type aux + ---> aux_c + ; aux_d. + +:- inst aux_c for aux/0 + ---> aux_c. +:- inst aux_d for aux/0 + ---> aux_d. + +:- pragma input_spec(control, add_to_in_mode, [ctrl_a, ctrl_b]). +:- pragma input_spec(aux, replace_in_mode, [aux_c, aux_d]). + +%---------------------------------------------------------------------------% + +:- pred test(int::in, io::di, io::uo) is det. + +test(In, !IO) :- + io.nl(!IO), + return_control(In, CtrlX), + test_control(ctrl_a, In, CtrlA), + test_control(ctrl_b, In, CtrlB), + test_aux(aux_c, CtrlA, AuxAC), + test_aux(aux_d, CtrlA, AuxAD), + test_aux(aux_c, CtrlB, AuxBC), + test_aux(aux_d, CtrlB, AuxBD), + test_aux(aux_c, CtrlX, AuxXC), + test_aux(aux_d, CtrlX, AuxXD), + io.format("CtrlA = %5d, CtrlB = %5d\n", [i(CtrlA), i(CtrlB)], !IO), + io.format("AuxAC = %5d, AuxAD = %5d\n", [i(AuxAC), i(AuxAD)], !IO), + io.format("AuxBC = %5d, AuxBD = %5d\n", [i(AuxBC), i(AuxBD)], !IO), + io.format("AuxXC = %5d, AuxXD = %5d\n", [i(AuxXC), i(AuxXD)], !IO). + +:- pred test_control(control::in, int::in, int::out) is det. + +test_control(Control, In, Out) :- + ( + Control = ctrl_a, + Out = In * 100 + ; + Control = ctrl_b, + Out = In * 1000 + ). + +:- pred test_aux(aux::in, int::in, int::out) is det. + +test_aux(Aux, In, Out) :- + ( + Aux = aux_c, + Out = In + 3 + ; + Aux = aux_d, + Out = In + 6 + ). + +:- pred return_control(int::in, int::out) is det. + +return_control(In, Ctrl) :- + ( if In mod 2 = 0 then + Ctrl = 10 + else + Ctrl = 10000 + ). + +%---------------------------------------------------------------------------% diff --git a/tests/invalid/Mmakefile b/tests/invalid/Mmakefile index 1a89e1735..d1c9f1a0b 100644 --- a/tests/invalid/Mmakefile +++ b/tests/invalid/Mmakefile @@ -77,6 +77,7 @@ BORING_SINGLEMODULE_PROGS = \ bad_fact_table_decls \ bad_field \ bad_format_call \ + bad_input_spec \ bad_inst_for_type \ bad_instance \ bad_item_in_interface \ diff --git a/tests/invalid/bad_input_spec.err_exp b/tests/invalid/bad_input_spec.err_exp new file mode 100644 index 000000000..acf39e23c --- /dev/null +++ b/tests/invalid/bad_input_spec.err_exp @@ -0,0 +1,34 @@ +bad_input_spec.m:050: Error: an `:- pragma input_spec' declaration must have +bad_input_spec.m:050: three arguments. +bad_input_spec.m:051: In the third argument of `:- pragma input_spec' +bad_input_spec.m:051: declaration: +bad_input_spec.m:051: error: expected a nonempty list of inst names, got an +bad_input_spec.m:051: empty list. +bad_input_spec.m:052: In the second argument of `:- pragma input_spec' +bad_input_spec.m:052: declaration: +bad_input_spec.m:052: error: expected either replace_in_mode or +bad_input_spec.m:052: add_to_in_mode, got add_to_in_mod. +bad_input_spec.m:052: In the third argument of `:- pragma input_spec' +bad_input_spec.m:052: declaration: +bad_input_spec.m:052: error: expected a nonempty list of inst names, but 9 is +bad_input_spec.m:052: not an inst name. +bad_input_spec.m:053: In the third argument of `:- pragma input_spec' +bad_input_spec.m:053: declaration: +bad_input_spec.m:053: error: expected a nonempty list of inst names, but 42 +bad_input_spec.m:053: and "fortytwo" are not inst names. +bad_input_spec.m:054: Error: the type constructor `au'/0 has no visible +bad_input_spec.m:054: definition. +bad_input_spec.m:054: In `:- pragma input_spec' declaration: +bad_input_spec.m:054: error: the type `au'/0 is undefined. +bad_input_spec.m:054: (Did you mean `aux'?) +bad_input_spec.m:055: Error: the type being specialized must be a ground type, +bad_input_spec.m:055: but it contains the type variable T. +bad_input_spec.m:056: In `:- pragma input_spec' declaration: +bad_input_spec.m:056: error: the inst `au_c'/0 is undefined. +bad_input_spec.m:056: (Did you mean `aux_c'?) +bad_input_spec.m:056: In `:- pragma input_spec' declaration: +bad_input_spec.m:056: error: the inst `aux_'/0 is undefined. +bad_input_spec.m:056: (Did you mean `aux_c' or `aux_d'?) +bad_input_spec.m:057: Error: duplicate `:- pragma input_spec' declaration for +bad_input_spec.m:057: bad_input_spec.aux. +bad_input_spec.m:056: The previous declaration was here. diff --git a/tests/invalid/bad_input_spec.m b/tests/invalid/bad_input_spec.m new file mode 100644 index 000000000..4b41adbb1 --- /dev/null +++ b/tests/invalid/bad_input_spec.m @@ -0,0 +1,110 @@ +%---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% +% +% Test errors in input_spec pragmas. +% +%---------------------------------------------------------------------------% + +:- module bad_input_spec. +:- interface. + +:- import_module io. + +:- pred main(io::di, io::uo) is det. + +%---------------------------------------------------------------------------% + +:- implementation. + +:- import_module int. +:- import_module list. +:- import_module string. + +%---------------------------------------------------------------------------% + +main(!IO) :- + test(4, !IO), + test(5, !IO). + +%---------------------------------------------------------------------------% + +:- type control + ---> ctrl_a + ; ctrl_b. + +:- inst ctrl_a for control/0 + ---> ctrl_a. +:- inst ctrl_b for control/0 + ---> ctrl_b. + +:- type aux + ---> aux_c + ; aux_d. + +:- inst aux_c for aux/0 + ---> aux_c. +:- inst aux_d for aux/0 + ---> aux_d. + +:- pragma input_spec(aux, replace_in_mode). +:- pragma input_spec(aux, replace_in_mode, []). +:- pragma input_spec(control, add_to_in_mod, [9, ctrl_b]). +:- pragma input_spec(control, add_to_in_mode, [42, "fortytwo", ctrl_b]). +:- pragma input_spec(au, replace_in_mode, [aux_c, aux_d]). +:- pragma input_spec(list(T), replace_in_mode, [aux_c, aux_d]). +:- pragma input_spec(aux, replace_in_mode, [au_c, aux_]). +:- pragma input_spec(aux, replace_in_mode, [aux_c, aux_d]). + +%---------------------------------------------------------------------------% + +:- pred test(int::in, io::di, io::uo) is det. + +test(In, !IO) :- + io.nl(!IO), + return_control(In, CtrlX), + test_control(ctrl_a, In, CtrlA), + test_control(ctrl_b, In, CtrlB), + test_aux(aux_c, CtrlA, AuxAC), + test_aux(aux_d, CtrlA, AuxAD), + test_aux(aux_c, CtrlB, AuxBC), + test_aux(aux_d, CtrlB, AuxBD), + test_aux(aux_c, CtrlX, AuxXC), + test_aux(aux_d, CtrlX, AuxXD), + io.format("CtrlA = %5d, CtrlB = %5d\n", [i(CtrlA), i(CtrlB)], !IO), + io.format("AuxAC = %5d, AuxAD = %5d\n", [i(AuxAC), i(AuxAD)], !IO), + io.format("AuxBC = %5d, AuxBD = %5d\n", [i(AuxBC), i(AuxBD)], !IO), + io.format("AuxXC = %5d, AuxXD = %5d\n", [i(AuxXC), i(AuxXD)], !IO). + +:- pred test_control(control::in, int::in, int::out) is det. + +test_control(Control, In, Out) :- + ( + Control = ctrl_a, + Out = In * 100 + ; + Control = ctrl_b, + Out = In * 1000 + ). + +:- pred test_aux(aux::in, int::in, int::out) is det. + +test_aux(Aux, In, Out) :- + ( + Aux = aux_c, + Out = In + 3 + ; + Aux = aux_d, + Out = In + 6 + ). + +:- pred return_control(int::in, int::out) is det. + +return_control(In, Ctrl) :- + ( if In mod 2 = 0 then + Ctrl = 10 + else + Ctrl = 10000 + ). + +%---------------------------------------------------------------------------% diff --git a/tests/warnings/help_text.err_exp b/tests/warnings/help_text.err_exp index d19f060e1..a4b6d7483 100644 --- a/tests/warnings/help_text.err_exp +++ b/tests/warnings/help_text.err_exp @@ -3722,6 +3722,7 @@ Options for developers only --inrange-2025-10-01 --scout-disj-2025-11-15 --subtype-int2-2026-08-09 + --input-spec-2026-08-14 Is the compiler sufficiently recent to contain the new feature or bugfix referred to by each name?