From 79dcbbef1574a5bbe2c94a78e5ee04871569a4ba Mon Sep 17 00:00:00 2001 From: Simon Taylor Date: Fri, 23 Apr 1999 01:03:51 +0000 Subject: [PATCH] User-guided type specialization. Estimated hours taken: 60 User-guided type specialization. compiler/prog_data.m: compiler/prog_io_pragma.m: compiler/modules.m: compiler/module_qual.m: compiler/mercury_to_mercury.m: Handle `:- pragma type_spec'. compiler/prog_io_pragma.m: Factor out some common code to parse predicate names with arguments. compiler/hlds_module.m: Added a field to the module_sub_info to hold information about user-requested type specializations, filled in by make_hlds.m and not used by anything after higher_order.m. compiler/make_hlds.m: For each `:- pragma type_spec' declaration, introduce a new predicate which just calls the predicate to be specialized with the specified argument types. This forces higher_order.m to produce the specialized versions. compiler/higher_order.m: Process the user-requested type specializations first to ensure that they get the correct names. Allow partial matches against user-specified versions, e.g. map__lookup(map(int, list(int)), int, list(int)) matches map__lookup(map(int, V), int, V). Perform specialization where a typeclass constraint matches a known instance, but the construction of the typeclass_info is done in the calling module. Give slightly more informative progress messages. compiler/dead_proc_elim.m: Remove specializations for dead procedures. compiler/prog_io_util.m: Change the definition of the `maybe1' and `maybe_functor' types to avoid the need for copying to convert between `maybe1' and `maybe1(generic)'. Changed the interface of `make_pred_name_with_context' to allow creation of predicate names for type specializations which describe the type substitution. compiler/make_hlds.m: compiler/prog_io_pragma.m: Make the specification of pragma declarations in error messages consistent. (There are probably some more to be fixed elsewhere for termination and tabling). compiler/intermod.m: Write type specialization pragmas for predicates declared in `.opt' files. compiler/mercury_to_mercury.m: Export `mercury_output_item' for use by intermod.m. compiler/options.m: Add an option `--user-guided-type-specialization' enabled with `-O2' or higher. compiler/handle_options.m: `--type-specialization' implies `--user-guided-type-specialization'. compiler/hlds_goal.m: Add predicates to construct constants. These are duplicated in several other places, I'll fix that as a separate change. compiler/type_util.m: Added functions `int_type/0', `string_type/0', `float_type/0' and `char_type/0' which return the builtin types. These are duplicated in several other places, I'll fix that as a separate change. library/private_builtin.m: Added `instance_constraint_from_typeclass_info/3' to extract the typeclass_infos for a constraint on an instance declaration. This is useful for specializing class method calls. Added `thread_safe' to various `:- pragma c_code's. Added `:- pragma inline' declarations for `builtin_compare_*', which are important for user-guided type specialization. (`builtin_unify_*' are simple enough to go in the `.opt' files automatically). compiler/polymorphism.m: `instance_constraint_from_typeclass_info/3' does not need type_infos. Add `instance_constraint_from_typeclass_info/3' to the list of `typeclass_info_manipulator's which higher_order.m can interpret. NEWS: doc/reference_manual.texi: doc/user_guide.texi Document the new pragma and option. tests/invalid/Mmakefile: tests/invalid/type_spec.m: tests/invalid/type_spec.err_exp: Test error reporting for invalid type specializations. tests/hard_coded/Mmakefile: tests/invalid/type_spec.m: tests/invalid/type_spec.exp: Test type specialization. --- NEWS | 5 + compiler/check_typeclass.m | 8 +- compiler/const_prop.m | 13 +- compiler/dead_proc_elim.m | 29 +- compiler/equiv_type.m | 21 +- compiler/handle_options.m | 5 + compiler/higher_order.m | 1191 ++++++++++++++++++++++--------- compiler/hlds_goal.m | 151 +++- compiler/hlds_module.m | 168 +++-- compiler/intermod.m | 51 +- compiler/make_hlds.m | 406 ++++++++++- compiler/mercury_compile.m | 5 +- compiler/mercury_to_mercury.m | 74 +- compiler/module_qual.m | 27 +- compiler/modules.m | 1 + compiler/options.m | 20 +- compiler/polymorphism.m | 15 +- compiler/prog_data.m | 12 +- compiler/prog_io_pragma.m | 671 ++++++++--------- compiler/prog_io_util.m | 8 +- compiler/prog_util.m | 79 +- compiler/type_util.m | 11 + doc/reference_manual.texi | 86 +++ doc/user_guide.texi | 7 + library/private_builtin.m | 30 +- samples/ultra_sub.m | 2 +- tests/hard_coded/Mmakefile | 4 +- tests/hard_coded/type_spec.exp | 4 + tests/hard_coded/type_spec.m | 108 +++ tests/invalid/Mmakefile | 1 + tests/invalid/type_spec.err_exp | 15 + tests/invalid/type_spec.m | 25 + 32 files changed, 2448 insertions(+), 805 deletions(-) create mode 100644 tests/hard_coded/type_spec.exp create mode 100644 tests/hard_coded/type_spec.m create mode 100644 tests/invalid/type_spec.err_exp create mode 100644 tests/invalid/type_spec.m diff --git a/NEWS b/NEWS index 368e36dbe..2253fc0c2 100644 --- a/NEWS +++ b/NEWS @@ -134,3 +134,8 @@ Changes to the Mercury implementation: directories for both versions in their PATH, with the more recent one first, of course. +* We've added support for user-guided type specialization. + + See the "Type specialization" section of the "Pragmas" chapter of the + Mercury Language Reference Manual for details. + diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m index 6f9e10c6f..d45170276 100644 --- a/compiler/check_typeclass.m +++ b/compiler/check_typeclass.m @@ -55,6 +55,10 @@ io__state, io__state). :- mode check_typeclass__check_instance_decls(in, out, out, di, uo) is det. + % The prefix added to the class method name for the predicate + % used to call a class method for a specific instance. +:- func check_typeclass__introduced_pred_name_prefix = string. + :- implementation. :- import_module map, list, std_util, hlds_pred, hlds_data, prog_data, require. @@ -612,7 +616,7 @@ make_introduced_pred_name(ClassId, MethodName, PredArity, base_typeclass_info__make_instance_string(InstanceTypes, InstanceString), string__append_list( - ["Introduced_pred_for_", + [check_typeclass__introduced_pred_name_prefix, ClassNameString, "__", InstanceString, "____", MethodNameString, "_", @@ -620,6 +624,8 @@ make_introduced_pred_name(ClassId, MethodName, PredArity, PredNameString), PredName = unqualified(PredNameString). +check_typeclass__introduced_pred_name_prefix = "Introduced_pred_for_". + %---------------------------------------------------------------------------% % check that the superclass constraints are satisfied for the diff --git a/compiler/const_prop.m b/compiler/const_prop.m index c1beaf723..a0231f272 100644 --- a/compiler/const_prop.m +++ b/compiler/const_prop.m @@ -1,5 +1,5 @@ %---------------------------------------------------------------------------% -% Copyright (C) 1997-1998 The University of Melbourne. +% Copyright (C) 1997-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %---------------------------------------------------------------------------% @@ -392,16 +392,13 @@ evaluate_builtin_test("float", ">=", 0, Args, Result) :- %------------------------------------------------------------------------------% + % recompute_instmap_delta is run by simplify.m if anything changes, + % so the insts are not important here. :- pred make_construction(pair(prog_var, inst), cons_id, hlds_goal_expr). :- mode make_construction(in, in, out) is det. -make_construction(Var - VarInst, ConsId, Goal) :- - RHS = functor(ConsId, []), - CInst = bound(unique, [functor(ConsId, [])]), - Mode = (VarInst -> CInst) - (CInst -> CInst), - Unification = construct(Var, ConsId, [], []), - Context = unify_context(explicit, []), - Goal = unify(Var, RHS, Mode, Unification, Context). +make_construction(Var - _, ConsId, Goal) :- + make_const_construction(Var, ConsId, Goal - _). %------------------------------------------------------------------------------% diff --git a/compiler/dead_proc_elim.m b/compiler/dead_proc_elim.m index e50290880..bd42c6b98 100644 --- a/compiler/dead_proc_elim.m +++ b/compiler/dead_proc_elim.m @@ -687,12 +687,37 @@ dead_pred_elim(ModuleInfo0, ModuleInfo) :- list__foldl(dead_pred_elim_initialize, PredIds, DeadInfo0, DeadInfo1), dead_pred_elim_analyze(DeadInfo1, DeadInfo), - DeadInfo = dead_pred_info(ModuleInfo1, _, _, NeededPreds, _), + DeadInfo = dead_pred_info(ModuleInfo1, _, _, NeededPreds2, _), + + % + % If a predicate is not needed, predicates which were added in + % make_hlds.m to force type specialization are also not needed. + % Here we add in those which are needed. + % + module_info_type_spec_info(ModuleInfo1, + type_spec_info(TypeSpecProcs0, TypeSpecForcePreds0, + SpecMap0, PragmaMap0)), + set__to_sorted_list(NeededPreds2, NeededPredList2), + list__foldl( + lambda([NeededPred::in, AllPreds0::in, AllPreds::out] is det, ( + ( map__search(SpecMap0, NeededPred, NewNeededPreds) -> + set__insert_list(AllPreds0, NewNeededPreds, AllPreds) + ; + AllPreds = AllPreds0 + ) + )), NeededPredList2, NeededPreds2, NeededPreds), + set__intersect(TypeSpecForcePreds0, NeededPreds, TypeSpecForcePreds), + + module_info_set_type_spec_info(ModuleInfo1, + type_spec_info(TypeSpecProcs0, TypeSpecForcePreds, + SpecMap0, PragmaMap0), + ModuleInfo2), + set__list_to_set(PredIds, PredIdSet), set__difference(PredIdSet, NeededPreds, DeadPreds), set__to_sorted_list(DeadPreds, DeadPredList), list__foldl(module_info_remove_predicate, DeadPredList, - ModuleInfo1, ModuleInfo). + ModuleInfo2, ModuleInfo). :- pred dead_pred_elim_add_entity(entity::in, queue(pred_id)::in, queue(pred_id)::out, set(pred_id)::in, set(pred_id)::out) is det. diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m index 47438ef0e..0d5cb093c 100644 --- a/compiler/equiv_type.m +++ b/compiler/equiv_type.m @@ -36,9 +36,8 @@ %-----------------------------------------------------------------------------% :- implementation. -:- import_module bool, require, std_util, map. +:- import_module assoc_list, bool, require, std_util, map, term, varset. :- import_module hlds_data, type_util, prog_data, prog_util, prog_out. -:- import_module term, varset. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -164,6 +163,12 @@ equiv_type__replace_in_item( EqvMap, Constraints, VarSet1), equiv_type__replace_in_type_list(Ts0, VarSet1, EqvMap, Ts, VarSet, _). +equiv_type__replace_in_item( + pragma(type_spec(A, B, C, D, E, Subst0, VarSet0)), + EqvMap, + pragma(type_spec(A, B, C, D, E, Subst, VarSet)), no) :- + equiv_type__replace_in_subst(Subst0, VarSet0, EqvMap, Subst, VarSet). + :- pred equiv_type__replace_in_type_defn(type_defn, tvarset, eqv_map, type_defn, tvarset, bool). :- mode equiv_type__replace_in_type_defn(in, in, in, out, out, out) is semidet. @@ -275,6 +280,18 @@ equiv_type__replace_in_class_method(_, %-----------------------------------------------------------------------------% +:- pred equiv_type__replace_in_subst(assoc_list(tvar, type), tvarset, + eqv_map, assoc_list(tvar, type), tvarset). +:- mode equiv_type__replace_in_subst(in, in, in, out, out) is det. + +equiv_type__replace_in_subst([], VarSet, _EqvMap, [], VarSet). +equiv_type__replace_in_subst([Var - Type0 | Subst0], VarSet0, + EqvMap, [Var - Type | Subst], VarSet) :- + equiv_type__replace_in_type(Type0, VarSet0, EqvMap, Type, VarSet1), + equiv_type__replace_in_subst(Subst0, VarSet1, EqvMap, Subst, VarSet). + +%-----------------------------------------------------------------------------% + :- pred equiv_type__replace_in_uu(list(type), tvarset, eqv_map, list(type), tvarset). :- mode equiv_type__replace_in_uu(in, in, in, out, out) is det. diff --git a/compiler/handle_options.m b/compiler/handle_options.m index 5dd5f78ad..15fc0c7f7 100644 --- a/compiler/handle_options.m +++ b/compiler/handle_options.m @@ -427,6 +427,11 @@ postprocess_options_2(OptionTable, GC_Method, TagsMethod, ArgsMethod, [] ), + % If we are doing type-specialization, we may as well take + % advantage of the declarations supplied by the programmer. + option_implies(type_specialization, user_guided_type_specialization, + bool(yes)), + % --intermod-unused-args implies --intermodule-optimization and % --optimize-unused-args. option_implies(intermod_unused_args, intermodule_optimization, diff --git a/compiler/higher_order.m b/compiler/higher_order.m index 30d2c72bd..f7d64e368 100644 --- a/compiler/higher_order.m +++ b/compiler/higher_order.m @@ -26,13 +26,9 @@ :- interface. :- import_module hlds_module. -:- import_module bool, io. +:- import_module io. - % specialize_higher_order(DoHigherOrder, DoTypeInfos, Module0, Module). - % DoHigherOrder is the value of `--optimize-higher-order'. - % DoTypeInfos is the value of `--type-specialization' -:- pred specialize_higher_order(bool::in, bool::in, - module_info::in, module_info::out, +:- pred specialize_higher_order(module_info::in, module_info::out, io__state::di, io__state::uo) is det. %------------------------------------------------------------------------------- @@ -43,63 +39,130 @@ :- import_module code_util, globals, make_hlds, mode_util, goal_util. :- import_module type_util, options, prog_data, prog_out, quantification. :- import_module mercury_to_mercury, inlining, polymorphism, prog_util. -:- import_module special_pred, term, varset. +:- import_module special_pred, passes_aux, check_typeclass. -:- import_module assoc_list, char, int, list, map, require, set. -:- import_module std_util, string. +:- import_module assoc_list, bool, char, int, list, map, require, set. +:- import_module std_util, string, varset, term. % Iterate collecting requests and processing them until there % are no more requests remaining. -specialize_higher_order(DoHigherOrder, DoTypeInfos, - ModuleInfo0, ModuleInfo) --> +specialize_higher_order(ModuleInfo0, ModuleInfo) --> + globals__io_lookup_bool_option(optimize_higher_order, HigherOrder), + globals__io_lookup_bool_option(type_specialization, TypeSpec), + globals__io_lookup_bool_option(user_guided_type_specialization, + UserTypeSpec), globals__io_lookup_int_option(higher_order_size_limit, SizeLimit), - { Params = ho_params(DoHigherOrder, DoTypeInfos, SizeLimit) }, - { get_specialization_requests(Params, Requests, GoalSizes, - ModuleInfo0, ModuleInfo1) }, + globals__io_lookup_bool_option(typeinfo_liveness, + TypeInfoLiveness), + { Params = ho_params(HigherOrder, TypeSpec, + UserTypeSpec, SizeLimit, TypeInfoLiveness) }, { map__init(NewPredMap) }, { map__init(PredVarMap) }, { NewPreds0 = new_preds(NewPredMap, PredVarMap) }, - process_requests(Params, Requests, GoalSizes, 1, _NextHOid, - NewPreds0, _NewPreds, ModuleInfo1, ModuleInfo). + { map__init(GoalSizes0) }, -:- pred process_requests(ho_params::in, set(request)::in, goal_sizes::in, - int::in, int::out, new_preds::in, new_preds::out, module_info::in, - module_info::out, io__state::di, io__state::uo) is det. + { module_info_predids(ModuleInfo0, PredIds0) }, + { module_info_type_spec_info(ModuleInfo0, + type_spec_info(_, UserSpecPreds, _, _)) }, -process_requests(Params, Requests0, GoalSizes0, NextHOid0, NextHOid, - NewPreds0, NewPreds, ModuleInfo1, ModuleInfo) --> - { filter_requests(Params, ModuleInfo1, - Requests0, GoalSizes0, Requests) }, + % + % Make sure the user requested specializations are processed first, + % since we don't want to create more versions if one of these + % matches. + % + { set__list_to_set(PredIds0, PredIdSet0) }, + { set__difference(PredIdSet0, UserSpecPreds, PredIdSet) }, + { set__to_sorted_list(PredIdSet, PredIds) }, + + { set__init(Requests0) }, + { set__to_sorted_list(UserSpecPreds, UserSpecPredList) }, + { get_specialization_requests(Params, UserSpecPredList, NewPreds0, + Requests0, UserRequests, GoalSizes0, GoalSizes1, + ModuleInfo0, ModuleInfo1) }, + process_requests(Params, UserRequests, Requests1, + GoalSizes1, GoalSizes2, 1, NextHOid, + NewPreds0, NewPreds1, ModuleInfo1, ModuleInfo2), + + % + % Process all other specialization until no more requests + % are generated. + % + { get_specialization_requests(Params, PredIds, NewPreds1, + Requests1, Requests, GoalSizes2, GoalSizes, + ModuleInfo2, ModuleInfo3) }, + recursively_process_requests(Params, Requests, GoalSizes, _, + NextHOid, _, NewPreds1, _NewPreds, ModuleInfo3, ModuleInfo4), + + % Remove the predicates which were used to force the production of + % user-requested type specializations, since they are not called + % from anywhere and are no longer needed. + { list__foldl(module_info_remove_predicate, + UserSpecPredList, ModuleInfo4, ModuleInfo) }. + + % Process one lot of requests, returning requests for any + % new specializations made possible by the first lot. +:- pred process_requests(ho_params::in, set(request)::in, set(request)::out, + goal_sizes::in, goal_sizes::out, int::in, int::out, + new_preds::in, new_preds::out, module_info::in, module_info::out, + io__state::di, io__state::uo) is det. + +process_requests(Params, Requests0, NewRequests, + GoalSizes0, GoalSizes, NextHOid0, NextHOid, + NewPreds0, NewPreds, ModuleInfo1, ModuleInfo) --> + filter_requests(Params, ModuleInfo1, Requests0, GoalSizes0, Requests), ( { Requests = [] } -> { ModuleInfo = ModuleInfo1 }, { NextHOid = NextHOid0 }, - { NewPreds = NewPreds0 } + { NewPreds = NewPreds0 }, + { GoalSizes = GoalSizes0 }, + { set__init(NewRequests) } ; { set__init(PredProcsToFix0) }, - create_new_preds(Requests, NewPreds0, NewPreds1, + create_new_preds(Params, Requests, NewPreds0, NewPreds1, [], NewPredList, PredProcsToFix0, PredProcsToFix, - NextHOid0, NextHOid1, ModuleInfo1, ModuleInfo2), + NextHOid0, NextHOid, ModuleInfo1, ModuleInfo2), { set__to_sorted_list(PredProcsToFix, PredProcs) }, { set__init(NewRequests0) }, { create_specialized_versions(Params, NewPredList, - NewPreds1, NewPreds2, NewRequests0, NewRequests, + NewPreds1, NewPreds, NewRequests0, NewRequests, GoalSizes0, GoalSizes, ModuleInfo2, ModuleInfo3) }, - { fixup_preds(Params, PredProcs, NewPreds2, + { fixup_preds(Params, PredProcs, NewPreds, ModuleInfo3, ModuleInfo4) }, { NewPredList \= [] -> % The dependencies have changed, so the % dependency graph needs to rebuilt for % inlining to work properly. module_info_clobber_dependency_info(ModuleInfo4, - ModuleInfo5) + ModuleInfo) ; - ModuleInfo5 = ModuleInfo4 - }, - process_requests(Params, NewRequests, GoalSizes, NextHOid1, - NextHOid, NewPreds2, NewPreds, ModuleInfo5, ModuleInfo) + ModuleInfo = ModuleInfo4 + } + ). + + % Process requests until there are no new requests to process. +:- pred recursively_process_requests(ho_params::in, set(request)::in, + goal_sizes::in, goal_sizes::out, int::in, int::out, + new_preds::in, new_preds::out, module_info::in, module_info::out, + io__state::di, io__state::uo) is det. + +recursively_process_requests(Params, Requests0, + GoalSizes0, GoalSizes, NextHOid0, NextHOid, + NewPreds0, NewPreds, ModuleInfo0, ModuleInfo) --> + ( { set__empty(Requests0) } -> + { GoalSizes = GoalSizes0 }, + { NextHOid = NextHOid0 }, + { NewPreds = NewPreds0 }, + { ModuleInfo = ModuleInfo0 } + ; + process_requests(Params, Requests0, NewRequests, + GoalSizes0, GoalSizes1, NextHOid0, NextHOid1, + NewPreds0, NewPreds1, ModuleInfo0, ModuleInfo1), + recursively_process_requests(Params, NewRequests, + GoalSizes1, GoalSizes, NextHOid1, NextHOid, + NewPreds1, NewPreds, ModuleInfo1, ModuleInfo) ). %------------------------------------------------------------------------------- @@ -115,7 +178,9 @@ process_requests(Params, Requests0, GoalSizes0, NextHOid0, NextHOid, list(type), % Extra typeinfo argument % types required by % --typeinfo-liveness. - tvarset % caller's typevarset. + tvarset, % caller's typevarset. + bool % is this a user-requested + % specialization ). % Stores cons_id, index in argument vector, number of @@ -163,8 +228,8 @@ process_requests(Params, Requests0, GoalSizes0, NextHOid0, NextHOid, % previous iterations % not changed by traverse_goal pred_proc_id, % pred_proc_id of goal being traversed - pred_info, % not changed by traverse_goal - proc_info, % not changed by traverse_goal + pred_info, % pred_info of goal being traversed + proc_info, % proc_info of goal being traversed module_info, % not changed by traverse_goal ho_params, changed @@ -174,7 +239,9 @@ process_requests(Params, Requests0, GoalSizes0, NextHOid0, NextHOid, ---> ho_params( bool, % propagate higher-order constants. bool, % propagate type-info constants. - int % size limit on requested version. + bool, % user-guided type specialization. + int, % size limit on requested version. + bool % --typeinfo-liveness ). :- type new_preds @@ -199,7 +266,9 @@ process_requests(Params, Requests0, GoalSizes0, NextHOid0, NextHOid, % in requesting caller list(type), % extra typeinfo argument % types in requesting caller - tvarset % caller's typevarset + tvarset, % caller's typevarset + bool % is this a user-specified type + % specialization ). % Returned by traverse_goal. @@ -208,26 +277,15 @@ process_requests(Params, Requests0, GoalSizes0, NextHOid0, NextHOid, ; request % Need to check other procs ; unchanged. % Do nothing more for this predicate -%------------------------------------------------------------------------------- -:- pred get_specialization_requests(ho_params::in, set(request)::out, +%-----------------------------------------------------------------------------% +:- pred get_specialization_requests(ho_params::in, list(pred_id)::in, + new_preds::in, set(request)::in, set(request)::out, goal_sizes::in, goal_sizes::out, module_info::in, module_info::out) is det. -get_specialization_requests(Params, Requests, GoalSizes, - ModuleInfo0, ModuleInfo) :- - module_info_predids(ModuleInfo0, PredIds), - map__init(GoalSizes0), - set__init(Requests0), - get_specialization_requests_2(Params, PredIds, Requests0, Requests, - GoalSizes0, GoalSizes, ModuleInfo0, ModuleInfo). - -:- pred get_specialization_requests_2(ho_params::in, list(pred_id)::in, - set(request)::in, set(request)::out, goal_sizes::in, goal_sizes::out, - module_info::in, module_info::out) is det. - -get_specialization_requests_2(_Params, [], Requests, Requests, Sizes, Sizes, - ModuleInfo, ModuleInfo). -get_specialization_requests_2(Params, [PredId | PredIds], Requests0, Requests, - GoalSizes0, GoalSizes, ModuleInfo0, ModuleInfo) :- +get_specialization_requests(_Params, [], _NewPreds, Requests, Requests, + Sizes, Sizes, ModuleInfo, ModuleInfo). +get_specialization_requests(Params, [PredId | PredIds], NewPreds, Requests0, + Requests, GoalSizes0, GoalSizes, ModuleInfo0, ModuleInfo) :- module_info_preds(ModuleInfo0, Preds0), map__lookup(Preds0, PredId, PredInfo0), pred_info_non_imported_procids(PredInfo0, NonImportedProcs), @@ -243,21 +301,18 @@ get_specialization_requests_2(Params, [PredId | PredIds], Requests0, Requests, proc_info_goal(ProcInfo0, Goal0), map__init(PredVars0), % first time through we can only specialize call/N - map__init(NewPredMap), - map__init(PredVarMap), - NewPreds0 = new_preds(NewPredMap, PredVarMap), PredProcId = proc(PredId, ProcId), - Info0 = info(PredVars0, Requests0, NewPreds0, PredProcId, + Info0 = info(PredVars0, Requests0, NewPreds, PredProcId, PredInfo0, ProcInfo0, ModuleInfo0, Params, unchanged), traverse_goal_0(Goal0, Goal1, Info0, - info(_, Requests1,_,_,_,_,_,_, Changed)), + info(_, Requests1,_,_,PredInfo1,ProcInfo1,_,_, Changed)), goal_size(Goal1, GoalSize), map__set(GoalSizes0, PredId, GoalSize, GoalSizes1), - proc_info_set_goal(ProcInfo0, Goal1, ProcInfo1), + proc_info_set_goal(ProcInfo1, Goal1, ProcInfo2), ( Changed = changed -> - requantify_proc(ProcInfo1, ProcInfo), + requantify_proc(ProcInfo2, ProcInfo), map__det_update(Procs0, ProcId, ProcInfo, Procs1) ; Procs1 = Procs0 @@ -266,9 +321,9 @@ get_specialization_requests_2(Params, [PredId | PredIds], Requests0, Requests, (Changed = request ; Changed = changed) -> traverse_other_procs(Params, PredId, ProcIds, - ModuleInfo0, PredInfo0, Requests1, Requests2, - Procs1, Procs), - pred_info_set_procedures(PredInfo0, Procs, PredInfo), + ModuleInfo0, PredInfo1, PredInfo2, NewPreds, + Requests1, Requests2, Procs1, Procs), + pred_info_set_procedures(PredInfo2, Procs, PredInfo), map__det_update(Preds0, PredId, PredInfo, Preds), module_info_set_preds(ModuleInfo0, Preds, ModuleInfo1) ; @@ -276,41 +331,42 @@ get_specialization_requests_2(Params, [PredId | PredIds], Requests0, Requests, Requests2 = Requests1 ) ), - get_specialization_requests_2(Params, PredIds, Requests2, Requests, - GoalSizes1, GoalSizes, ModuleInfo1, ModuleInfo). + get_specialization_requests(Params, PredIds, NewPreds, + Requests2, Requests, GoalSizes1, GoalSizes, + ModuleInfo1, ModuleInfo). % This is called when the first procedure of a pred was % changed. It fixes up all the other procs, ignoring the % goal_size and requests that come out, since that information % has already been collected. :- pred traverse_other_procs(ho_params::in, pred_id::in, list(proc_id)::in, - module_info::in, pred_info::in, set(request)::in, - set(request)::out, proc_table::in, proc_table::out) is det. + module_info::in, pred_info::in, pred_info::out, + new_preds::in, set(request)::in, + set(request)::out, proc_table::in, proc_table::out) is det. -traverse_other_procs(_Params, _PredId, [], _Module, _PredInfo, - Requests, Requests, Procs, Procs). +traverse_other_procs(_Params, _PredId, [], _Module, PredInfo, PredInfo, + _, Requests, Requests, Procs, Procs). traverse_other_procs(Params, PredId, [ProcId | ProcIds], ModuleInfo, - PredInfo0, Requests0, Requests, Procs0, Procs) :- + PredInfo0, PredInfo, NewPreds, + Requests0, Requests, Procs0, Procs) :- map__init(PredVars0), - map__init(NewPredMap), - map__init(PredVarMap), - NewPreds0 = new_preds(NewPredMap, PredVarMap), map__lookup(Procs0, ProcId, ProcInfo0), proc_info_goal(ProcInfo0, Goal0), - Info0 = info(PredVars0, Requests0, NewPreds0, proc(PredId, ProcId), + Info0 = info(PredVars0, Requests0, NewPreds, proc(PredId, ProcId), PredInfo0, ProcInfo0, ModuleInfo, Params, unchanged), traverse_goal_0(Goal0, Goal1, Info0, - info(_, Requests1, _,_,_,_,_,_,_)), - proc_info_headvars(ProcInfo0, HeadVars), - proc_info_varset(ProcInfo0, Varset0), - proc_info_vartypes(ProcInfo0, VarTypes0), + info(_, Requests1, _,_,PredInfo1,ProcInfo1,_,_,_)), + proc_info_headvars(ProcInfo1, HeadVars), + proc_info_varset(ProcInfo1, Varset0), + proc_info_vartypes(ProcInfo1, VarTypes0), implicitly_quantify_clause_body(HeadVars, Goal1, Varset0, VarTypes0, Goal, Varset, VarTypes, _), - proc_info_set_goal(ProcInfo0, Goal, ProcInfo1), - proc_info_set_varset(ProcInfo1, Varset, ProcInfo2), - proc_info_set_vartypes(ProcInfo2, VarTypes, ProcInfo), + proc_info_set_goal(ProcInfo1, Goal, ProcInfo2), + proc_info_set_varset(ProcInfo2, Varset, ProcInfo3), + proc_info_set_vartypes(ProcInfo3, VarTypes, ProcInfo), map__det_update(Procs0, ProcId, ProcInfo, Procs1), - traverse_other_procs(Params, PredId, ProcIds, ModuleInfo, PredInfo0, + traverse_other_procs(Params, PredId, ProcIds, ModuleInfo, + PredInfo1, PredInfo, NewPreds, Requests1, Requests, Procs1, Procs). %------------------------------------------------------------------------------- @@ -322,6 +378,7 @@ traverse_other_procs(Params, PredId, [ProcId | ProcIds], ModuleInfo, traverse_goal_0(Goal0, Goal, Info0, Info) :- Info0 = info(_, B, NewPreds0, PredProcId, E, F, G, H, I), NewPreds0 = new_preds(_, PredVarMap), + % Lookup the initial known bindings of the variables if this % procedure is a specialised version. ( map__search(PredVarMap, PredProcId, PredVars) -> @@ -359,15 +416,17 @@ traverse_goal(switch(Var, CanFail, Cases0, SM) - Info, % check whether this call could be specialized traverse_goal(Goal0, Goal) --> - { Goal0 = higher_order_call(Var, Args, _,_,_,_) - _ }, - maybe_specialize_higher_order_call(Var, no, Args, Goal0, Goal). + { Goal0 = higher_order_call(Var, Args, _,_,_,_) - GoalInfo }, + maybe_specialize_higher_order_call(Var, no, Args, Goal0, Goals), + { conj_list_to_goal(Goals, GoalInfo, Goal) }. % class_method_calls are treated similarly to % higher_order_calls. traverse_goal(Goal0, Goal) --> - { Goal0 = class_method_call(Var, Method, Args,_,_,_) - _ }, + { Goal0 = class_method_call(Var, Method, Args,_,_,_) - GoalInfo }, maybe_specialize_higher_order_call(Var, yes(Method), Args, - Goal0, Goal). + Goal0, Goals), + { conj_list_to_goal(Goals, GoalInfo, Goal) }. % check whether this call could be specialized traverse_goal(Goal0, Goal) --> @@ -553,35 +612,33 @@ check_unify(complicated_unify(_, _)) --> :- pred is_interesting_cons_id(ho_params::in, cons_id::in) is semidet. -is_interesting_cons_id(ho_params(_, yes, _), +is_interesting_cons_id(ho_params(_, _, yes, _, _), cons(qualified(Module, Name), _)) :- mercury_private_builtin_module(Module), ( Name = "type_info" ; Name = "typeclass_info" ). -is_interesting_cons_id(ho_params(yes, _, _), pred_const(_, _)). -is_interesting_cons_id(ho_params(_, yes, _), type_ctor_info_const(_, _, _)). -is_interesting_cons_id(ho_params(_, yes, _), +is_interesting_cons_id(ho_params(yes, _, _, _, _), pred_const(_, _)). +is_interesting_cons_id(ho_params(_, _, yes, _, _), + type_ctor_info_const(_, _, _)). +is_interesting_cons_id(ho_params(_, _, yes, _, _), base_typeclass_info_const(_, _, _, _)). % We need to keep track of int_consts so we can interpret % superclass_info_from_typeclass_info and typeinfo_from_typeclass_info. % We don't specialize based on them. -is_interesting_cons_id(ho_params(_, yes, _), int_const(_)). +is_interesting_cons_id(ho_params(_, _, yes, _, _), int_const(_)). % Process a higher-order call or class_method_call to see if it % could possibly be specialized. :- pred maybe_specialize_higher_order_call(prog_var::in, maybe(int)::in, - list(prog_var)::in, hlds_goal::in, hlds_goal::out, + list(prog_var)::in, hlds_goal::in, list(hlds_goal)::out, higher_order_info::in, higher_order_info::out) is det. maybe_specialize_higher_order_call(PredVar, MaybeMethod, Args, - Goal0 - GoalInfo, Goal - GoalInfo, Info0, Info) :- - Info0 = info(PredVars, _Requests0, _NewPreds, _PredProcId, - _CallerPredInfo, _CallerProcInfo, ModuleInfo, _, _), + Goal0 - GoalInfo, Goals, Info0, Info) :- + Info0 = info(PredVars, Requests0, NewPreds, PredProcId, + CallerPredInfo0, CallerProcInfo0, ModuleInfo, Params, Changed), - %proc_info_vartypes(CallerProcInfo, VarTypes), - %map__lookup(VarTypes, PredVar, PredVarType), - % We can specialize calls to call/N and class_method_call/N if % the closure or typeclass_info has a known value. ( @@ -620,27 +677,174 @@ maybe_specialize_higher_order_call(PredVar, MaybeMethod, Args, hlds_class_proc(PredId, ProcId)), list__append(InstanceConstraintArgs, Args, AllArgs) ; - fail + fail ) -> - module_info_pred_info(ModuleInfo, PredId, PredInfo), - pred_info_module(PredInfo, ModuleName), - pred_info_name(PredInfo, PredName), - code_util__builtin_state(ModuleInfo, PredId, ProcId, Builtin), + construct_specialized_higher_order_call(ModuleInfo, + PredId, ProcId, AllArgs, GoalInfo, Goal, Info0, Info), + Goals = [Goal] + ; + % Handle a class method call where we know which instance + % is being used, but we haven't seen a construction for + % the typeclass_info. This can happen for user-guided + % typeclass specialization, because the type-specialized class + % constraint is still in the constraint list, so a + % typeclass_info is passed in by the caller rather than + % being constructed locally. + % + % The problem is that in importing modules we don't know + % which instance declarations are visible in the imported + % module, so we don't know which class constraints are + % redundant after type specialization. + MaybeMethod = yes(Method), - MaybeContext = no, - Goal1 = call(PredId, ProcId, AllArgs, - Builtin, MaybeContext, - qualified(ModuleName, PredName)), - higher_order_info_update_changed_status(changed, Info0, Info1), - maybe_specialize_call(Goal1 - GoalInfo, - Goal - _, Info1, Info) + proc_info_vartypes(CallerProcInfo0, VarTypes), + map__lookup(VarTypes, PredVar, TypeClassInfoType), + polymorphism__typeclass_info_class_constraint( + TypeClassInfoType, ClassConstraint), + ClassConstraint = constraint(ClassName, ClassArgs), + list__length(ClassArgs, ClassArity), + module_info_instances(ModuleInfo, InstanceTable), + map__lookup(InstanceTable, class_id(ClassName, ClassArity), + Instances), + pred_info_typevarset(CallerPredInfo0, TVarSet0), + find_matching_instance_method(Instances, Method, + ClassArgs, PredId, ProcId, InstanceConstraints, + TVarSet0, TVarSet) + -> + pred_info_set_typevarset(CallerPredInfo0, + TVarSet, CallerPredInfo), + % Pull out the argument typeclass_infos. + ( InstanceConstraints = [] -> + ExtraGoals = [], + CallerProcInfo = CallerProcInfo0, + AllArgs = Args + ; + mercury_private_builtin_module(PrivateBuiltin), + module_info_get_predicate_table(ModuleInfo, PredTable), + ExtractArgSymName = qualified(PrivateBuiltin, + "instance_constraint_from_typeclass_info"), + ( + predicate_table_search_pred_sym_arity( + PredTable, ExtractArgSymName, + 3, [ExtractArgPredId0]) + -> + ExtractArgPredId = ExtractArgPredId0 + ; + error( + "higher_order.m: can't find `instance_constraint_from_typeclass_info'") + ), + hlds_pred__initial_proc_id(ExtractArgProcId), + get_arg_typeclass_infos(PredVar, ExtractArgPredId, + ExtractArgProcId, ExtractArgSymName, + InstanceConstraints, 1, + ExtraGoals, ArgTypeClassInfos, + CallerProcInfo0, CallerProcInfo), + list__append(ArgTypeClassInfos, Args, AllArgs) + ), + Info1 = info(PredVars, Requests0, NewPreds, PredProcId, + CallerPredInfo, CallerProcInfo, ModuleInfo, + Params, Changed), + construct_specialized_higher_order_call(ModuleInfo, + PredId, ProcId, AllArgs, GoalInfo, Goal, Info1, Info), + list__append(ExtraGoals, [Goal], Goals) ; % non-specializable call/N or class_method_call/N - Goal = Goal0, + Goals = [Goal0 - GoalInfo], Info = Info0 ). +:- pred find_matching_instance_method(list(hlds_instance_defn)::in, int::in, + list(type)::in, pred_id::out, proc_id::out, + list(class_constraint)::out, tvarset::in, tvarset::out) is semidet. + +find_matching_instance_method([Instance | Instances], MethodNum, + ClassTypes, PredId, ProcId, Constraints, TVarSet0, TVarSet) :- + ( + instance_matches(ClassTypes, Instance, + Constraints0, TVarSet0, TVarSet1) + -> + TVarSet = TVarSet1, + Constraints = Constraints0, + Instance = hlds_instance_defn(_, _, _, + _, _, yes(ClassInterface), _, _), + list__index1_det(ClassInterface, MethodNum, + hlds_class_proc(PredId, ProcId)) + ; + find_matching_instance_method(Instances, MethodNum, + ClassTypes, PredId, ProcId, Constraints, + TVarSet0, TVarSet) + ). + +:- pred instance_matches(list(type)::in, hlds_instance_defn::in, + list(class_constraint)::out, tvarset::in, tvarset::out) is semidet. + +instance_matches(ClassTypes, Instance, Constraints, TVarSet0, TVarSet) :- + Instance = hlds_instance_defn(_, _, Constraints0, + InstanceTypes0, _, _, InstanceTVarSet, _), + varset__merge_subst(TVarSet0, InstanceTVarSet, TVarSet, + RenameSubst), + term__apply_substitution_to_list(InstanceTypes0, + RenameSubst, InstanceTypes), + type_list_subsumes(InstanceTypes, ClassTypes, Subst), + apply_subst_to_constraint_list(RenameSubst, + Constraints0, Constraints1), + apply_rec_subst_to_constraint_list(Subst, + Constraints1, Constraints). + + % Build calls to + % `private_builtin:instance_constraint_from_typeclass_info/3' + % to extract the typeclass_infos for the constraints on an instance. + % This simulates the action of `do_call_class_method' in + % runtime/mercury_ho_call.c. +:- pred get_arg_typeclass_infos(prog_var::in, pred_id::in, proc_id::in, + sym_name::in, list(class_constraint)::in, int::in, + list(hlds_goal)::out, list(prog_var)::out, + proc_info::in, proc_info::out) is det. + +get_arg_typeclass_infos(_, _, _, _, [], _, [], [], ProcInfo, ProcInfo). +get_arg_typeclass_infos(TypeClassInfoVar, PredId, ProcId, SymName, + [InstanceConstraint | InstanceConstraints], + ConstraintNum, [ConstraintNumGoal, CallGoal | Goals], + [ArgTypeClassInfoVar | Vars], ProcInfo0, ProcInfo) :- + polymorphism__build_typeclass_info_type(InstanceConstraint, + ArgTypeClassInfoType), + proc_info_create_var_from_type(ProcInfo0, ArgTypeClassInfoType, + ArgTypeClassInfoVar, ProcInfo1), + MaybeContext = no, + make_int_const_construction(ConstraintNum, ConstraintNumGoal, + ConstraintNumVar, ProcInfo1, ProcInfo2), + Args = [TypeClassInfoVar, ConstraintNumVar, ArgTypeClassInfoVar], + + set__list_to_set(Args, NonLocals), + instmap_delta_init_reachable(InstMapDelta0), + instmap_delta_insert(InstMapDelta0, ArgTypeClassInfoVar, + ground(shared, no), InstMapDelta), + goal_info_init(NonLocals, InstMapDelta, det, GoalInfo), + CallGoal = call(PredId, ProcId, Args, not_builtin, + MaybeContext, SymName) - GoalInfo, + get_arg_typeclass_infos(TypeClassInfoVar, PredId, ProcId, SymName, + InstanceConstraints, ConstraintNum + 1, Goals, + Vars, ProcInfo2, ProcInfo). + +:- pred construct_specialized_higher_order_call(module_info::in, + pred_id::in, proc_id::in, list(prog_var)::in, hlds_goal_info::in, + hlds_goal::out, higher_order_info::in, higher_order_info::out) is det. + +construct_specialized_higher_order_call(ModuleInfo, PredId, ProcId, + AllArgs, GoalInfo, Goal - GoalInfo, Info0, Info) :- + module_info_pred_info(ModuleInfo, PredId, PredInfo), + pred_info_module(PredInfo, ModuleName), + pred_info_name(PredInfo, PredName), + SymName = qualified(ModuleName, PredName), + code_util__builtin_state(ModuleInfo, PredId, ProcId, Builtin), + + MaybeContext = no, + Goal1 = call(PredId, ProcId, AllArgs, Builtin, MaybeContext, SymName), + higher_order_info_update_changed_status(changed, Info0, Info1), + maybe_specialize_call(Goal1 - GoalInfo, + Goal - _, Info1, Info). + % Process a call to see if it could possibly be specialized. :- pred maybe_specialize_call(hlds_goal::in, hlds_goal::out, higher_order_info::in, higher_order_info::out) is det. @@ -672,30 +876,76 @@ maybe_specialize_call(Goal0 - GoalInfo, Goal - GoalInfo, Info0, Info) :- interpret_typeclass_info_manipulator(Manipulator, Args0, Goal0, Goal, Info0, Info) ; - ( pred_info_is_imported(CalleePredInfo) - ; pred_info_get_goal_type(CalleePredInfo, pragmas) + ( + pred_info_is_imported(CalleePredInfo), + module_info_type_spec_info(Module, + type_spec_info(TypeSpecProcs, _, _, _)), + \+ set__member(proc(CalledPred, CalledProc), + TypeSpecProcs) + ; + pred_info_is_pseudo_imported(CalleePredInfo), + hlds_pred__in_in_unification_proc_id(CalledProc) + ; + pred_info_get_goal_type(CalleePredInfo, pragmas) ) -> Info = Info0, Goal = Goal0 ; pred_info_arg_types(CalleePredInfo, CalleeArgTypes), + pred_info_import_status(CalleePredInfo, CalleeStatus), proc_info_vartypes(ProcInfo, VarTypes), - find_higher_order_args(Module, Args0, CalleeArgTypes, - VarTypes, PredVars, 1, [], HigherOrderArgs0, - Args0, Args1), - ( HigherOrderArgs0 = [] -> - Info = Info0, - Goal = Goal0 + find_higher_order_args(Module, CalleeStatus, Args0, + CalleeArgTypes, VarTypes, PredVars, 1, [], + HigherOrderArgs0), + + PredProcId = proc(CallerPredId, _), + module_info_type_spec_info(Module, + type_spec_info(_, ForceVersions, _, _)), + ( set__member(CallerPredId, ForceVersions) -> + IsUserSpecProc = yes ; + IsUserSpecProc = no + ), + + ( + ( + HigherOrderArgs0 = [_ | _] + ; + % We should create these + % even if there is no specialization + % to avoid link errors. + IsUserSpecProc = yes + ; + Params = ho_params(_, _, UserTypeSpec, _, _), + UserTypeSpec = yes, + map__apply_to_list(Args0, VarTypes, ArgTypes), + + % Check whether any typeclass constraints + % now match an instance. + pred_info_get_class_context(CalleePredInfo, + CalleeClassContext), + CalleeClassContext = + constraints(CalleeUnivConstraints0, _), + pred_info_typevarset(CalleePredInfo, + CalleeTVarSet), + pred_info_get_exist_quant_tvars(CalleePredInfo, + CalleeExistQTVars), + pred_info_typevarset(PredInfo, TVarSet), + type_subst_makes_instance_known( + Module, CalleeUnivConstraints0, + TVarSet, ArgTypes, CalleeTVarSet, + CalleeExistQTVars, CalleeArgTypes) + ) + -> list__reverse(HigherOrderArgs0, HigherOrderArgs), find_matching_version(Info0, CalledPred, CalledProc, - Args0, Args1, HigherOrderArgs, FindResult), + Args0, HigherOrderArgs, IsUserSpecProc, + FindResult), ( - FindResult = match(Match, ExtraTypeInfos), + FindResult = match(match(Match, _, Args)), Match = new_pred(NewPredProcId, _, _, - NewName, _HOArgs, _, _, _, _, _), - list__append(ExtraTypeInfos, Args1, Args), + NewName, _HOArgs, _, _, _, _, _, _), NewPredProcId = proc(NewCalledPred, NewCalledProc), Goal = call(NewCalledPred, NewCalledProc, @@ -707,34 +957,38 @@ maybe_specialize_call(Goal0 - GoalInfo, Goal - GoalInfo, Info0, Info) :- % There is a known higher order variable in % the call, so we put in a request for a % specialized version of the pred. - Goal = Goal0, FindResult = request(Request), + Goal = Goal0, set__insert(Requests0, Request, Requests), update_changed_status(Changed0, request, Changed) + ; + FindResult = no_request, + Goal = Goal0, + Requests = Requests0, + Changed = Changed0 ), Info = info(PredVars, Requests, NewPreds, PredProcId, PredInfo, ProcInfo, Module, Params, Changed) - ) + ; + Info = Info0, + Goal = Goal0 + ) ). % Returns a list of the higher-order arguments in a call that have - % a known value. Also update the argument list to now include - % curried arguments that need to be explicitly passed. - % The order of the argument list must match that generated - % by construct_higher_order_terms. -:- pred find_higher_order_args(module_info::in, list(prog_var)::in, - list(type)::in, map(prog_var, type)::in, pred_vars::in, int::in, - list(higher_order_arg)::in, list(higher_order_arg)::out, - list(prog_var)::in, list(prog_var)::out) is det. + % a known value. +:- pred find_higher_order_args(module_info::in, import_status::in, + list(prog_var)::in, list(type)::in, map(prog_var, type)::in, + pred_vars::in, int::in, list(higher_order_arg)::in, + list(higher_order_arg)::out) is det. -find_higher_order_args(_, [], _, _, _, _, - HOArgs, HOArgs, NewArgs, NewArgs). -find_higher_order_args(_, [_|_], [], _, _, _, _, _, _, _) :- +find_higher_order_args(_, _, [], _, _, _, _, HOArgs, HOArgs). +find_higher_order_args(_, _, [_|_], [], _, _, _, _, _) :- error("find_higher_order_args: length mismatch"). -find_higher_order_args(ModuleInfo, [Arg | Args], - [CalleeArgType | CalleeArgTypes], VarTypes, PredVars, ArgNo, - HOArgs0, HOArgs, NewArgs0, NewArgs) :- +find_higher_order_args(ModuleInfo, CalleeStatus, [Arg | Args], + [CalleeArgType | CalleeArgTypes], VarTypes, + PredVars, ArgNo, HOArgs0, HOArgs) :- NextArg is ArgNo + 1, ( % We don't specialize arguments whose declared type is @@ -750,6 +1004,10 @@ find_higher_order_args(ModuleInfo, [Arg | Args], ConsId \= int_const(_), ( ConsId = pred_const(_, _) -> + % If we don't have clauses for the callee, we can't + % specialize any higher-order arguments. We may be + % able to do user guided type specialization. + CalleeStatus \= imported, type_is_higher_order(CalleeArgType, _, _) ; true @@ -764,53 +1022,165 @@ find_higher_order_args(ModuleInfo, [Arg | Args], ; CurriedCalleeArgTypes = CurriedArgTypes ), - find_higher_order_args(ModuleInfo, CurriedArgs, + find_higher_order_args(ModuleInfo, CalleeStatus, CurriedArgs, CurriedCalleeArgTypes, VarTypes, - PredVars, 1, [], HOCurriedArgs0, - CurriedArgs, NewExtraArgs), + PredVars, 1, [], HOCurriedArgs0), list__reverse(HOCurriedArgs0, HOCurriedArgs), list__length(CurriedArgs, NumArgs), HOArg = higher_order_arg(ConsId, ArgNo, NumArgs, CurriedArgs, CurriedArgTypes, HOCurriedArgs), - HOArgs1 = [HOArg | HOArgs0], - list__append(NewArgs0, NewExtraArgs, NewArgs1) + HOArgs1 = [HOArg | HOArgs0] ; - HOArgs1 = HOArgs0, - NewArgs1 = NewArgs0 + HOArgs1 = HOArgs0 ), - find_higher_order_args(ModuleInfo, Args, CalleeArgTypes, - VarTypes, PredVars, NextArg, HOArgs1, HOArgs, - NewArgs1, NewArgs). + find_higher_order_args(ModuleInfo, CalleeStatus, Args, CalleeArgTypes, + VarTypes, PredVars, NextArg, HOArgs1, HOArgs). + + % Succeeds if the type substitution for a call makes any of + % the class constraints match an instance which was not matched + % before. +:- pred type_subst_makes_instance_known(module_info::in, + list(class_constraint)::in, tvarset::in, list(type)::in, + tvarset::in, existq_tvars::in, list(type)::in) is semidet. + +type_subst_makes_instance_known(ModuleInfo, CalleeUnivConstraints0, TVarSet0, + ArgTypes, CalleeTVarSet, CalleeExistQVars, CalleeArgTypes0) :- + CalleeUnivConstraints0 \= [], + varset__merge_subst(TVarSet0, CalleeTVarSet, + TVarSet, TypeRenaming), + term__apply_substitution_to_list(CalleeArgTypes0, TypeRenaming, + CalleeArgTypes1), + + % Substitute the types in the callee's class constraints. + % Typechecking has already succeeded, so none of the head type + % variables will be bound by the substitution. + HeadTypeParams = [], + inlining__get_type_substitution(CalleeArgTypes1, ArgTypes, + HeadTypeParams, CalleeExistQVars, TypeSubn), + apply_subst_to_constraint_list(TypeRenaming, + CalleeUnivConstraints0, CalleeUnivConstraints1), + apply_rec_subst_to_constraint_list(TypeSubn, + CalleeUnivConstraints1, CalleeUnivConstraints), + assoc_list__from_corresponding_lists(CalleeUnivConstraints0, + CalleeUnivConstraints, CalleeUnivConstraintAL), + + % Go through each constraint in turn, checking whether any instances + % match which didn't before the substitution was applied. + list__member(CalleeUnivConstraint0 - CalleeUnivConstraint, + CalleeUnivConstraintAL), + CalleeUnivConstraint0 = constraint(ClassName, ConstraintArgs0), + list__length(ConstraintArgs0, ClassArity), + CalleeUnivConstraint = constraint(_, ConstraintArgs), + module_info_instances(ModuleInfo, InstanceTable), + map__search(InstanceTable, class_id(ClassName, ClassArity), Instances), + list__member(Instance, Instances), + instance_matches(ConstraintArgs, Instance, _, TVarSet, _), + \+ instance_matches(ConstraintArgs0, Instance, _, TVarSet, _). :- type find_result - ---> match( - new_pred, % Specialised version to use. - list(prog_var) % Ordered list of extra type-info - % variables to add to the front of - % the argument list, empty if - % --typeinfo-liveness is not set. - ) - ; request(request) + ---> match(match) + ; request(request) + ; no_request . +:- type match + ---> match( + new_pred, + maybe(int), % was the match partial, if so, + % how many higher_order arguments + % matched. + list(prog_var) % the arguments to the specialised call + ). + :- pred find_matching_version(higher_order_info::in, - pred_id::in, proc_id::in, list(prog_var)::in, list(prog_var)::in, - list(higher_order_arg)::in, find_result::out) is det. + pred_id::in, proc_id::in, list(prog_var)::in, + list(higher_order_arg)::in, bool::in, find_result::out) is det. % Args0 is the original list of arguments. % Args1 is the original list of arguments with the curried arguments % of known higher-order arguments added. -find_matching_version(Info, CalledPred, CalledProc, Args0, Args1, - HigherOrderArgs, Result) :- +find_matching_version(Info, CalledPred, CalledProc, Args0, + HigherOrderArgs, IsUserSpecProc, Result) :- Info = info(_, _, NewPreds, Caller, - PredInfo, ProcInfo, ModuleInfo, _, _), + PredInfo, ProcInfo, ModuleInfo, Params, _), + + compute_extra_typeinfos(Info, Args0, ExtraTypeInfos, + ExtraTypeInfoTypes), + proc_info_vartypes(ProcInfo, VarTypes), - pred_info_arg_types(PredInfo, _, ExistQVars, _), + map__apply_to_list(Args0, VarTypes, CallArgTypes), pred_info_typevarset(PredInfo, TVarSet), - module_info_globals(ModuleInfo, Globals), - globals__lookup_bool_option(Globals, - typeinfo_liveness, TypeInfoLiveness), + Request = request(Caller, proc(CalledPred, CalledProc), Args0, + ExtraTypeInfos, HigherOrderArgs, CallArgTypes, + ExtraTypeInfoTypes, TVarSet, IsUserSpecProc), + + % Check to see if any of the specialized + % versions of the called pred apply here. + ( + NewPreds = new_preds(NewPredMap, _), + map__search(NewPredMap, proc(CalledPred, CalledProc), + Versions0), + set__to_sorted_list(Versions0, Versions), + search_for_version(Info, Params, ModuleInfo, Request, Args0, + Versions, no, Match) + -> + Result = match(Match) + ; + Params = ho_params(HigherOrder, TypeSpec, UserTypeSpec, _, _), + ( + UserTypeSpec = yes, + IsUserSpecProc = yes + ; + module_info_pred_info(ModuleInfo, + CalledPred, CalledPredInfo), + \+ pred_info_is_imported(CalledPredInfo), + ( + % This handles the predicates introduced + % by check_typeclass.m to call the class + % methods for a specific instance. + % Without this, user-specified specialized + % versions of class methods won't be called. + UserTypeSpec = yes, + ( + pred_info_get_markers(CalledPredInfo, + Markers), + check_marker(Markers, class_method) + ; + pred_info_name(CalledPredInfo, + CalledPredName), + string__prefix(CalledPredName, + check_typeclass__introduced_pred_name_prefix) + ) + ; + HigherOrder = yes, + list__member(HOArg, HigherOrderArgs), + HOArg = higher_order_arg(pred_const(_, _), + _, _, _, _, _) + ; + TypeSpec = yes + ) + ) + -> + Result = request(Request) + ; + Result = no_request + ). + + % If `--typeinfo-liveness' is set, specializing type `T' to `list(U)' + % requires passing in the type-info for `U'. This predicate + % works out which extra variables to pass in given the argument + % list for the call. +:- pred compute_extra_typeinfos(higher_order_info::in, list(prog_var)::in, + list(prog_var)::out, list(type)::out) is det. + +compute_extra_typeinfos(Info, Args1, ExtraTypeInfos, ExtraTypeInfoTypes) :- + Info = info(_, _, _, _, PredInfo, ProcInfo, _, Params, _), + + proc_info_vartypes(ProcInfo, VarTypes), + pred_info_arg_types(PredInfo, _, ExistQVars, _), + + Params = ho_params(_, _, _, _, TypeInfoLiveness), ( TypeInfoLiveness = yes -> set__list_to_set(Args1, NonLocals0), proc_info_typeinfo_varmap(ProcInfo, TVarMap), @@ -824,90 +1194,134 @@ find_matching_version(Info, CalledPred, CalledProc, Args0, Args1, ; ExtraTypeInfos = [], ExtraTypeInfoTypes = [] - ), - - map__apply_to_list(Args0, VarTypes, CallArgTypes), - Request = request(Caller, proc(CalledPred, CalledProc), Args0, - ExtraTypeInfos, HigherOrderArgs, CallArgTypes, - ExtraTypeInfoTypes, TVarSet), - - % Check to see if any of the specialized - % versions of the called pred apply here. - ( - NewPreds = new_preds(NewPredMap, _), - map__search(NewPredMap, proc(CalledPred, CalledProc), - NewPredSet), - set__to_sorted_list(NewPredSet, NewPredList), - search_for_version(TypeInfoLiveness, ModuleInfo, Request, - ExtraTypeInfos, NewPredList, - Match, OrderedExtraTypeInfos) - -> - Result = match(Match, OrderedExtraTypeInfos) - ; - Result = request(Request) ). -:- pred search_for_version(bool::in, module_info::in, request::in, - list(prog_var)::in, list(new_pred)::in, new_pred::out, - list(prog_var)::out) is semidet. +:- pred search_for_version(higher_order_info::in, ho_params::in, + module_info::in, request::in, list(prog_var)::in, + list(new_pred)::in, maybe(match)::in, match::out) is semidet. -search_for_version(TypeInfoLiveness, ModuleInfo, Request, ExtraTypeInfos, - [Version | Versions], Match, OrderedExtraTypeInfos) :- +search_for_version(_Info, _Params, _ModuleInfo, _Request, _Args0, + [], yes(Match), Match). +search_for_version(Info, Params, ModuleInfo, Request, Args0, + [Version | Versions], Match0, Match) :- ( - version_matches(TypeInfoLiveness, ModuleInfo, Request, - Version, yes(ExtraTypeInfos), OrderedExtraTypeInfos0) + version_matches(Params, ModuleInfo, Request, yes(Args0 - Info), + Version, Match1) -> - Match = Version, - OrderedExtraTypeInfos = OrderedExtraTypeInfos0 + ( + Match1 = match(_, no, _) + -> + Match = Match1 + ; + ( + Match0 = no + -> + Match2 = yes(Match1) + ; + % pick the best match + Match0 = yes(match(_, yes(NumMatches0), _)), + Match1 = match(_, yes(NumMatches1), _) + -> + ( NumMatches0 > NumMatches1 -> + Match2 = Match0 + ; + Match2 = yes(Match1) + ) + ; + error("higher_order: search_for_version") + ), + search_for_version(Info, Params, ModuleInfo, Request, + Args0, Versions, Match2, Match) + ) ; - search_for_version(TypeInfoLiveness, ModuleInfo, Request, - ExtraTypeInfos, Versions, Match, OrderedExtraTypeInfos) + search_for_version(Info, Params, ModuleInfo, Request, + Args0, Versions, Match0, Match) ). % Check whether the request has already been implemented by % the new_pred, maybe ordering the list of extra type_infos % in the caller predicate to match up with those in the caller. -:- pred version_matches(bool::in, module_info::in, request::in, - new_pred::in, maybe(list(prog_var))::in, list(prog_var)::out) - is semidet. +:- pred version_matches(ho_params::in, module_info::in, request::in, + maybe(pair(list(prog_var), higher_order_info))::in, + new_pred::in, match::out) is semidet. -version_matches(TypeInfoLiveness, _ModuleInfo, Request, Version, - MaybeExtraTypeInfos, OrderedExtraTypeInfos) :- +version_matches(Params, ModuleInfo, Request, MaybeArgs0, Version, + match(Version, PartialMatch, Args)) :- - Request = request(_, _, _, _, RequestHigherOrderArgs, CallArgTypes, - ExtraTypeInfoTypes, RequestTVarSet), + Request = request(_, Callee, _, _, RequestHigherOrderArgs, + CallArgTypes, _, RequestTVarSet, _), Version = new_pred(_, _, _, _, VersionHigherOrderArgs, _, _, - VersionArgTypes0, VersionExtraTypeInfoTypes0, VersionTVarSet), + VersionArgTypes0, VersionExtraTypeInfoTypes, + VersionTVarSet, VersionIsUserSpec), higher_order_args_match(RequestHigherOrderArgs, - VersionHigherOrderArgs), + VersionHigherOrderArgs, HigherOrderArgs, MatchIsPartial), + + ( MatchIsPartial = yes -> + list__length(HigherOrderArgs, NumHOArgs), + PartialMatch = yes(NumHOArgs) + ; + PartialMatch = no + ), + + Params = ho_params(_, TypeSpec, _, _, TypeInfoLiveness), + + Callee = proc(CalleePredId, _), + module_info_pred_info(ModuleInfo, CalleePredId, CalleePredInfo), + ( + % Don't accept partial matches unless the predicate is + % imported or we are only doing user-guided type + % specialization. + MatchIsPartial = no + ; + TypeSpec = no + ; + pred_info_is_imported(CalleePredInfo) + ), % Rename apart type variables. varset__merge_subst(RequestTVarSet, VersionTVarSet, _, TVarSubn), term__apply_substitution_to_list(VersionArgTypes0, TVarSubn, VersionArgTypes), - term__apply_substitution_to_list(VersionExtraTypeInfoTypes0, - TVarSubn, VersionExtraTypeInfoTypes), type_list_subsumes(VersionArgTypes, CallArgTypes, Subn), - ( TypeInfoLiveness = yes -> - % If typeinfo_liveness is set, the subsumption - % must go in both directions, since otherwise - % the set of type_infos which need to be passed - % might not be the same. + + % If typeinfo_liveness is set, the subsumption must go both ways, + % since otherwise a different set of typeinfos may need to be passed. + % For user-specified type specializations, it is guaranteed that + % no extra typeinfos are required because the substitution supplied + % by the user is not allowed to partially instantiate type variables. + ( TypeInfoLiveness = yes, VersionIsUserSpec = no -> type_list_subsumes(CallArgTypes, VersionArgTypes, _) ; true ), - ( TypeInfoLiveness = yes, MaybeExtraTypeInfos = yes(ExtraTypeInfos) -> - term__apply_rec_substitution_to_list( - VersionExtraTypeInfoTypes, - Subn, RenamedVersionTypeInfos), - assoc_list__from_corresponding_lists(ExtraTypeInfos, - ExtraTypeInfoTypes, ExtraTypeInfoAL), - order_typeinfos(Subn, ExtraTypeInfoAL, RenamedVersionTypeInfos, - [], OrderedExtraTypeInfos) + + ( MaybeArgs0 = yes(Args0 - Info) -> + get_extra_arguments(HigherOrderArgs, Args0, Args1), + + % For user-specified type specializations, it is guaranteed + % that no extra typeinfos are required because the + % substitution supplied by the user is not allowed to + % partially instantiate type variables. + ( VersionIsUserSpec = yes -> + Args = Args1 + ; + compute_extra_typeinfos(Info, Args1, ExtraTypeInfos, + ExtraTypeInfoTypes), + term__apply_rec_substitution_to_list( + VersionExtraTypeInfoTypes, + Subn, RenamedVersionTypeInfos), + assoc_list__from_corresponding_lists(ExtraTypeInfos, + ExtraTypeInfoTypes, ExtraTypeInfoAL), + order_typeinfos(Subn, ExtraTypeInfoAL, + RenamedVersionTypeInfos, + [], OrderedExtraTypeInfos), + list__append(OrderedExtraTypeInfos, Args1, Args) + ) ; - OrderedExtraTypeInfos = [] + % This happens when called from create_new_preds -- it doesn't + % care about the arguments. + Args = [] ). % Put the extra typeinfos for --typeinfo-liveness in the correct @@ -944,16 +1358,56 @@ order_typeinfos_2(VersionType, Var, [Var1 - VarType | VarsAndTypes0], ). :- pred higher_order_args_match(list(higher_order_arg)::in, - list(higher_order_arg)::in) is semidet. + list(higher_order_arg)::in, list(higher_order_arg)::out, + bool::out) is semidet. -higher_order_args_match([], []). -higher_order_args_match([Arg1 | Args1], [Arg2 | Args2]) :- - Arg1 = higher_order_arg(ConsId, ArgNo, NumArgs, - _, _, HOCurriedArgs1), - Arg2 = higher_order_arg(ConsId, ArgNo, NumArgs, +higher_order_args_match([], [], [], no). +higher_order_args_match([_ | _], [], [], yes). +higher_order_args_match([RequestArg | Args1], [VersionArg | Args2], + Args, PartialMatch) :- + RequestArg = higher_order_arg(ConsId1, ArgNo1, _, _, _, _), + VersionArg = higher_order_arg(ConsId2, ArgNo2, _, _, _, _), + + ( ArgNo1 = ArgNo2 -> + ConsId1 = ConsId2, + RequestArg = higher_order_arg(_, _, NumArgs, + CurriedArgs, CurriedArgTypes, HOCurriedArgs1), + VersionArg = higher_order_arg(_, _, NumArgs, _, _, HOCurriedArgs2), - higher_order_args_match(HOCurriedArgs1, HOCurriedArgs2), - higher_order_args_match(Args1, Args2). + higher_order_args_match(HOCurriedArgs1, HOCurriedArgs2, + NewHOCurriedArgs, PartialMatch), + higher_order_args_match(Args1, Args2, Args3, _), + NewRequestArg = higher_order_arg(ConsId1, ArgNo1, NumArgs, + CurriedArgs, CurriedArgTypes, NewHOCurriedArgs), + Args = [NewRequestArg | Args3] + ; + % type-info arguments present in the request may be missing + % from the version if we are doing user-guided type + % specialization. + % All of the arguments in the version must be + % present in the request for a match. + ArgNo1 < ArgNo2, + + % All the higher-order arguments must be present in the + % version otherwise we should create a new one. + ConsId1 \= pred_const(_, _), + PartialMatch = yes, + higher_order_args_match(Args1, [VersionArg | Args2], Args, _) + ). + + % Add the curried arguments of the higher-order terms to the + % argument list. The order here must match that generated by + % construct_higher_order_terms. +:- pred get_extra_arguments(list(higher_order_arg)::in, + list(prog_var)::in, list(prog_var)::out) is det. + +get_extra_arguments([], Args, Args). +get_extra_arguments([HOArg | HOArgs], Args0, Args) :- + HOArg = higher_order_arg(_, _, _, + CurriedArgs0, _, HOCurriedArgs), + get_extra_arguments(HOCurriedArgs, CurriedArgs0, CurriedArgs), + list__append(Args0, CurriedArgs, Args1), + get_extra_arguments(HOArgs, Args1, Args). % if the right argument of an assignment is a higher order % term with a known value, we need to add an entry for @@ -992,16 +1446,17 @@ higher_order_info_update_changed_status(Changed1, Info0, Info) :- %------------------------------------------------------------------------------- - % Interpret a call to `type_info_from_typeclass_info' or - % `superclass_from_typeclass_info'. Currently they both have - % the same definition. This should be kept in sync with - % compiler/polymorphism.m, library/private_builtin.m and - % runtime/mercury_type_info.h. + % Interpret a call to `type_info_from_typeclass_info', + % `superclass_from_typeclass_info' or + % `instance_constraint_from_typeclass_info'. + % This should be kept in sync with compiler/polymorphism.m, + % library/private_builtin.m and runtime/mercury_type_info.h. :- pred interpret_typeclass_info_manipulator(typeclass_info_manipulator::in, list(prog_var)::in, hlds_goal_expr::in, hlds_goal_expr::out, higher_order_info::in, higher_order_info::out) is det. -interpret_typeclass_info_manipulator(_, Args, Goal0, Goal, Info0, Info) :- +interpret_typeclass_info_manipulator(Manipulator, Args, + Goal0, Goal, Info0, Info) :- Info0 = info(PredVars0, _, _, _, _, _, ModuleInfo, _, _), ( Args = [TypeClassInfoVar, IndexVar, TypeInfoVar], @@ -1009,7 +1464,7 @@ interpret_typeclass_info_manipulator(_, Args, Goal0, Goal, Info0, Info) :- constant(_TypeClassInfoConsId, TypeClassInfoArgs)), map__search(PredVars0, IndexVar, - constant(int_const(Index), [])), + constant(int_const(Index0), [])), % Extract the number of class constraints on the instance % from the base_typeclass_info. @@ -1023,9 +1478,21 @@ interpret_typeclass_info_manipulator(_, Args, Goal0, Goal, Info0, Info) :- map__lookup(Instances, ClassId, InstanceDefns), list__index1_det(InstanceDefns, InstanceNum, InstanceDefn), InstanceDefn = hlds_instance_defn(_, _, Constraints, _,_,_,_,_), - list__length(Constraints, NumConstraints), - TypeInfoIndex is Index + NumConstraints, - list__index1_det(OtherVars, TypeInfoIndex, TypeInfoArg), + ( + Manipulator = type_info_from_typeclass_info, + list__length(Constraints, NumConstraints), + Index = Index0 + NumConstraints + ; + Manipulator = superclass_from_typeclass_info, + list__length(Constraints, NumConstraints), + % polymorphism.m adds the number of + % type_infos to the index. + Index = Index0 + NumConstraints + ; + Manipulator = instance_constraint_from_typeclass_info, + Index = Index0 + ), + list__index1_det(OtherVars, Index, TypeInfoArg), maybe_add_alias(TypeInfoVar, TypeInfoArg, Info0, Info), Uni = assign(TypeInfoVar, TypeInfoArg), in_mode(In), @@ -1096,70 +1563,100 @@ specialize_special_pred(Info0, CalledPred, _CalledProc, Args, % involving recursively building up lambda expressions % this can create ridiculous numbers of versions. :- pred filter_requests(ho_params::in, module_info::in, - set(request)::in, goal_sizes::in, list(request)::out) is det. + set(request)::in, goal_sizes::in, list(request)::out, + io__state::di, io__state::uo) is det. -filter_requests(Params, ModuleInfo, Requests0, GoalSizes, Requests) :- - Params = ho_params(_, _, MaxSize), - set__to_sorted_list(Requests0, Requests1), - list__filter(lambda([X::in] is semidet, ( - X = request(_, CalledPredProcId, _, _, _, _, _, _), - CalledPredProcId = proc(CalledPredId, - CalledProcId), - module_info_pred_info(ModuleInfo, - CalledPredId, PredInfo), - \+ pred_info_is_imported(PredInfo), - \+ ( - pred_info_is_pseudo_imported(PredInfo), - hlds_pred__in_in_unification_proc_id( - CalledProcId) - ), +filter_requests(Params, ModuleInfo, Requests0, GoalSizes, Requests) --> + { set__to_sorted_list(Requests0, Requests1) }, + filter_requests_2(Params, ModuleInfo, Requests1, GoalSizes, + [], Requests). + +:- pred filter_requests_2(ho_params::in, module_info::in, list(request)::in, + goal_sizes::in, list(request)::in, list(request)::out, + io__state::di, io__state::uo) is det. + +filter_requests_2(_, _, [], _, Requests, Requests) --> []. +filter_requests_2(Params, ModuleInfo, [Request | Requests0], + GoalSizes, FilteredRequests0, FilteredRequests) --> + { Params = ho_params(_, _, _, MaxSize, _) }, + { Request = request(_, CalledPredProcId, _, _, HOArgs, + _, _, _, IsUserTypeSpec) }, + { CalledPredProcId = proc(CalledPredId, _) }, + { module_info_pred_info(ModuleInfo, CalledPredId, PredInfo) }, + globals__io_lookup_bool_option(very_verbose, VeryVerbose), + { pred_info_module(PredInfo, PredModule) }, + { pred_info_name(PredInfo, PredName) }, + { pred_info_arity(PredInfo, Arity) }, + { pred_info_arg_types(PredInfo, Types) }, + { list__length(Types, ActualArity) }, + maybe_write_request(VeryVerbose, ModuleInfo, "% Request for", + qualified(PredModule, PredName), Arity, ActualArity, + no, HOArgs), + ( + { + % Ignore the size limit for user + % specified specializations. + IsUserTypeSpec = yes + ; map__search(GoalSizes, CalledPredId, GoalSize), - GoalSize =< MaxSize, - pred_info_name(PredInfo, PredName), - \+ ( + GoalSize =< MaxSize + } + -> + ( + \+ { % There are probably cleaner ways to check % if this is a specialised version. - string__sub_string_search(PredName, + string__sub_string_search(PredName, "__ho", Index), NumIndex is Index + 4, string__index(PredName, NumIndex, Digit), char__is_digit(Digit) - ) - )), - Requests1, Requests). + } + -> + { FilteredRequests1 = [Request | FilteredRequests0] } + ; + { FilteredRequests1 = FilteredRequests0 }, + maybe_write_string(VeryVerbose, + "% Not specializing (recursive specialization).\n") + ) + ; + { FilteredRequests1 = FilteredRequests0 }, + maybe_write_string(VeryVerbose, + "% Not specializing (goal too large).\n") + ), + filter_requests_2(Params, ModuleInfo, Requests0, GoalSizes, + FilteredRequests1, FilteredRequests). -:- pred create_new_preds(list(request)::in, new_preds::in, new_preds::out, - list(new_pred)::in, list(new_pred)::out, +:- pred create_new_preds(ho_params::in, list(request)::in, new_preds::in, + new_preds::out, list(new_pred)::in, list(new_pred)::out, set(pred_proc_id)::in, set(pred_proc_id)::out, int::in, int::out, module_info::in, module_info::out, io__state::di, io__state::uo) is det. -create_new_preds([], NewPreds, NewPreds, NewPredList, NewPredList, +create_new_preds(_, [], NewPreds, NewPreds, NewPredList, NewPredList, ToFix, ToFix, NextId, NextId, Mod, Mod, IO, IO). -create_new_preds([Request | Requests], NewPreds0, NewPreds, +create_new_preds(Params, [Request | Requests], NewPreds0, NewPreds, NewPredList0, NewPredList, PredsToFix0, PredsToFix, NextHOid0, NextHOid, Module0, Module, IO0, IO) :- Request = request(CallingPredProcId, CalledPredProcId, _HOArgs, - _CallArgs, _, _CallerArgTypes, _ExtraTypeInfoTypes, _), + _CallArgs, _, _CallerArgTypes, _ExtraTypeInfoTypes, _, _), set__insert(PredsToFix0, CallingPredProcId, PredsToFix1), ( NewPreds0 = new_preds(NewPredMap0, _), map__search(NewPredMap0, CalledPredProcId, SpecVersions0) -> - globals__io_lookup_bool_option(typeinfo_liveness, - TypeInfoLiveness, IO0, IO1), ( % check that we aren't redoing the same pred % SpecVersions are pred_proc_ids of the specialized % versions of the current pred. \+ ( set__member(Version, SpecVersions0), - version_matches(TypeInfoLiveness, Module0, - Request, Version, no, _) + version_matches(Params, Module0, + Request, no, Version, _) ) -> create_new_pred(Request, NewPred, NextHOid0, - NextHOid1, Module0, Module1, IO1, IO2), + NextHOid1, Module0, Module1, IO0, IO2), add_new_pred(CalledPredProcId, NewPred, NewPreds0, NewPreds1), NewPredList1 = [NewPred | NewPredList0] @@ -1167,7 +1664,7 @@ create_new_preds([Request | Requests], NewPreds0, NewPreds, Module1 = Module0, NewPredList1 = NewPredList0, NewPreds1 = NewPreds0, - IO2 = IO1, + IO2 = IO0, NextHOid1 = NextHOid0 ) ; @@ -1176,7 +1673,7 @@ create_new_preds([Request | Requests], NewPreds0, NewPreds, add_new_pred(CalledPredProcId, NewPred, NewPreds0, NewPreds1), NewPredList1 = [NewPred | NewPredList0] ), - create_new_preds(Requests, NewPreds1, NewPreds, NewPredList1, + create_new_preds(Params, Requests, NewPreds1, NewPreds, NewPredList1, NewPredList, PredsToFix1, PredsToFix, NextHOid1, NextHOid, Module1, Module, IO2, IO). @@ -1199,7 +1696,8 @@ add_new_pred(CalledPredProcId, NewPred, new_preds(NewPreds0, PredVars), create_new_pred(Request, NewPred, NextHOid0, NextHOid, ModuleInfo0, ModuleInfo, IOState0, IOState) :- Request = request(Caller, CalledPredProc, CallArgs, ExtraTypeInfoArgs, - HOArgs, ArgTypes, ExtraTypeInfoTypes, CallerTVarSet), + HOArgs, ArgTypes, ExtraTypeInfoTypes, + CallerTVarSet, IsUserTypeSpec), CalledPredProc = proc(CalledPred, _), module_info_get_predicate_table(ModuleInfo0, PredTable0), predicate_table_get_preds(PredTable0, Preds0), @@ -1211,32 +1709,42 @@ create_new_pred(Request, NewPred, NextHOid0, NextHOid, globals__io_lookup_bool_option(very_verbose, VeryVerbose, IOState0, IOState1), pred_info_arg_types(PredInfo0, ArgTVarSet, ExistQVars, Types), - string__int_to_string(Arity, ArStr), - ( - VeryVerbose = yes - -> - prog_out__sym_name_to_string(PredModule, PredModuleString), - io__write_strings(["% Specializing calls to `", - PredModuleString, ":", Name0, "'/", ArStr, - " with higher-order arguments:\n"], - IOState1, IOState2), - list__length(Types, ActualArity), - NumToDrop is ActualArity - Arity, - output_higher_order_args(ModuleInfo0, NumToDrop, - HOArgs, IOState2, IOState) + + ( IsUserTypeSpec = yes -> + % If this is a user-guided type specialisation, the + % new name comes from the name of the requesting predicate. + Caller = proc(CallerPredId, CallerProcId), + predicate_name(ModuleInfo0, CallerPredId, CallerName), + proc_id_to_int(CallerProcId, CallerProcInt), + string__int_to_string(CallerProcInt, CallerProcStr), + string__append_list([CallerName, "__ho", CallerProcStr], + PredName), + NextHOid = NextHOid0, + % For exported predicates the type specialization must + % be exported. + % For opt_imported predicates we only want to keep this + % version if we do some other useful specialization on it. + pred_info_import_status(PredInfo0, Status) ; - IOState = IOState1 - ), - string__int_to_string(NextHOid0, IdStr), - NextHOid is NextHOid0 + 1, - string__append_list([Name0, "__ho", IdStr], PredName), + string__int_to_string(NextHOid0, IdStr), + NextHOid is NextHOid0 + 1, + string__append_list([Name0, "__ho", IdStr], PredName), + Status = local + ), + + SymName = qualified(PredModule, PredName), + unqualify_name(SymName, NewName), + list__length(Types, ActualArity), + maybe_write_request(VeryVerbose, ModuleInfo, "% Specializing", + qualified(PredModule, Name0), Arity, ActualArity, + yes(NewName), HOArgs, IOState1, IOState), + pred_info_typevarset(PredInfo0, TypeVarSet), pred_info_context(PredInfo0, Context), pred_info_get_markers(PredInfo0, MarkerList), pred_info_get_goal_type(PredInfo0, GoalType), pred_info_get_class_context(PredInfo0, ClassContext), pred_info_get_aditi_owner(PredInfo0, Owner), - Name = qualified(PredModule, PredName), varset__init(EmptyVarSet), map__init(EmptyVarTypes), map__init(EmptyProofs), @@ -1245,8 +1753,8 @@ create_new_pred(Request, NewPred, NextHOid0, NextHOid, % hlds dumps if it's filled in. ClausesInfo = clauses_info(EmptyVarSet, EmptyVarTypes, EmptyVarTypes, [], []), - pred_info_init(PredModule, Name, Arity, ArgTVarSet, ExistQVars, - Types, true, Context, ClausesInfo, local, MarkerList, GoalType, + pred_info_init(PredModule, SymName, Arity, ArgTVarSet, ExistQVars, + Types, true, Context, ClausesInfo, Status, MarkerList, GoalType, PredOrFunc, ClassContext, EmptyProofs, Owner, PredInfo1), pred_info_set_typevarset(PredInfo1, TypeVarSet, PredInfo2), pred_info_procedures(PredInfo2, Procs0), @@ -1254,9 +1762,30 @@ create_new_pred(Request, NewPred, NextHOid0, NextHOid, predicate_table_insert(PredTable0, PredInfo2, NewPredId, PredTable), module_info_set_predicate_table(ModuleInfo0, PredTable, ModuleInfo), NewPred = new_pred(proc(NewPredId, NewProcId), CalledPredProc, Caller, - Name, HOArgs, CallArgs, ExtraTypeInfoArgs, ArgTypes, - ExtraTypeInfoTypes, CallerTVarSet). - + SymName, HOArgs, CallArgs, ExtraTypeInfoArgs, ArgTypes, + ExtraTypeInfoTypes, CallerTVarSet, IsUserTypeSpec). + +:- pred maybe_write_request(bool::in, module_info::in, string::in, + sym_name::in, arity::in, arity::in, maybe(string)::in, + list(higher_order_arg)::in, io__state::di, io__state::uo) is det. + +maybe_write_request(no, _, _, _, _, _, _, _) --> []. +maybe_write_request(yes, ModuleInfo, Msg, SymName, + Arity, ActualArity, MaybeNewName, HOArgs) --> + { prog_out__sym_name_to_string(SymName, OldName) }, + { string__int_to_string(Arity, ArStr) }, + io__write_strings([Msg, " `", OldName, "'/", ArStr]), + + ( { MaybeNewName = yes(NewName) } -> + io__write_string(" into "), + io__write_string(NewName) + ; + [] + ), + io__write_string(" with higher-order arguments:\n"), + { NumToDrop is ActualArity - Arity }, + output_higher_order_args(ModuleInfo, NumToDrop, HOArgs). + :- pred output_higher_order_args(module_info::in, int::in, list(higher_order_arg)::in, io__state::di, io__state::uo) is det. @@ -1275,9 +1804,20 @@ output_higher_order_args(ModuleInfo, NumToDrop, [HOArg | HOArgs]) --> io__write_string(Name), io__write_string("'/"), io__write_int(Arity) + ; { ConsId = type_ctor_info_const(TypeModule, TypeName, TypeArity) } -> + io__write_string(" type_ctor_info for `"), + prog_out__write_sym_name(qualified(TypeModule, TypeName)), + io__write_string("'/"), + io__write_int(TypeArity) + ; { ConsId = base_typeclass_info_const(_, ClassId, _, _) } -> + io__write_string(" base_typeclass_info for `"), + { ClassId = class_id(ClassName, ClassArity) }, + prog_out__write_sym_name(ClassName), + io__write_string("'/"), + io__write_int(ClassArity) ; % XXX output the type. - io__write_string(" type_info ") + io__write_string(" type_info/typeclass_info ") ), io__write_string(" with "), io__write_int(NumArgs), @@ -1301,17 +1841,18 @@ fixup_preds(Params, [PredProcId | PredProcIds], NewPreds, set__init(Requests0), Info0 = info(PredVars0, Requests0, NewPreds, PredProcId, PredInfo0, ProcInfo0, ModuleInfo0, Params, unchanged), - traverse_goal_0(Goal0, Goal1, Info0, _), - proc_info_varset(ProcInfo0, Varset0), - proc_info_headvars(ProcInfo0, HeadVars), - proc_info_vartypes(ProcInfo0, VarTypes0), + traverse_goal_0(Goal0, Goal1, Info0, Info), + Info = info(_, _, _, _, PredInfo1, ProcInfo1, _, _, _), + proc_info_varset(ProcInfo1, Varset0), + proc_info_headvars(ProcInfo1, HeadVars), + proc_info_vartypes(ProcInfo1, VarTypes0), implicitly_quantify_clause_body(HeadVars, Goal1, Varset0, VarTypes0, Goal, Varset, VarTypes, _), - proc_info_set_goal(ProcInfo0, Goal, ProcInfo1), proc_info_set_varset(ProcInfo1, Varset, ProcInfo2), - proc_info_set_vartypes(ProcInfo2, VarTypes, ProcInfo), + proc_info_set_vartypes(ProcInfo2, VarTypes, ProcInfo3), + proc_info_set_goal(ProcInfo3, Goal, ProcInfo), map__det_update(Procs0, ProcId, ProcInfo, Procs), - pred_info_set_procedures(PredInfo0, Procs, PredInfo), + pred_info_set_procedures(PredInfo1, Procs, PredInfo), map__det_update(Preds0, PredId, PredInfo, Preds), module_info_set_preds(ModuleInfo0, Preds, ModuleInfo1), fixup_preds(Params, PredProcIds, NewPreds, ModuleInfo1, ModuleInfo). @@ -1329,7 +1870,7 @@ create_specialized_versions(Params, [NewPred | NewPreds], NewPredMap0, ModuleInfo0, ModuleInfo) :- NewPred = new_pred(NewPredProcId, OldPredProcId, Caller, _Name, HOArgs0, CallArgs, ExtraTypeInfoArgs, CallerArgTypes0, - ExtraTypeInfoTypes0, _), + ExtraTypeInfoTypes0, _, _), OldPredProcId = proc(OldPredId, OldProcId), module_info_pred_proc_info(ModuleInfo0, OldPredId, OldProcId, @@ -1477,28 +2018,28 @@ create_specialized_versions(Params, [NewPred | NewPreds], NewPredMap0, % proc_info_goal(NewProcInfo7, Goal1), HOInfo0 = info(PredVars, Requests0, NewPredMap1, NewPredProcId, - NewPredInfo2, NewProcInfo6, ModuleInfo0, Params, unchanged), + NewPredInfo3, NewProcInfo7, ModuleInfo0, Params, unchanged), traverse_goal_0(Goal1, Goal2, HOInfo0, - info(_, Requests1,_,_,_,_,_,_,_)), + info(_, Requests1,_,_,NewPredInfo4, NewProcInfo8,_,_,_)), goal_size(Goal2, GoalSize), map__set(GoalSizes0, NewPredId, GoalSize, GoalSizes1), % % Requantify and recompute instmap deltas. % - proc_info_varset(NewProcInfo7, Varset7), - proc_info_vartypes(NewProcInfo7, VarTypes7), - implicitly_quantify_clause_body(HeadVars, Goal2, Varset7, VarTypes7, + proc_info_varset(NewProcInfo8, Varset8), + proc_info_vartypes(NewProcInfo8, VarTypes8), + implicitly_quantify_clause_body(HeadVars, Goal2, Varset8, VarTypes8, Goal3, Varset, VarTypes, _), - proc_info_get_initial_instmap(NewProcInfo3, ModuleInfo0, InstMap0), + proc_info_get_initial_instmap(NewProcInfo8, ModuleInfo0, InstMap0), recompute_instmap_delta(no, Goal3, Goal4, InstMap0, ModuleInfo0, ModuleInfo1), - proc_info_set_goal(NewProcInfo7, Goal4, NewProcInfo8), - proc_info_set_varset(NewProcInfo8, Varset, NewProcInfo9), - proc_info_set_vartypes(NewProcInfo9, VarTypes, NewProcInfo), + proc_info_set_goal(NewProcInfo8, Goal4, NewProcInfo9), + proc_info_set_varset(NewProcInfo9, Varset, NewProcInfo10), + proc_info_set_vartypes(NewProcInfo10, VarTypes, NewProcInfo), map__det_insert(NewProcs0, NewProcId, NewProcInfo, NewProcs), - pred_info_set_procedures(NewPredInfo3, NewProcs, NewPredInfo), + pred_info_set_procedures(NewPredInfo4, NewProcs, NewPredInfo), map__det_update(Preds0, NewPredId, NewPredInfo, Preds), predicate_table_set_preds(PredTable0, Preds, PredTable), module_info_set_predicate_table(ModuleInfo1, PredTable, ModuleInfo2), @@ -1581,8 +2122,8 @@ construct_higher_order_terms(ModuleInfo, HeadVars0, HeadVars, ArgModes0, list__append(ArgModes0, CurriedArgModes, ArgModes1), list__append(HeadVars0, NewHeadVars, HeadVars1), - construct_higher_order_terms(ModuleInfo, HeadVars1, HeadVars, ArgModes1, - ArgModes, HOArgs, ProcInfo2, ProcInfo, + construct_higher_order_terms(ModuleInfo, HeadVars1, HeadVars, + ArgModes1, ArgModes, HOArgs, ProcInfo2, ProcInfo, Renaming2, Renaming, PredVars2, PredVars). %-----------------------------------------------------------------------------% diff --git a/compiler/hlds_goal.m b/compiler/hlds_goal.m index 7f2703fad..6ef7bbe59 100644 --- a/compiler/hlds_goal.m +++ b/compiler/hlds_goal.m @@ -13,7 +13,7 @@ :- interface. :- import_module hlds_data, hlds_pred, llds, prog_data, (inst), instmap. -:- import_module list, set, map, std_util. +:- import_module char, list, set, map, std_util. % Here is how goals are represented @@ -715,12 +715,80 @@ get_pragma_c_var_names_2([MaybeName | MaybeNames], Names0, Names) :- :- pred goal_list_determinism(list(hlds_goal), determinism). :- mode goal_list_determinism(in, out) is det. + % + % Produce a goal to construct a given constant. + % These predicates all fill in the non-locals, instmap_delta + % and determinism fields of the goal_info of the returned goal. + % With alias tracking, the instmap_delta will be correct + % only if the variable being assigned to has no aliases. + % + +:- pred make_int_const_construction(prog_var, int, hlds_goal). +:- mode make_int_const_construction(in, in, out) is det. + +:- pred make_string_const_construction(prog_var, string, hlds_goal). +:- mode make_string_const_construction(in, in, out) is det. + +:- pred make_float_const_construction(prog_var, float, hlds_goal). +:- mode make_float_const_construction(in, in, out) is det. + +:- pred make_char_const_construction(prog_var, char, hlds_goal). +:- mode make_char_const_construction(in, in, out) is det. + +:- pred make_const_construction(prog_var, cons_id, hlds_goal). +:- mode make_const_construction(in, in, out) is det. + +:- pred make_int_const_construction(int, hlds_goal, prog_var, + map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset). +:- mode make_int_const_construction(in, out, out, in, out, in, out) is det. + +:- pred make_string_const_construction(string, hlds_goal, prog_var, + map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset). +:- mode make_string_const_construction(in, out, out, in, out, in, out) is det. + +:- pred make_float_const_construction(float, hlds_goal, prog_var, + map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset). +:- mode make_float_const_construction(in, out, out, in, out, in, out) is det. + +:- pred make_char_const_construction(char, hlds_goal, prog_var, + map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset). +:- mode make_char_const_construction(in, out, out, in, out, in, out) is det. + +:- pred make_const_construction(cons_id, (type), hlds_goal, prog_var, + map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset). +:- mode make_const_construction(in, in, out, out, in, out, in, out) is det. + +:- pred make_int_const_construction(int, hlds_goal, prog_var, + proc_info, proc_info). +:- mode make_int_const_construction(in, out, out, in, out) is det. + +:- pred make_string_const_construction(string, hlds_goal, prog_var, + proc_info, proc_info). +:- mode make_string_const_construction(in, out, out, in, out) is det. + +:- pred make_float_const_construction(float, hlds_goal, prog_var, + proc_info, proc_info). +:- mode make_float_const_construction(in, out, out, in, out) is det. + +:- pred make_char_const_construction(char, hlds_goal, prog_var, + proc_info, proc_info). +:- mode make_char_const_construction(in, out, out, in, out) is det. + +:- pred make_const_construction(cons_id, (type), hlds_goal, prog_var, + proc_info, proc_info). +:- mode make_const_construction(in, in, out, out, in, out) is det. + %-----------------------------------------------------------------------------% :- implementation. -:- import_module det_analysis, term. -:- import_module require. +:- import_module det_analysis, type_util. +:- import_module require, string, term, varset. goal_info_init(GoalInfo) :- Detism = erroneous, @@ -1032,5 +1100,82 @@ goal_list_determinism(Goals, Determinism) :- )), list__foldl(ComputeDeterminism, Goals, det, Determinism). +%-----------------------------------------------------------------------------% + +make_int_const_construction(Int, Goal, Var, ProcInfo0, ProcInfo) :- + proc_info_create_var_from_type(ProcInfo0, int_type, Var, ProcInfo), + make_int_const_construction(Var, Int, Goal). + +make_string_const_construction(String, Goal, Var, ProcInfo0, ProcInfo) :- + proc_info_create_var_from_type(ProcInfo0, string_type, Var, ProcInfo), + make_string_const_construction(Var, String, Goal). + +make_float_const_construction(Float, Goal, Var, ProcInfo0, ProcInfo) :- + proc_info_create_var_from_type(ProcInfo0, float_type, Var, ProcInfo), + make_float_const_construction(Var, Float, Goal). + +make_char_const_construction(Char, Goal, Var, ProcInfo0, ProcInfo) :- + proc_info_create_var_from_type(ProcInfo0, char_type, Var, ProcInfo), + make_char_const_construction(Var, Char, Goal). + +make_const_construction(ConsId, Type, Goal, Var, ProcInfo0, ProcInfo) :- + proc_info_create_var_from_type(ProcInfo0, Type, Var, ProcInfo), + make_const_construction(Var, ConsId, Goal). + +make_int_const_construction(Int, Goal, Var, VarTypes0, VarTypes, + VarSet0, VarSet) :- + varset__new_var(VarSet0, Var, VarSet), + map__det_insert(VarTypes0, Var, int_type, VarTypes), + make_int_const_construction(Var, Int, Goal). + +make_string_const_construction(String, Goal, Var, VarTypes0, VarTypes, + VarSet0, VarSet) :- + varset__new_var(VarSet0, Var, VarSet), + map__det_insert(VarTypes0, Var, string_type, VarTypes), + make_string_const_construction(Var, String, Goal). + +make_float_const_construction(Float, Goal, Var, VarTypes0, VarTypes, + VarSet0, VarSet) :- + varset__new_var(VarSet0, Var, VarSet), + map__det_insert(VarTypes0, Var, float_type, VarTypes), + make_float_const_construction(Var, Float, Goal). + +make_char_const_construction(Char, Goal, Var, VarTypes0, VarTypes, + VarSet0, VarSet) :- + varset__new_var(VarSet0, Var, VarSet), + map__det_insert(VarTypes0, Var, char_type, VarTypes), + make_char_const_construction(Var, Char, Goal). + +make_const_construction(ConsId, Type, Goal, Var, VarTypes0, VarTypes, + VarSet0, VarSet) :- + varset__new_var(VarSet0, Var, VarSet), + map__det_insert(VarTypes0, Var, Type, VarTypes), + make_const_construction(Var, ConsId, Goal). + +make_int_const_construction(Var, Int, Goal) :- + make_const_construction(Var, int_const(Int), Goal). + +make_string_const_construction(Var, String, Goal) :- + make_const_construction(Var, string_const(String), Goal). + +make_float_const_construction(Var, Float, Goal) :- + make_const_construction(Var, float_const(Float), Goal). + +make_char_const_construction(Var, Char, Goal) :- + string__char_to_string(Char, String), + make_const_construction(Var, cons(unqualified(String), 0), Goal). + +make_const_construction(Var, ConsId, Goal - GoalInfo) :- + RHS = functor(ConsId, []), + Inst = bound(unique, [functor(ConsId, [])]), + Mode = (free -> Inst) - (Inst -> Inst), + Unification = construct(Var, ConsId, [], []), + Context = unify_context(explicit, []), + Goal = unify(Var, RHS, Mode, Unification, Context), + set__singleton_set(NonLocals, Var), + instmap_delta_init_reachable(InstMapDelta0), + instmap_delta_insert(InstMapDelta0, Var, Inst, InstMapDelta), + goal_info_init(NonLocals, InstMapDelta, det, GoalInfo). + %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% diff --git a/compiler/hlds_module.m b/compiler/hlds_module.m index 0ac12bb0f..c89f1ecba 100644 --- a/compiler/hlds_module.m +++ b/compiler/hlds_module.m @@ -24,13 +24,13 @@ :- import_module hlds_pred, hlds_data, prog_data, unify_proc, special_pred. :- import_module globals, llds, continuation_info. -:- import_module relation, map, std_util, list, set. +:- import_module relation, map, std_util, list, set, multi_map. :- implementation. -:- import_module hlds_out, prog_out, prog_data, prog_util. +:- import_module hlds_out, prog_out, prog_util. :- import_module typecheck, modules. -:- import_module bool, require, int, string, set, multi_map. +:- import_module bool, require, int, string. %-----------------------------------------------------------------------------% @@ -83,10 +83,36 @@ hlds_type_defn % defn of type ). - % Various predicates for manipulating the module_info data structure % map from proc to a list of unused argument numbers. :- type unused_arg_info == map(pred_proc_id, list(int)). + % 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. +:- type type_spec_info + ---> type_spec_info( + set(pred_proc_id), % Procedures for which there are + % user-requested type specializations. + set(pred_id), % Set of procedures which need to be + % processed by higher_order.m to + % produce those specialized versions. + multi_map(pred_id, pred_id), + % Map from predicates for which the + % user requested a type specialization + % to the list of predicates which must + % be processed by higher_order.m to + % force the production of those + % versions. This is used by + % dead_proc_elim.m to avoid creating + % versions unnecessarily for versions + % in imported modules. + multi_map(pred_id, pragma_type) + % Type spec pragmas to be placed in + % the `.opt' file if a predicate + % becomes exported. + ). + % This field should be set to `do_aditi_compilation' if there % are local Aditi predicates. :- type do_aditi_compilation @@ -95,6 +121,8 @@ %-----------------------------------------------------------------------------% + % Various predicates for manipulating the module_info data structure + % Create an empty module_info for a given module name (and the % global options). @@ -266,6 +294,13 @@ :- pred module_info_set_do_aditi_compilation(module_info, module_info). :- mode module_info_set_do_aditi_compilation(in, out) is det. +:- pred module_info_type_spec_info(module_info, type_spec_info). +:- mode module_info_type_spec_info(in, out) is det. + +:- pred module_info_set_type_spec_info(module_info, + type_spec_info, module_info). +:- mode module_info_set_type_spec_info(in, in, out) is det. + %-----------------------------------------------------------------------------% :- pred module_info_preds(module_info, pred_table). @@ -450,6 +485,9 @@ do_aditi_compilation). :- mode module_sub_get_do_aditi_compilation(in, out) is det. +:- pred module_sub_get_type_spec_info(module_sub_info, type_spec_info). +:- mode module_sub_get_type_spec_info(in, out) is det. + :- pred module_sub_set_c_header_info(module_sub_info, c_header_info, module_sub_info). :- mode module_sub_set_c_header_info(in, in, out) is det. @@ -499,6 +537,10 @@ :- pred module_sub_set_do_aditi_compilation(module_sub_info, module_sub_info). :- mode module_sub_set_do_aditi_compilation(in, out) is det. +:- pred module_sub_set_type_spec_info(module_sub_info, + type_spec_info, module_sub_info). +:- mode module_sub_set_type_spec_info(in, in, out) is det. + :- type module_info ---> module( module_sub_info, @@ -547,9 +589,12 @@ set(module_specifier), % All the imported module specifiers % (used during type checking). - do_aditi_compilation + do_aditi_compilation, % are there any local Aditi predicates % for which Aditi-RL must be produced. + type_spec_info + % data used for user-guided type + % specialization. ). % A predicate which creates an empty module @@ -565,13 +610,21 @@ module_info_init(Name, Globals, ModuleInfo) :- map__init(Ctors), set__init(StratPreds), map__init(UnusedArgInfo), + + set__init(TypeSpecPreds), + set__init(TypeSpecForcePreds), + map__init(SpecMap), + map__init(PragmaMap), + TypeSpecInfo = type_spec_info(TypeSpecPreds, + TypeSpecForcePreds, SpecMap, PragmaMap), + map__init(ClassTable), map__init(InstanceTable), map__init(SuperClassTable), set__init(ModuleNames), ModuleSubInfo = module_sub(Name, Globals, [], [], no, 0, 0, [], [], [], StratPreds, UnusedArgInfo, 0, ModuleNames, - no_aditi_compilation), + no_aditi_compilation, TypeSpecInfo), ModuleInfo = module(ModuleSubInfo, PredicateTable, Requests, UnifyPredMap, GlobalData, Types, Insts, Modes, Ctors, ClassTable, SuperClassTable, InstanceTable, 0). @@ -609,6 +662,7 @@ module_info_init(Name, Globals, ModuleInfo) :- % O do_aditi_compilation % % are there any local Aditi predicates % % for which Aditi-RL must be produced. +% P type_spec_info % ). %-----------------------------------------------------------------------------% @@ -616,110 +670,117 @@ module_info_init(Name, Globals, ModuleInfo) :- % Various predicates which access the module_sub_info data structure. module_sub_get_name(MI0, A) :- - MI0 = module_sub(A, _, _, _, _, _, _, _, _, _, _, _, _, _, _). + MI0 = module_sub(A, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _). module_sub_get_globals(MI0, B) :- - MI0 = module_sub(_, B, _, _, _, _, _, _, _, _, _, _, _, _, _). + MI0 = module_sub(_, B, _, _, _, _, _, _, _, _, _, _, _, _, _, _). module_sub_get_c_header_info(MI0, C) :- - MI0 = module_sub(_, _, C, _, _, _, _, _, _, _, _, _, _, _, _). + MI0 = module_sub(_, _, C, _, _, _, _, _, _, _, _, _, _, _, _, _). module_sub_get_c_body_info(MI0, D) :- - MI0 = module_sub(_, _, _, D, _, _, _, _, _, _, _, _, _, _, _). + MI0 = module_sub(_, _, _, D, _, _, _, _, _, _, _, _, _, _, _, _). module_sub_get_maybe_dependency_info(MI0, E) :- - MI0 = module_sub(_, _, _, _, E, _, _, _, _, _, _, _, _, _, _). + MI0 = module_sub(_, _, _, _, E, _, _, _, _, _, _, _, _, _, _, _). module_sub_get_num_errors(MI0, F) :- - MI0 = module_sub(_, _, _, _, _, F, _, _, _, _, _, _, _, _, _). + MI0 = module_sub(_, _, _, _, _, F, _, _, _, _, _, _, _, _, _, _). module_sub_get_lambda_count(MI0, G) :- - MI0 = module_sub(_, _, _, _, _, _, G, _, _, _, _, _, _, _, _). + MI0 = module_sub(_, _, _, _, _, _, G, _, _, _, _, _, _, _, _, _). module_sub_get_pragma_exported_procs(MI0, H) :- - MI0 = module_sub(_, _, _, _, _, _, _, H, _, _, _, _, _, _, _). + MI0 = module_sub(_, _, _, _, _, _, _, H, _, _, _, _, _, _, _, _). module_sub_get_base_gen_infos(MI0, I) :- - MI0 = module_sub(_, _, _, _, _, _, _, _, I, _, _, _, _, _, _). + MI0 = module_sub(_, _, _, _, _, _, _, _, I, _, _, _, _, _, _, _). module_sub_get_base_gen_layouts(MI0, J) :- - MI0 = module_sub(_, _, _, _, _, _, _, _, _, J, _, _, _, _, _). + MI0 = module_sub(_, _, _, _, _, _, _, _, _, J, _, _, _, _, _, _). module_sub_get_stratified_preds(MI0, K) :- - MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, K, _, _, _, _). + MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, K, _, _, _, _, _). module_sub_get_unused_arg_info(MI0, L) :- - MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, L, _, _, _). + MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, L, _, _, _, _). module_sub_get_model_non_pragma_count(MI0, M) :- - MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, M, _, _). + MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, M, _, _, _). module_sub_get_imported_module_specifiers(MI0, N) :- - MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, _, N, _). + MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, _, N, _, _). module_sub_get_do_aditi_compilation(MI0, O) :- - MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, _, _, O). + MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, _, _, O, _). + +module_sub_get_type_spec_info(MI0, P) :- + MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, P). %-----------------------------------------------------------------------------% % Various predicates which modify the module_sub_info data structure. module_sub_set_globals(MI0, B, MI) :- - MI0 = module_sub(A, _, C, D, E, F, G, H, I, J, K, L, M, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, _, C, D, E, F, G, H, I, J, K, L, M, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_c_header_info(MI0, C, MI) :- - MI0 = module_sub(A, B, _, D, E, F, G, H, I, J, K, L, M, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, _, D, E, F, G, H, I, J, K, L, M, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_c_body_info(MI0, D, MI) :- - MI0 = module_sub(A, B, C, _, E, F, G, H, I, J, K, L, M, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, C, _, E, F, G, H, I, J, K, L, M, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_maybe_dependency_info(MI0, E, MI) :- - MI0 = module_sub(A, B, C, D, _, F, G, H, I, J, K, L, M, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, C, D, _, F, G, H, I, J, K, L, M, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_num_errors(MI0, F, MI) :- - MI0 = module_sub(A, B, C, D, E, _, G, H, I, J, K, L, M, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, C, D, E, _, G, H, I, J, K, L, M, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_lambda_count(MI0, G, MI) :- - MI0 = module_sub(A, B, C, D, E, F, _, H, I, J, K, L, M, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, C, D, E, F, _, H, I, J, K, L, M, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_pragma_exported_procs(MI0, H, MI) :- - MI0 = module_sub(A, B, C, D, E, F, G, _, I, J, K, L, M, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, C, D, E, F, G, _, I, J, K, L, M, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_base_gen_infos(MI0, I, MI) :- - MI0 = module_sub(A, B, C, D, E, F, G, H, _, J, K, L, M, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, C, D, E, F, G, H, _, J, K, L, M, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_base_gen_layouts(MI0, J, MI) :- - MI0 = module_sub(A, B, C, D, E, F, G, H, I, _, K, L, M, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, C, D, E, F, G, H, I, _, K, L, M, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_stratified_preds(MI0, K, MI) :- - MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, _, L, M, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, _, L, M, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_unused_arg_info(MI0, L, MI) :- - MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, _, M, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, _, M, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_model_non_pragma_count(MI0, M, MI) :- - MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, _, N, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, _, N, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_imported_module_specifiers(MI0, N, MI) :- - MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, _, O), - MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O). + MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, _, O, P), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). module_sub_set_do_aditi_compilation(MI0, MI) :- - MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, _), + MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, _, P), MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, - do_aditi_compilation). + do_aditi_compilation, P). + +module_sub_set_type_spec_info(MI0, P, MI) :- + MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, _), + MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P). %-----------------------------------------------------------------------------% @@ -903,6 +964,10 @@ module_info_get_imported_module_specifiers(MI0, N) :- module_info_get_sub_info(MI0, MS0), module_sub_get_imported_module_specifiers(MS0, N). +module_info_type_spec_info(MI0, P) :- + module_info_get_sub_info(MI0, MS0), + module_sub_get_type_spec_info(MS0, P). + module_info_get_do_aditi_compilation(MI0, O) :- module_info_get_sub_info(MI0, MS0), module_sub_get_do_aditi_compilation(MS0, O). @@ -984,6 +1049,11 @@ module_info_set_do_aditi_compilation(MI0, MI) :- module_sub_set_do_aditi_compilation(MS0, MS), module_info_set_sub_info(MI0, MS, MI). +module_info_set_type_spec_info(MI0, P, MI) :- + module_info_get_sub_info(MI0, MS0), + module_sub_set_type_spec_info(MS0, P, MS), + module_info_set_sub_info(MI0, MS, MI). + %-----------------------------------------------------------------------------% % Various predicates which do simple things that are nevertheless diff --git a/compiler/intermod.m b/compiler/intermod.m index 2473cfcaf..4f64beae5 100644 --- a/compiler/intermod.m +++ b/compiler/intermod.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1996-1998 The University of Melbourne. +% Copyright (C) 1996-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -60,8 +60,8 @@ :- implementation. -:- import_module assoc_list, dir, getopt, int, list, map, require, set. -:- import_module std_util, string. +:- import_module assoc_list, dir, getopt, int, list, map, multi_map, require. +:- import_module set, std_util, string, term, varset. :- import_module code_util, globals, goal_util, term, varset. :- import_module hlds_data, hlds_goal, hlds_pred, hlds_out, inlining, llds. @@ -167,6 +167,8 @@ intermod__gather_preds([PredId | PredIds], CollectTypes, intermod_info_get_module_info(ModuleInfo0), { module_info_preds(ModuleInfo0, PredTable0) }, { map__lookup(PredTable0, PredId, PredInfo0) }, + { module_info_type_spec_info(ModuleInfo0, TypeSpecInfo) }, + { TypeSpecInfo = type_spec_info(_, TypeSpecForcePreds, _, _) }, ( % % note: we can't include exported_to_submodules predicates @@ -183,6 +185,9 @@ intermod__gather_preds([PredId | PredIds], CollectTypes, % recreated in the importing module anyway. { \+ code_util__compiler_generated(PredInfo0) }, { \+ code_util__predinfo_is_builtin(PredInfo0) }, + + % These will be recreated in the importing module. + { \+ set__member(PredId, TypeSpecForcePreds) }, ( { inlining__is_simple_goal(Goal, InlineThreshold) }, @@ -1010,6 +1015,8 @@ intermod__write_pred_decls(ModuleInfo, [PredId | PredIds]) --> { list__sort(CompareProcId, ProcIds, SortedProcIds) }, intermod__write_pred_modes(Procs, qualified(Module, Name), PredOrFunc, SortedProcIds), + intermod__write_pragmas(PredInfo), + intermod__write_type_spec_pragmas(ModuleInfo, PredId), intermod__write_pred_decls(ModuleInfo, PredIds). :- pred intermod__write_pred_modes(map(proc_id, proc_info)::in, @@ -1048,15 +1055,14 @@ intermod__write_pred_modes(Procs, SymName, PredOrFunc, [ProcId | ProcIds]) --> intermod__write_preds(_, []) --> []. intermod__write_preds(ModuleInfo, [PredId | PredIds]) --> { module_info_pred_info(ModuleInfo, PredId, PredInfo) }, - { pred_info_arg_types(PredInfo, ArgTypes) }, - { list__length(ArgTypes, Arity) }, { pred_info_module(PredInfo, Module) }, { pred_info_name(PredInfo, Name) }, { SymName = qualified(Module, Name) }, - { pred_info_get_markers(PredInfo, Markers) }, - { markers_to_marker_list(Markers, MarkerList) }, { pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) }, - intermod__write_pragmas(SymName, Arity, MarkerList, PredOrFunc), + intermod__write_pragmas(PredInfo), + % The type specialization pragmas for exported preds should + % already be in the interface file. + { pred_info_clauses_info(PredInfo, ClausesInfo) }, { ClausesInfo = clauses_info(Varset, _, _VarTypes, HeadVars, Clauses) }, % handle pragma c_code(...) separately @@ -1072,6 +1078,20 @@ intermod__write_preds(ModuleInfo, [PredId | PredIds]) --> ), intermod__write_preds(ModuleInfo, PredIds). + +:- pred intermod__write_pragmas(pred_info::in, + io__state::di, io__state::uo) is det. + +intermod__write_pragmas(PredInfo) --> + { pred_info_module(PredInfo, Module) }, + { pred_info_name(PredInfo, Name) }, + { pred_info_arity(PredInfo, Arity) }, + { SymName = qualified(Module, Name) }, + { pred_info_get_markers(PredInfo, Markers) }, + { markers_to_marker_list(Markers, MarkerList) }, + { pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) }, + intermod__write_pragmas(SymName, Arity, MarkerList, PredOrFunc). + :- pred intermod__write_pragmas(sym_name::in, int::in, list(marker)::in, pred_or_func::in, io__state::di, io__state::uo) is det. @@ -1086,6 +1106,21 @@ intermod__write_pragmas(SymName, Arity, [Marker | Markers], PredOrFunc) --> ), intermod__write_pragmas(SymName, Arity, Markers, PredOrFunc). +:- pred intermod__write_type_spec_pragmas(module_info::in, pred_id::in, + io__state::di, io__state::uo) is det. + +intermod__write_type_spec_pragmas(ModuleInfo, PredId) --> + { module_info_type_spec_info(ModuleInfo, + type_spec_info(_, _, _, PragmaMap)) }, + ( { multi_map__search(PragmaMap, PredId, TypeSpecPragmas) } -> + { term__context_init(Context) }, + list__foldl(lambda([Pragma::in, IO0::di, IO::uo] is det, ( + mercury_output_item(pragma(Pragma), Context, IO0, IO) + )), TypeSpecPragmas) + ; + [] + ). + % Is a pragma declaration required in the `.opt' file for % a predicate with the given marker. :- pred intermod__should_output_marker(marker::in, bool::out) is det. diff --git a/compiler/make_hlds.m b/compiler/make_hlds.m index f42207559..e4aa407d3 100644 --- a/compiler/make_hlds.m +++ b/compiler/make_hlds.m @@ -401,8 +401,13 @@ add_item_decl_pass_2(pragma(Pragma), Context, Status, Module0, Status, Module) ; add_pragma_unused_args(PredOrFunc, SymName, Arity, ProcId, UnusedArgs, Context, Module0, Module) - ) + ; + { Pragma = type_spec(Name, SpecName, Arity, PorF, + MaybeModes, TypeSubst, VarSet) }, + add_pragma_type_spec(Pragma, Name, SpecName, Arity, PorF, + MaybeModes, TypeSubst, VarSet, + Context, Module0, Module) ; % Handle pragma fact_table decls later on (when we process % clauses). @@ -776,6 +781,380 @@ add_pragma_unused_args(PredOrFunc, SymName, Arity, ProcId, UnusedArgs, Context, %-----------------------------------------------------------------------------% +:- pred add_pragma_type_spec(pragma_type, sym_name, sym_name, arity, + maybe(pred_or_func), maybe(list(mode)), assoc_list(tvar, type), + tvarset, term__context, module_info, module_info, + io__state, io__state). +:- mode add_pragma_type_spec(in, in, in, in, in, in, in, + in, in, in, out, di, uo) is det. + +add_pragma_type_spec(Pragma, SymName, SpecName, Arity, MaybePredOrFunc, + MaybeModes, SpecSubst, VarSet, Context, Module0, Module) --> + { module_info_get_predicate_table(Module0, Preds) }, + ( + { MaybePredOrFunc = yes(PredOrFunc) -> + predicate_table_search_pf_sym_arity(Preds, + PredOrFunc, SymName, Arity, PredIds) + ; + predicate_table_search_sym_arity(Preds, + SymName, Arity, PredIds) + }, + { PredIds \= [] } + -> + list__foldl2(add_pragma_type_spec_2(Pragma, SymName, SpecName, + Arity, SpecSubst, MaybeModes, VarSet, Context), + PredIds, Module0, Module) + ; + undefined_pred_or_func_error(SymName, Arity, Context, + "`:- pragma type_spec' declaration"), + { module_info_incr_errors(Module0, Module) } + ). + +:- pred add_pragma_type_spec_2(pragma_type, sym_name, sym_name, arity, + assoc_list(tvar, type), maybe(list(mode)), tvarset, + prog_context, pred_id, module_info, module_info, io__state, io__state). +:- mode add_pragma_type_spec_2(in, in, in, in, in, in, in, in, + in, in, out, di, uo) is det. + +add_pragma_type_spec_2(Pragma, SymName, SpecName, Arity, + Subst, MaybeModes, TVarSet0, Context, PredId, + ModuleInfo0, ModuleInfo) --> + { module_info_pred_info(ModuleInfo0, PredId, PredInfo0) }, + handle_pragma_type_spec_subst(Context, Subst, TVarSet0, PredInfo0, + TVarSet, Types, ExistQVars, ClassContext, SubstOk, + ModuleInfo0, ModuleInfo1), + ( { SubstOk = yes } -> + { pred_info_procedures(PredInfo0, Procs0) }, + handle_pragma_type_spec_modes(SymName, Arity, Context, + MaybeModes, ProcIds, Procs0, Procs, ModesOk, + ModuleInfo1, ModuleInfo2), + globals__io_lookup_bool_option(user_guided_type_specialization, + DoTypeSpec), + { + ModesOk = yes, + % Even if we aren't doing type specialization, we need + % to create the interface procedures for local predicates + % to check the type-class correctness of the requested + % specializations. + ( DoTypeSpec = yes + ; \+ pred_info_is_imported(PredInfo0) + ) + -> + % + % Build a clause to call the old predicate with the + % specified types to force the specialization. For imported + % predicates this forces the creation of the proper interface. + % + varset__init(ArgVarSet0), + varset__new_vars(ArgVarSet0, Arity, Args, ArgVarSet), + map__from_corresponding_lists(Args, Types, VarTypes0), + goal_info_init(GoalInfo0), + set__list_to_set(Args, NonLocals), + goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo1), + goal_info_set_context(GoalInfo1, Context, GoalInfo), + invalid_proc_id(DummyProcId), + Goal = call(PredId, DummyProcId, Args, + not_builtin, no, SymName) - GoalInfo, + Clause = clause(ProcIds, Goal, Context), + Clauses = clauses_info(ArgVarSet, VarTypes0, + VarTypes0, Args, [Clause]), + pred_info_get_markers(PredInfo0, Markers), + map__init(Proofs), + ( pred_info_is_imported(PredInfo0) -> + Status = opt_imported + ; + pred_info_import_status(PredInfo0, Status) + ), + + pred_info_module(PredInfo0, ModuleName), + pred_info_get_aditi_owner(PredInfo0, Owner), + pred_info_get_is_pred_or_func(PredInfo0, PredOrFunc), + pred_info_init(ModuleName, SpecName, Arity, TVarSet, + ExistQVars, Types, true, Context, Clauses, + Status, Markers, none, PredOrFunc, + ClassContext, Proofs, Owner, NewPredInfo0), + pred_info_set_procedures(NewPredInfo0, + Procs, NewPredInfo), + module_info_get_predicate_table(ModuleInfo2, PredTable0), + predicate_table_insert(PredTable0, NewPredInfo, + must_be_qualified, NewPredId, PredTable), + module_info_set_predicate_table(ModuleInfo2, + PredTable, ModuleInfo3), + + % + % Record the type specialisation in the module_info. + % + module_info_type_spec_info(ModuleInfo3, TypeSpecInfo0), + TypeSpecInfo0 = type_spec_info(ProcsToSpec0, + ForceVersions0, SpecMap0, PragmaMap0), + list__map(lambda([ProcId::in, PredProcId::out] is det, ( + PredProcId = proc(PredId, ProcId) + )), ProcIds, PredProcIds), + set__insert_list(ProcsToSpec0, PredProcIds, ProcsToSpec), + set__insert(ForceVersions0, NewPredId, ForceVersions), + + ( Status = opt_imported -> + % For imported predicates dead_proc_elim.m needs + % to know that if the original predicate is used, + % the predicate to force the production of the + % specialised interface is also used. + multi_map__set(SpecMap0, PredId, NewPredId, SpecMap) + ; + SpecMap = SpecMap0 + ), + + multi_map__set(PragmaMap0, PredId, Pragma, PragmaMap), + TypeSpecInfo = type_spec_info(ProcsToSpec, + ForceVersions, SpecMap, PragmaMap), + module_info_set_type_spec_info(ModuleInfo3, + TypeSpecInfo, ModuleInfo) + ; + ModuleInfo = ModuleInfo2 + } + ; + { ModuleInfo = ModuleInfo1 } + ). + + % Check that the type substitution for a `:- pragma type_spec' + % declaration is valid. + % A type substitution is invalid if: + % - it substitutes unknown type variables + % - it substitutes existentially quantified type variables + % Type substitutions are also invalid if the replacement types are + % not ground, however this is a (hopefully temporary) limitation + % of the current implementation, so it only results in a warning. +:- pred handle_pragma_type_spec_subst(prog_context, assoc_list(tvar, type), + tvarset, pred_info, tvarset, list(type), existq_tvars, + class_constraints, bool, module_info, module_info, + io__state, io__state). +:- mode handle_pragma_type_spec_subst(in, in, in, in, out, out, out, out, out, + in, out, di, uo) is det. + +handle_pragma_type_spec_subst(Context, Subst, TVarSet0, PredInfo0, + TVarSet, Types, ExistQVars, ClassContext, SubstOk, + ModuleInfo0, ModuleInfo) --> + ( { Subst = [] } -> + { error("handle_pragma_type_spec_subst: empty substitution") } + ; + { pred_info_typevarset(PredInfo0, CalledTVarSet) }, + { varset__create_name_var_map(CalledTVarSet, NameVarIndex0) }, + { assoc_list__keys(Subst, VarsToSub) }, + { list__filter(lambda([Var::in] is semidet, ( + varset__lookup_name(TVarSet0, Var, VarName), + \+ map__contains(NameVarIndex0, VarName) + )), VarsToSub, UnknownVarsToSub) }, + ( { UnknownVarsToSub = [] } -> + % Check that the substitution makes all types involved + % ground. This is not strictly necessary, but handling + % this case with --typeinfo-liveness is tricky (to get the + % order of any extra typeclass_infos right), and it probably + % isn't very useful. If this restriction is removed later, + % remember to report an error for recursive substitutions. + { map__init(TVarRenaming0) }, + { assoc_list__values(Subst, SubstTypes) }, + { list__filter(lambda([SubstType::in] is semidet, ( + \+ term__is_ground(SubstType) + )), SubstTypes, NonGroundTypes) }, + + ( { NonGroundTypes = [] } -> + { get_new_tvars(VarsToSub, TVarSet0, CalledTVarSet, + TVarSet, NameVarIndex0, _, + TVarRenaming0, TVarRenaming) }, + + % Check that none of the existentially quantified + % variables were substituted. + { map__apply_to_list(VarsToSub, TVarRenaming, + RenamedVars) }, + { pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars) }, + { list__filter(lambda([RenamedVar::in] is semidet, ( + list__member(RenamedVar, ExistQVars) + )), RenamedVars, SubExistQVars) }, + ( { SubExistQVars = [] } -> + { + map__apply_to_list(VarsToSub, TVarRenaming, + RenamedVarsToSub), + map__init(TypeSubst0), + assoc_list__from_corresponding_lists(RenamedVarsToSub, + SubstTypes, SubAL), + list__foldl( + lambda([(TVar - Type)::in, TSubst0::in, + TSubst::out] is det, ( + map__set(TSubst0, TVar, Type, TSubst) + )), SubAL, TypeSubst0, TypeSubst), + + % Apply the substitution. + pred_info_arg_types(PredInfo0, Types0), + pred_info_get_class_context(PredInfo0, + ClassContext0), + term__apply_rec_substitution_to_list(Types0, + TypeSubst, Types), + apply_rec_subst_to_constraints(TypeSubst, + ClassContext0, ClassContext), + SubstOk = yes, + ModuleInfo = ModuleInfo0 + } + ; + report_subst_existq_tvars(PredInfo0, Context, + SubExistQVars), + io__set_exit_status(1), + { module_info_incr_errors(ModuleInfo0, ModuleInfo) }, + { Types = [] }, + { ClassContext = constraints([], []) }, + { SubstOk = no } + ) + ; + report_non_ground_subst(PredInfo0, Context), + globals__io_lookup_bool_option(halt_at_warn, Halt), + ( { Halt = yes } -> + { module_info_incr_errors(ModuleInfo0, ModuleInfo) }, + io__set_exit_status(1) + ; + { ModuleInfo = ModuleInfo0 } + ), + { ExistQVars = [] }, + { Types = [] }, + { ClassContext = constraints([], []) }, + { varset__init(TVarSet) }, + { SubstOk = no } + ) + ; + report_unknown_vars_to_subst(PredInfo0, Context, + TVarSet0, UnknownVarsToSub), + { module_info_incr_errors(ModuleInfo0, ModuleInfo) }, + io__set_exit_status(1), + { ExistQVars = [] }, + { Types = [] }, + { ClassContext = constraints([], []) }, + { varset__init(TVarSet) }, + { SubstOk = no } + ) + ). + +:- pred report_subst_existq_tvars(pred_info, prog_context, + list(tvar), io__state, io__state). +:- mode report_subst_existq_tvars(in, in, in, di, uo) is det. + +report_subst_existq_tvars(PredInfo0, Context, SubExistQVars) --> + report_pragma_type_spec(PredInfo0, Context), + prog_out__write_context(Context), + io__write_string(" error: the substitution includes the existentially\n"), + prog_out__write_context(Context), + io__write_string(" quantified type "), + { pred_info_typevarset(PredInfo0, TVarSet) }, + report_variables(SubExistQVars, TVarSet), + io__write_string(".\n"). + +:- pred report_non_ground_subst(pred_info, prog_context, + io__state, io__state). +:- mode report_non_ground_subst(in, in, di, uo) is det. + +report_non_ground_subst(PredInfo0, Context) --> + report_pragma_type_spec(PredInfo0, Context), + prog_out__write_context(Context), + io__write_string( + " warning: the substitution does not make the substituted\n"), + prog_out__write_context(Context), + io__write_string(" types ground. The declaration will be ignored.\n"), + prog_out__write_context(Context), + io__write_string( + " This is a limitation of the current implementation\n"), + prog_out__write_context(Context), + io__write_string(" which may be removed in a future release.\n"). + +:- pred report_unknown_vars_to_subst(pred_info, prog_context, tvarset, + list(tvar), io__state, io__state). +:- mode report_unknown_vars_to_subst(in, in, in, in, di, uo) is det. + +report_unknown_vars_to_subst(PredInfo0, Context, TVarSet, RecursiveVars) --> + report_pragma_type_spec(PredInfo0, Context), + prog_out__write_context(Context), + io__write_string(" error: "), + report_variables(RecursiveVars, TVarSet), + ( { RecursiveVars = [_] } -> + io__write_string(" does not ") + ; + io__write_string(" do not ") + ), + { pred_info_get_is_pred_or_func(PredInfo0, PredOrFunc) }, + ( + { PredOrFunc = predicate }, + { Decl = "`:- pred'" } + ; + { PredOrFunc = function }, + { Decl = "`:- func'" } + ), + io__write_string("occur in the "), + io__write_string(Decl), + io__write_string(" declaration.\n"). + +:- pred report_pragma_type_spec(pred_info, term__context, + io__state, io__state). +:- mode report_pragma_type_spec(in, in, di, uo) is det. + +report_pragma_type_spec(PredInfo0, Context) --> + { pred_info_module(PredInfo0, Module) }, + { pred_info_name(PredInfo0, Name) }, + { pred_info_arity(PredInfo0, Arity) }, + { pred_info_get_is_pred_or_func(PredInfo0, PredOrFunc) }, + prog_out__write_context(Context), + io__write_string("In `:- pragma type_spec' declaration for "), + hlds_out__write_call_id(PredOrFunc, qualified(Module, Name)/Arity), + io__write_string(":\n"). + +:- pred report_variables(list(tvar), tvarset, io__state, io__state). +:- mode report_variables(in, in, di, uo) is det. + +report_variables(SubExistQVars, VarSet) --> + ( { SubExistQVars = [_] } -> + io__write_string("variable `") + ; + io__write_string("variables `") + ), + mercury_output_vars(SubExistQVars, VarSet, no), + io__write_string("'"). + + % Check that the mode list for a `:- pragma type_spec' declaration + % specifies a known procedure. +:- pred handle_pragma_type_spec_modes(sym_name, arity, + prog_context, maybe(list(mode)), list(proc_id), + proc_table, proc_table, bool, module_info, module_info, + io__state, io__state). +:- mode handle_pragma_type_spec_modes(in, in, in, in, out, in, out, + out, in, out, di, uo) is det. + +handle_pragma_type_spec_modes(SymName, Arity, Context, MaybeModes, ProcIds, + Procs0, Procs, ModesOk, ModuleInfo0, ModuleInfo) --> + ( { MaybeModes = yes(Modes) } -> + { map__to_assoc_list(Procs0, ExistingProcs) }, + ( + { get_procedure_matching_argmodes(ExistingProcs, + Modes, ModuleInfo0, ProcId) } + -> + { map__lookup(Procs0, ProcId, ProcInfo) }, + { map__init(Procs1) }, + { hlds_pred__initial_proc_id(NewProcId) }, + { map__det_insert(Procs1, NewProcId, + ProcInfo, Procs) }, + { ProcIds = [ProcId] }, + { ModesOk = yes }, + { ModuleInfo = ModuleInfo0 } + ; + { ProcIds = [] }, + { Procs = Procs0 }, + { module_info_incr_errors(ModuleInfo0, ModuleInfo) }, + undefined_mode_error(SymName, Arity, Context, + "`:- pragma type_spec' declaration"), + { ModesOk = no } + ) + ; + { Procs = Procs0 }, + { map__keys(Procs, ProcIds) }, + { ModesOk = yes }, + { ModuleInfo = ModuleInfo0 } + ). + +%-----------------------------------------------------------------------------% + :- pred add_pragma_termination_info(pred_or_func, sym_name, list(mode), maybe(arg_size_info), maybe(termination_info), prog_context, module_info, module_info, io__state, io__state). @@ -949,7 +1328,7 @@ check_index_attribute(Name, Arity, Context, Attr) --> ; prog_out__write_context(Context), io__write_string( - "In `:- pragma aditi_index(...)' declaration for `"), + "In `:- pragma aditi_index' declaration for `"), hlds_out__write_pred_call_id(Name/Arity), io__write_string("':\n"), prog_out__write_context(Context), @@ -974,7 +1353,7 @@ check_index_attribute_pred(ModuleInfo, Name, Arity, Context, Attrs, PredId) --> ; prog_out__write_context(Context), io__write_string( - "Error: `:- pragma aditi_index(...)' declaration"), + "Error: `:- pragma aditi_index' declaration"), io__nl, prog_out__write_context(Context), io__write_string(" for "), @@ -982,7 +1361,7 @@ check_index_attribute_pred(ModuleInfo, Name, Arity, Context, Attrs, PredId) --> io__write_string(" without preceding\n"), prog_out__write_context(Context), io__write_string( - " `:- pragma base_relation(...)' declaration.\n"), + " `:- pragma base_relation' declaration.\n"), io__set_exit_status(1) ), @@ -999,7 +1378,7 @@ check_index_attribute_pred(ModuleInfo, Name, Arity, Context, Attrs, PredId) --> % since they're removed by magic.m. prog_out__write_context(Context), io__write_string( - "In `:- pragma aditi_index(...)' declaration for "), + "In `:- pragma aditi_index' declaration for "), hlds_out__write_call_id(PredOrFunc, Name/Arity), io__write_string(":\n"), prog_out__write_context(Context), @@ -1044,8 +1423,9 @@ do_add_pred_marker(Module0, PragmaName, Name, Arity, Status, Module) } ; { PredIds = [] }, - { string__append_list(["`", PragmaName, "' pragma"], - Description) }, + { string__append_list( + ["`:- pragma ", PragmaName, "' declaration"], + Description) }, undefined_pred_or_func_error(Name, Arity, Context, Description), { module_info_incr_errors(Module0, Module) } @@ -1083,7 +1463,7 @@ module_mark_as_external(PredName, Arity, Context, Module0, Module) --> { module_mark_preds_as_external(PredIdList, Module0, Module) } ; undefined_pred_or_func_error(PredName, Arity, - Context, "`external' declaration"), + Context, "`:- external' declaration"), { module_info_incr_errors(Module0, Module) } ). @@ -2936,8 +3316,8 @@ module_add_pragma_tabled(EvalMethod, PredName, Arity, MaybePredOrFunc, { ModuleInfo1 = ModuleInfo0 } ; { module_info_name(ModuleInfo0, ModuleName) }, - { string__format("pragma (%s)", [s(EvalMethodS)], - Message1) }, + { string__format("`:- pragma %s' declaration", + [s(EvalMethodS)], Message1) }, maybe_undefined_pred_error(PredName, Arity, PredOrFunc, Context, Message1), { preds_add_implicit(ModuleInfo0, PredicateTable0, @@ -2956,8 +3336,8 @@ module_add_pragma_tabled(EvalMethod, PredName, Arity, MaybePredOrFunc, { PredIds = PredIds0 } ; { module_info_name(ModuleInfo0, ModuleName) }, - { string__format("pragma (%s)", [s(EvalMethodS)], - Message1) }, + { string__format("`:- pragma %s' declaration", + [s(EvalMethodS)], Message1) }, maybe_undefined_pred_error(PredName, Arity, predicate, Context, Message1), { preds_add_implicit(ModuleInfo0, PredicateTable0, @@ -5171,7 +5551,7 @@ module_add_pragma_fact_table(Pred, Arity, FileName, Status, Context, ) ; undefined_pred_or_func_error(Pred, Arity, Context, - "pragma fact_table"), + "`:- pragma fact_table' declaration"), { Module = Module0 }, { Info = Info0 } ). diff --git a/compiler/mercury_compile.m b/compiler/mercury_compile.m index 3e128c3a2..b52dcc744 100644 --- a/compiler/mercury_compile.m +++ b/compiler/mercury_compile.m @@ -1635,14 +1635,15 @@ mercury_compile__maybe_bytecodes(HLDS0, ModuleName, Verbose, Stats) --> mercury_compile__maybe_higher_order(HLDS0, Verbose, Stats, HLDS) --> globals__io_lookup_bool_option(optimize_higher_order, HigherOrder), - globals__io_lookup_bool_option(type_specialization, Types), + % --type-specialization implies --user-guided-type-specialization. + globals__io_lookup_bool_option(user_guided_type_specialization, Types), ( { HigherOrder = yes ; Types = yes } -> maybe_write_string(Verbose, "% Specializing higher-order and polymorphic predicates...\n"), maybe_flush_output(Verbose), - specialize_higher_order(HigherOrder, Types, HLDS0, HLDS), + specialize_higher_order(HLDS0, HLDS), maybe_write_string(Verbose, "% done.\n"), maybe_report_stats(Stats) ; diff --git a/compiler/mercury_to_mercury.m b/compiler/mercury_to_mercury.m index 6d1ad9627..801565fb5 100644 --- a/compiler/mercury_to_mercury.m +++ b/compiler/mercury_to_mercury.m @@ -32,6 +32,9 @@ io__state, io__state). :- mode convert_to_mercury(in, in, in, di, uo) is det. +:- pred mercury_output_item(item, prog_context, io__state, io__state). +:- mode mercury_output_item(in, in, di, uo) is det. + :- pred mercury_output_pred_type(tvarset, existq_tvars, sym_name, list(type), maybe(determinism), purity, class_constraints, prog_context, io__state, io__state). @@ -205,11 +208,10 @@ :- implementation. :- import_module prog_out, prog_util, hlds_pred, hlds_out, instmap. -:- import_module globals, options, termination, term, varset. -:- import_module term_io. +:- import_module globals, options, termination. -:- import_module int, string, set, lexer, require. -:- import_module char. +:- import_module assoc_list, char, int, string, set, lexer, require. +:- import_module term, term_io, varset. %-----------------------------------------------------------------------------% @@ -256,9 +258,6 @@ mercury_output_item_list([Item - Context | Items]) --> %-----------------------------------------------------------------------------% -:- pred mercury_output_item(item, prog_context, io__state, io__state). -:- mode mercury_output_item(in, in, di, uo) is det. - % dispatch on the different types of items mercury_output_item(type_defn(VarSet, TypeDefn, _Cond), Context) --> @@ -346,6 +345,11 @@ mercury_output_item(pragma(Pragma), Context) --> { Pragma = tabled(Type, Pred, Arity, _PredOrFunc, _Mode) }, { eval_method_to_string(Type, TypeS) }, mercury_output_pragma_decl(Pred, Arity, predicate, TypeS) + ; + { Pragma = type_spec(PredName, SymName, Arity, + MaybePredOrFunc, MaybeModes, Subst, VarSet) }, + mercury_output_pragma_type_spec(PredName, SymName, Arity, + MaybePredOrFunc, MaybeModes, Subst, VarSet) ; { Pragma = inline(Pred, Arity) }, mercury_output_pragma_decl(Pred, Arity, predicate, "inline") @@ -2181,6 +2185,62 @@ mercury_output_pragma_c_code_vars([V|Vars], VarSet) --> %-----------------------------------------------------------------------------% +:- pred mercury_output_pragma_type_spec(sym_name, sym_name, arity, + maybe(pred_or_func), maybe(list(mode)), assoc_list(tvar, type), + tvarset, io__state, io__state). +:- mode mercury_output_pragma_type_spec(in, in, in, in, in, + in, in, di, uo) is det. + +mercury_output_pragma_type_spec(PredName, SpecName, Arity, + MaybePredOrFunc, MaybeModes, Subst, VarSet) --> + io__write_string(":- pragma type_spec("), + ( { MaybeModes = yes(Modes) } -> + { MaybePredOrFunc = yes(PredOrFunc0) -> + PredOrFunc = PredOrFunc0 + ; + error("pragma type_spec: no pred_or_func") + }, + ( + { PredOrFunc = function }, + { pred_args_to_func_args(Modes, FuncModes, RetMode) }, + mercury_output_sym_name(PredName), + io__write_string("("), + { varset__init(InstVarSet) }, + mercury_output_mode_list(FuncModes, InstVarSet), + io__write_string(") = "), + mercury_output_mode(RetMode, InstVarSet) + ; + { PredOrFunc = predicate }, + mercury_output_sym_name(PredName), + io__write_string("("), + { varset__init(InstVarSet) }, + mercury_output_mode_list(Modes, InstVarSet), + io__write_string(")") + ) + ; + mercury_output_bracketed_sym_name(PredName, + next_to_graphic_token), + io__write_string("/"), + io__write_int(Arity) + ), + + io__write_string(", ("), + io__write_list(Subst, ", ", mercury_output_type_subst(VarSet)), + io__write_string("), "), + mercury_output_bracketed_sym_name(SpecName, not_next_to_graphic_token), + io__write_string(").\n"). + +:- pred mercury_output_type_subst(tvarset, pair(tvar, type), + io__state, io__state). +:- mode mercury_output_type_subst(in, in, di, uo) is det. + +mercury_output_type_subst(VarSet, Var - Type) --> + mercury_output_var(Var, VarSet, no), + io__write_string(" = "), + mercury_output_term(Type, VarSet, no). + +%-----------------------------------------------------------------------------% + mercury_output_pragma_unused_args(PredOrFunc, SymName, Arity, ProcId, UnusedArgs) --> io__write_string(":- pragma unused_args("), diff --git a/compiler/module_qual.m b/compiler/module_qual.m index 46379ad0f..d2b5b891f 100644 --- a/compiler/module_qual.m +++ b/compiler/module_qual.m @@ -65,8 +65,9 @@ :- import_module hlds_data, hlds_module, hlds_pred, type_util, prog_out. :- import_module prog_util, mercury_to_mercury, modules, globals, options. -:- import_module (inst), instmap, term, varset. -:- import_module int, map, require, set, std_util, string. +:- import_module (inst), instmap. +:- import_module int, map, require, set, std_util, string, term, varset. +:- import_module assoc_list. module_qual__module_qualify_items(Items0, Items, ModuleName, ReportErrors, Info, NumErrors, UndefTypes, UndefModes) --> @@ -685,6 +686,18 @@ qualify_pragma(export(Name, PredOrFunc, Modes0, CFunc), qualify_mode_list(Modes0, Modes, Info0, Info). qualify_pragma(unused_args(A, B, C, D, E), unused_args(A, B, C, D, E), Info, Info) --> []. +qualify_pragma(type_spec(A, B, C, D, MaybeModes0, Subst0, G), + type_spec(A, B, C, D, MaybeModes, Subst, G), Info0, Info) --> + ( + { MaybeModes0 = yes(Modes0) } + -> + qualify_mode_list(Modes0, Modes, Info0, Info1), + { MaybeModes = yes(Modes) } + ; + { Info1 = Info0 }, + { MaybeModes = no } + ), + qualify_type_spec_subst(Subst0, Subst, Info1, Info). qualify_pragma(fact_table(SymName, Arity, FileName), fact_table(SymName, Arity, FileName), Info, Info) --> []. qualify_pragma(aditi(SymName, Arity), aditi(SymName, Arity), @@ -727,6 +740,16 @@ qualify_pragma_vars([pragma_var(Var, Name, Mode0) | PragmaVars0], qualify_mode(Mode0, Mode, Info0, Info1), qualify_pragma_vars(PragmaVars0, PragmaVars, Info1, Info). +:- pred qualify_type_spec_subst(assoc_list(tvar, type)::in, + assoc_list(tvar, type)::out, mq_info::in, mq_info::out, + io__state::di, io__state::uo) is det. + +qualify_type_spec_subst([], [], Info, Info) --> []. +qualify_type_spec_subst([Var - Type0 | Subst0], [Var - Type | Subst], + Info0, Info) --> + qualify_type(Type0, Type, Info0, Info1), + qualify_type_spec_subst(Subst0, Subst, Info1, Info). + :- pred qualify_class_constraints(class_constraints::in, class_constraints::out, mq_info::in, mq_info::out, io__state::di, io__state::uo) is det. diff --git a/compiler/modules.m b/compiler/modules.m index 41e662f89..270193a5c 100644 --- a/compiler/modules.m +++ b/compiler/modules.m @@ -864,6 +864,7 @@ pragma_allowed_in_interface(fact_table(_, _, _), no). pragma_allowed_in_interface(tabled(_, _, _, _, _), no). pragma_allowed_in_interface(promise_pure(_, _), no). pragma_allowed_in_interface(unused_args(_, _, _, _, _), no). +pragma_allowed_in_interface(type_spec(_, _, _, _, _, _, _), yes). pragma_allowed_in_interface(termination_info(_, _, _, _, _), yes). pragma_allowed_in_interface(terminates(_, _), yes). pragma_allowed_in_interface(does_not_terminate(_, _), yes). diff --git a/compiler/options.m b/compiler/options.m index 8d16ada18..2ad5b7800 100644 --- a/compiler/options.m +++ b/compiler/options.m @@ -233,6 +233,7 @@ ; intermod_unused_args ; optimize_higher_order ; type_specialization + ; user_guided_type_specialization ; higher_order_size_limit ; optimize_constructor_last_call ; optimize_duplicate_calls @@ -576,6 +577,7 @@ option_defaults_2(optimization_option, [ intermod_unused_args - bool(no), optimize_higher_order - bool(no), type_specialization - bool(no), + user_guided_type_specialization - bool(no), higher_order_size_limit - int(20), optimize_constructor_last_call - bool(no), optimize_dead_procs - bool(no), @@ -906,6 +908,10 @@ long_option("optimize-higher-order", optimize_higher_order). long_option("optimise-higher-order", optimize_higher_order). long_option("type-specialization", type_specialization). long_option("type-specialisation", type_specialization). +long_option("user-guided-type-specialization", + user_guided_type_specialization). +long_option("user-guided-type-specialisation", + user_guided_type_specialization). long_option("higher-order-size-limit", higher_order_size_limit). long_option("optimise-constructor-last-call", optimize_constructor_last_call). long_option("optimize-constructor-last-call", optimize_constructor_last_call). @@ -1211,6 +1217,8 @@ opt_level(2, _, [ inline_single_use - bool(yes), inline_compound_threshold - int(10), common_struct - bool(yes), + user_guided_type_specialization + - bool(yes), /**** % XXX optimize_duplicate_calls is broken -- % it doesn't take type information into account. @@ -1831,10 +1839,10 @@ options_help_code_generation --> "--fact-table-max-array-size ", "\tSpecify the maximum number of elements in a single", - "\t`pragma fact_table' data array (default: 1024).", + "\t`:- pragma fact_table' data array (default: 1024).", "--fact-table-hash-percent-full ", - "\tSpecify how full the `pragma fact_table' hash tables should be", - "\tallowed to get. Given as an integer percentage", + "\tSpecify how full the `:- pragma fact_table' hash tables", + "\tshould be allowed to get. Given as an integer percentage", "\t(valid range: 1 to 100, default: 90)." ]), @@ -1959,7 +1967,11 @@ options_help_hlds_hlds_optimization --> "--optimize-higher-order", "\tEnable specialization of higher-order predicates.", "--type-specialization", - "\tEnable specialization of polymorphic predicates.", + "\tEnable specialization of polymorphic predicates where the", + "\tpolymorphic types are known.", + "--user-guided-type-specialization", + "\tEnable specialization of polymorphic predicates for which", + "\tthere are `:- pragma type_spec' declarations.", "--higher-order-size-limit", "\tSet the maximum goal size of specialized versions created by", "\t`--optimize-higher-order' and `--type-specialization'.", diff --git a/compiler/polymorphism.m b/compiler/polymorphism.m index a966bbcc7..623945a91 100644 --- a/compiler/polymorphism.m +++ b/compiler/polymorphism.m @@ -347,6 +347,11 @@ :- pred polymorphism__no_type_info_builtin(module_name, string, int). :- mode polymorphism__no_type_info_builtin(in, in, out) is semidet. + % Build the type describing the typeclass_info for the + % given class_constraint. +:- pred polymorphism__build_typeclass_info_type(class_constraint, (type)). +:- mode polymorphism__build_typeclass_info_type(in, out) is det. + % From the type of a typeclass_info variable find the class_constraint % about which the variable carries information, failing if the % type is not a valid typeclass_info type. @@ -370,6 +375,7 @@ :- type typeclass_info_manipulator ---> type_info_from_typeclass_info ; superclass_from_typeclass_info + ; instance_constraint_from_typeclass_info . % Look up the pred_id and proc_id for a type specific @@ -500,6 +506,9 @@ polymorphism__no_type_info_builtin(MercuryBuiltin, polymorphism__no_type_info_builtin(MercuryBuiltin, "superclass_from_typeclass_info", 3) :- mercury_private_builtin_module(MercuryBuiltin). +polymorphism__no_type_info_builtin(MercuryBuiltin, + "instance_constraint_from_typeclass_info", 3) :- + mercury_private_builtin_module(MercuryBuiltin). polymorphism__no_type_info_builtin(MercuryBuiltin, "type_info_from_typeclass_info", 3) :- mercury_private_builtin_module(MercuryBuiltin). @@ -2826,9 +2835,6 @@ polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, Constraint, polymorphism__build_typeclass_info_type(Constraint, DictionaryType), map__set(VarTypes0, Var, DictionaryType, VarTypes). -:- pred polymorphism__build_typeclass_info_type(class_constraint, (type)). -:- mode polymorphism__build_typeclass_info_type(in, out) is det. - polymorphism__build_typeclass_info_type(Constraint, DictionaryType) :- Constraint = constraint(SymName, ArgTypes), @@ -2880,6 +2886,9 @@ polymorphism__is_typeclass_info_manipulator(ModuleInfo, ; PredName = "superclass_from_typeclass_info", TypeClassManipulator = superclass_from_typeclass_info + ; + PredName = "instance_constraint_from_typeclass_info", + TypeClassManipulator = instance_constraint_from_typeclass_info ). %---------------------------------------------------------------------------% diff --git a/compiler/prog_data.m b/compiler/prog_data.m index 513d52d3b..5ca534862 100644 --- a/compiler/prog_data.m +++ b/compiler/prog_data.m @@ -19,7 +19,7 @@ :- interface. :- import_module hlds_data, hlds_pred, (inst), purity, rl, term_util. -:- import_module list, map, varset, term, std_util. +:- import_module assoc_list, list, map, varset, term, std_util. %-----------------------------------------------------------------------------% @@ -110,6 +110,13 @@ % whether or not the C code is thread-safe % PredName, Predicate or Function, Vars/Mode, % VarNames, C Code Implementation Info + + ; type_spec(sym_name, sym_name, arity, maybe(pred_or_func), + maybe(list(mode)), type_subst, tvarset) + % PredName, SpecializedPredName, Arity, + % PredOrFunc, Modes if a specific procedure was + % specified, type substitution (using the variable + % names from the pred declaration), TVarSet ; inline(sym_name, arity) % Predname, Arity @@ -215,6 +222,9 @@ ; check_termination(sym_name, arity). % Predname, Arity + % The type substitution for a `pragma type_spec' declaration. +:- type type_subst == assoc_list(tvar, type). + % This type holds information about the implementation details % of procedures defined via `pragma c_code'. diff --git a/compiler/prog_io_pragma.m b/compiler/prog_io_pragma.m index ef00b5465..25c29ff37 100644 --- a/compiler/prog_io_pragma.m +++ b/compiler/prog_io_pragma.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1996-1998 The University of Melbourne. +% Copyright (C) 1996-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -22,7 +22,8 @@ :- implementation. -:- import_module prog_io, prog_io_goal, hlds_pred, term_util, term_errors, rl. +:- import_module prog_io, prog_io_goal, prog_util, hlds_pred. +:- import_module term_util, term_errors, rl. :- import_module int, map, string, std_util, bool, require. parse_pragma(ModuleName, VarSet, PragmaTerms, Result) :- @@ -60,12 +61,12 @@ parse_pragma_type(_, "source_file", PragmaTerms, ErrorTerm, _VarSet, Result) :- Result = ok(pragma(source_file(SourceFile))) ; Result = error( - "string expected in `pragma source_file' declaration", + "string expected in `:- pragma source_file' declaration", SourceFileTerm) ) ; Result = error( - "wrong number of arguments in `pragma source_file' declaration", + "wrong number of arguments in `:- pragma source_file' declaration", ErrorTerm) ). @@ -83,7 +84,7 @@ parse_pragma_type(_, "c_header_code", PragmaTerms, ) ; Result = error( -"wrong number of arguments in `pragma c_header_code(...) declaration", +"wrong number of arguments in `:- pragma c_header_code' declaration", ErrorTerm) ). @@ -210,136 +211,44 @@ parse_pragma_type(ModuleName, "c_code", PragmaTerms, ErrorTerm) ). -parse_pragma_type(ModuleName, "import", PragmaTerms, ErrorTerm, - _VarSet, Result) :- - ( - PragmaTerms = [PredAndModesTerm, FlagsTerm, - C_FunctionTerm] - -> +parse_pragma_type(ModuleName, "import", PragmaTerms, + ErrorTerm, _VarSet, Result) :- + ( ( - PredAndModesTerm = term__functor(_, _, _), - C_FunctionTerm = term__functor(term__string(C_Function), [], _) - -> - ( - PredAndModesTerm = term__functor(term__atom("="), - [FuncAndArgModesTerm, RetModeTerm], _) - -> - parse_implicitly_qualified_term(ModuleName, - FuncAndArgModesTerm, PredAndModesTerm, - "pragma import declaration", FuncAndArgModesResult), - ( - FuncAndArgModesResult = ok(FuncName, ArgModeTerms), - ( - convert_mode_list(ArgModeTerms, ArgModes), - convert_mode(RetModeTerm, RetMode) - -> - list__append(ArgModes, [RetMode], Modes), - ( - parse_pragma_c_code_attributes_term(FlagsTerm, - Flags) - -> - Result = ok(pragma(import(FuncName, function, - Modes, Flags, C_Function))) - ; - Result = error("invalid second argument in `:- pragma import/3' declaration -- expecting C code attribute or list of attributes'", - FlagsTerm) - ) - ; - Result = error( -"expected pragma import(FuncName(ModeList) = Mode, Attributes, C_Function)", - PredAndModesTerm) - ) - ; - FuncAndArgModesResult = error(Msg, Term), - Result = error(Msg, Term) - ) + PragmaTerms = [PredAndModesTerm, FlagsTerm, C_FunctionTerm], + ( parse_pragma_c_code_attributes_term(FlagsTerm, Flags) -> + FlagsResult = ok(Flags) ; - parse_implicitly_qualified_term(ModuleName, - PredAndModesTerm, ErrorTerm, - "pragma import declaration", PredAndModesResult), - ( - PredAndModesResult = ok(PredName, ModeTerms), - ( - convert_mode_list(ModeTerms, Modes) - -> - ( - parse_pragma_c_code_attributes_term(FlagsTerm, - Flags) - -> - Result = ok(pragma(import(PredName, predicate, - Modes, Flags, C_Function))) - ; - Result = error("invalid second argument in `:- pragma import/3' declaration -- expecting C code attribute or list of attributes'", + FlagsResult = error("invalid second argument in `:- pragma import/3' declaration -- expecting C code attribute or list of attributes'", FlagsTerm) - ) - ; - Result = error( -"expected pragma import(PredName(ModeList), Attributes, C_Function)", - PredAndModesTerm) - ) - ; - PredAndModesResult = error(Msg, Term), - Result = error(Msg, Term) - ) - ) + ) ; - Result = error( -"expected pragma import(PredName(ModeList), Attributes, C_Function)", - PredAndModesTerm) - ) - ; - PragmaTerms = [PredAndModesTerm, C_FunctionTerm] - -> - default_attributes(Attributes), + PragmaTerms = [PredAndModesTerm, C_FunctionTerm], + default_attributes(Flags), + FlagsResult = ok(Flags) + ) + -> ( - PredAndModesTerm = term__functor(_, _, _), C_FunctionTerm = term__functor(term__string(C_Function), [], _) -> + parse_pred_or_func_and_arg_modes(yes(ModuleName), + PredAndModesTerm, ErrorTerm, + "`:- pragma import' declaration", + PredAndArgModesResult), ( - PredAndModesTerm = term__functor(term__atom("="), - [FuncAndArgModesTerm, RetModeTerm], _) - -> - parse_implicitly_qualified_term(ModuleName, - FuncAndArgModesTerm, PredAndModesTerm, - "pragma import declaration", FuncAndArgModesResult), + PredAndArgModesResult = ok(PredName - PredOrFunc, + ArgModes), ( - FuncAndArgModesResult = ok(FuncName, ArgModeTerms), - ( - convert_mode_list(ArgModeTerms, ArgModes), - convert_mode(RetModeTerm, RetMode) - -> - list__append(ArgModes, [RetMode], Modes), - Result = ok(pragma(import(FuncName, function, - Modes, Attributes, C_Function))) - ; - Result = error( -"expected pragma import(FuncName(ModeList) = Mode, C_Function)", - PredAndModesTerm) - ) + FlagsResult = ok(Attributes), + Result = ok(pragma(import(PredName, PredOrFunc, + ArgModes, Attributes, C_Function))) ; - FuncAndArgModesResult = error(Msg, Term), + FlagsResult = error(Msg, Term), Result = error(Msg, Term) ) ; - parse_implicitly_qualified_term(ModuleName, - PredAndModesTerm, ErrorTerm, - "pragma import declaration", PredAndModesResult), - ( - PredAndModesResult = ok(PredName, ModeTerms), - ( - convert_mode_list(ModeTerms, Modes) - -> - Result = ok(pragma(import(PredName, predicate, - Modes, Attributes, C_Function))) - ; - Result = error( - "expected pragma import(PredName(ModeList), C_Function)", - PredAndModesTerm) - ) - ; - PredAndModesResult = error(Msg, Term), + PredAndArgModesResult = error(Msg, Term), Result = error(Msg, Term) - ) ) ; Result = error( @@ -349,65 +258,28 @@ parse_pragma_type(ModuleName, "import", PragmaTerms, ErrorTerm, ; Result = error( - "wrong number of arguments in `pragma import(...)' declaration", + "wrong number of arguments in `:- pragma import' declaration", ErrorTerm) - ). + ). -parse_pragma_type(_ModuleName, "export", PragmaTerms, ErrorTerm, - _VarSet, Result) :- +parse_pragma_type(_ModuleName, "export", PragmaTerms, + ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [PredAndModesTerm, C_FunctionTerm] -> ( - PredAndModesTerm = term__functor(_, _, _), C_FunctionTerm = term__functor(term__string(C_Function), [], _) -> + parse_pred_or_func_and_arg_modes(no, PredAndModesTerm, + ErrorTerm, "`:- pragma export' declaration", + PredAndModesResult), ( - PredAndModesTerm = term__functor(term__atom("="), - [FuncAndArgModesTerm, RetModeTerm], _) - -> - parse_qualified_term(FuncAndArgModesTerm, - PredAndModesTerm, "pragma export declaration", - FuncAndArgModesResult), - ( - FuncAndArgModesResult = ok(FuncName, ArgModeTerms), - ( - convert_mode_list(ArgModeTerms, ArgModes), - convert_mode(RetModeTerm, RetMode) - -> - list__append(ArgModes, [RetMode], Modes), - Result = - ok(pragma(export(FuncName, function, - Modes, C_Function))) - ; - Result = error( - "expected pragma export(FuncName(ModeList) = Mode, C_Function)", - PredAndModesTerm) - ) - ; - FuncAndArgModesResult = error(Msg, Term), - Result = error(Msg, Term) - ) - ; - parse_qualified_term(PredAndModesTerm, ErrorTerm, - "pragma export declaration", PredAndModesResult), - ( - PredAndModesResult = ok(PredName, ModeTerms), - ( - convert_mode_list(ModeTerms, Modes) - -> - Result = - ok(pragma(export(PredName, predicate, Modes, - C_Function))) - ; - Result = error( - "expected pragma export(PredName(ModeList), C_Function)", - PredAndModesTerm) - ) - ; - PredAndModesResult = error(Msg, Term), - Result = error(Msg, Term) - ) + PredAndModesResult = ok(PredName - PredOrFunc, Modes), + Result = ok(pragma(export(PredName, PredOrFunc, + Modes, C_Function))) + ; + PredAndModesResult = error(Msg, Term), + Result = error(Msg, Term) ) ; Result = error( @@ -417,7 +289,7 @@ parse_pragma_type(_ModuleName, "export", PragmaTerms, ErrorTerm, ; Result = error( - "wrong number of arguments in `pragma export(...)' declaration", + "wrong number of arguments in `:- pragma export' declaration", ErrorTerm) ). @@ -457,8 +329,8 @@ parse_pragma_type(ModuleName, "obsolete", PragmaTerms, ErrorTerm, % pragma unused_args should never appear in user programs, % only in .opt files. -parse_pragma_type(_ModuleName, "unused_args", PragmaTerms, ErrorTerm, - _VarSet, Result) :- +parse_pragma_type(ModuleName, "unused_args", PragmaTerms, + ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [ PredOrFuncTerm, @@ -477,8 +349,9 @@ parse_pragma_type(_ModuleName, "unused_args", PragmaTerms, ErrorTerm, term__atom("function"), [], _), PredOrFunc = function ), - parse_qualified_term(PredNameTerm, ErrorTerm, - "predicate name", PredNameResult), + parse_implicitly_qualified_term(ModuleName, PredNameTerm, + ErrorTerm, "`:- pragma unused_args' declaration", + PredNameResult), PredNameResult = ok(PredName, []), convert_int_list(UnusedArgsTerm, UnusedArgsResult), UnusedArgsResult = ok(UnusedArgs) @@ -486,7 +359,65 @@ parse_pragma_type(_ModuleName, "unused_args", PragmaTerms, ErrorTerm, Result = ok(pragma(unused_args(PredOrFunc, PredName, Arity, ProcId, UnusedArgs))) ; - Result = error("error in pragma unused_args", ErrorTerm) + Result = error("error in `:- pragma unused_args'", ErrorTerm) + ). + +parse_pragma_type(ModuleName, "type_spec", PragmaTerms, ErrorTerm, + VarSet0, Result) :- + ( + ( + PragmaTerms = [PredAndModesTerm, TypeSubnTerm], + MaybeName = no + ; + PragmaTerms = [PredAndModesTerm, TypeSubnTerm, SpecNameTerm], + SpecNameTerm = term__functor(_, _, SpecContext), + + % This form of the pragma should not appear in source files. + term__context_file(SpecContext, FileName), + \+ string__remove_suffix(FileName, ".m", _), + + parse_implicitly_qualified_term(ModuleName, + SpecNameTerm, ErrorTerm, "", NameResult), + NameResult = ok(SpecName, []), + MaybeName = yes(SpecName) + ) + -> + parse_arity_or_modes(ModuleName, PredAndModesTerm, ErrorTerm, + "`:- pragma type_spec' declaration", + ArityOrModesResult), + ( + ArityOrModesResult = ok(arity_or_modes(PredName, + Arity, MaybePredOrFunc, MaybeModes)), + conjunction_to_list(TypeSubnTerm, TypeSubnList), + + % The varset is actually a tvarset. + varset__coerce(VarSet0, TVarSet), + ( list__map(convert_type_spec_pair, TypeSubnList, TypeSubn) -> + ( MaybeName = yes(SpecializedName0) -> + SpecializedName = SpecializedName0 + ; + unqualify_name(PredName, UnqualName), + make_pred_name(ModuleName, "TypeSpecOf", + MaybePredOrFunc, UnqualName, + type_subst(TVarSet, TypeSubn), + SpecializedName) + ), + Result = ok(pragma(type_spec(PredName, + SpecializedName, Arity, MaybePredOrFunc, + MaybeModes, TypeSubn, TVarSet))) + ; + Result = error( + "expected type substitution in `:- pragma type_spec' declaration", + TypeSubnTerm) + ) + ; + ArityOrModesResult = error(Msg, Term), + Result = error(Msg, Term) + ) + ; + Result = error( + "wrong number of arguments in `:- pragma type_spec' declaration", + ErrorTerm) ). parse_pragma_type(ModuleName, "fact_table", PragmaTerms, ErrorTerm, @@ -513,7 +444,7 @@ parse_pragma_type(ModuleName, "fact_table", PragmaTerms, ErrorTerm, ; Result = error( - "wrong number of arguments in pragma fact_table(..., ...) declaration", + "wrong number of arguments in `:- pragma fact_table' declaration", ErrorTerm) ). @@ -556,12 +487,12 @@ parse_pragma_type(ModuleName, "aditi_index", PragmaTerms, ; AttributeResult = error(_, AttrErrorTerm), Result = error( - "expected attribute list for `:- pragma aditi_index(...)' declaration", + "expected attribute list for `:- pragma aditi_index' declaration", AttrErrorTerm) ) ; Result = error( - "expected index type for `:- pragma aditi_index(...)' declaration", + "expected index type for `:- pragma aditi_index' declaration", IndexTypeTerm) ) ; @@ -570,7 +501,7 @@ parse_pragma_type(ModuleName, "aditi_index", PragmaTerms, ) ; Result = error( -"wrong number of arguments in pragma aditi_index(..., ..., ...) declaration", + "wrong number of arguments in `:- pragma aditi_index' declaration", ErrorTerm) ). @@ -607,7 +538,7 @@ parse_pragma_type(ModuleName, "supp_magic", Pragma = supp_magic(Name, Arity)), PragmaTerms, ErrorTerm, Result). -parse_pragma_type(ModuleName, "context", +parse_pragma_type(ModuleName, "context", PragmaTerms, ErrorTerm, _, Result) :- parse_simple_pragma(ModuleName, "context", lambda([Name::in, Arity::in, Pragma::out] is det, @@ -623,13 +554,11 @@ parse_pragma_type(ModuleName, "owner", Pragma = owner(Name, Arity, Owner)), [SymNameAndArityTerm], ErrorTerm, Result) ; - string__append_list(["expected owner name for - `pragma owner(...)' declaration"], ErrorMsg), + ErrorMsg = "expected owner name for `:- pragma owner' declaration", Result = error(ErrorMsg, OwnerTerm) ) ; - string__append_list(["wrong number of arguments in - `pragma owner(...)' declaration"], ErrorMsg), + ErrorMsg = "wrong number of arguments in `:- pragma owner' declaration", Result = error(ErrorMsg, ErrorTerm) ). @@ -648,73 +577,46 @@ parse_pragma_type(ModuleName, "termination_info", PragmaTerms, ErrorTerm, ArgSizeTerm, TerminationTerm ], - ( - PredAndModesTerm0 = term__functor(Const, Terms0, _) - -> - ( - Const = term__atom("="), - Terms0 = [FuncAndModesTerm, FuncResultTerm0] - -> - % function - PredOrFunc = function, - PredAndModesTerm = FuncAndModesTerm, - FuncResultTerm = [FuncResultTerm0] - ; - % predicate - PredOrFunc = predicate, - PredAndModesTerm = PredAndModesTerm0, - FuncResultTerm = [] - ), - parse_implicitly_qualified_term(ModuleName, - PredAndModesTerm, ErrorTerm, - "`pragma termination_info' declaration", PredNameResult), - PredNameResult = ok(PredName, ModeListTerm0), - ( - PredOrFunc = predicate, - ModeListTerm = ModeListTerm0 - ; - PredOrFunc = function, - list__append(ModeListTerm0, FuncResultTerm, ModeListTerm) - ), - convert_mode_list(ModeListTerm, ModeList), - ( + parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0, + ErrorTerm, "`:- pragma termination_info' declaration", + NameAndModesResult), + NameAndModesResult = ok(PredName - PredOrFunc, ModeList), + ( ArgSizeTerm = term__functor(term__atom("not_set"), [], _), MaybeArgSizeInfo = no - ; + ; ArgSizeTerm = term__functor(term__atom("infinite"), [], ArgSizeContext), MaybeArgSizeInfo = yes(infinite( [ArgSizeContext - imported_pred])) - ; + ; ArgSizeTerm = term__functor(term__atom("finite"), [IntTerm, UsedArgsTerm], _), IntTerm = term__functor(term__integer(Int), [], _), convert_bool_list(UsedArgsTerm, UsedArgs), MaybeArgSizeInfo = yes(finite(Int, UsedArgs)) - ), - ( + ), + ( TerminationTerm = term__functor(term__atom("not_set"), [], _), MaybeTerminationInfo = no - ; + ; TerminationTerm = term__functor(term__atom("can_loop"), [], TermContext), MaybeTerminationInfo = yes(can_loop( [TermContext - imported_pred])) - ; + ; TerminationTerm = term__functor(term__atom("cannot_loop"), [], _), MaybeTerminationInfo = yes(cannot_loop) - ), - Result0 = ok(pragma(termination_info(PredOrFunc, PredName, - ModeList, MaybeArgSizeInfo, MaybeTerminationInfo))) - ; - Result0 = error("unexpected variable in pragma termination_info", - ErrorTerm) - ) + ), + Result0 = ok(pragma(termination_info(PredOrFunc, PredName, + ModeList, MaybeArgSizeInfo, MaybeTerminationInfo))) -> Result = Result0 ; - Result = error("syntax error in `pragma termination_info'", ErrorTerm) + Result = error( + "syntax error in `:- pragma termination_info' declaration", + ErrorTerm) ). parse_pragma_type(ModuleName, "terminates", PragmaTerms, @@ -758,8 +660,8 @@ parse_simple_pragma(ModuleName, PragmaType, MakePragma, Result = error(ErrorMsg, PredAndArityTerm) ) ; - string__append_list(["wrong number of arguments in `pragma ", - PragmaType, "(...)' declaration"], ErrorMsg), + string__append_list(["wrong number of arguments in `:- pragma ", + PragmaType, "' declaration"], ErrorMsg), Result = error(ErrorMsg, ErrorTerm) ). @@ -781,13 +683,13 @@ parse_pred_name_and_arity(ModuleName, PragmaType, PredAndArityTerm, Result = ok(PredName, Arity) ; string__append_list( - ["expected predname/arity for `pragma ", - PragmaType, "(...)' declaration"], ErrorMsg), + ["expected predname/arity for `:- pragma ", + PragmaType, "' declaration"], ErrorMsg), Result = error(ErrorMsg, PredAndArityTerm) ) ; - string__append_list(["expected predname/arity for `pragma ", - PragmaType, "(...)' declaration"], ErrorMsg), + string__append_list(["expected predname/arity for `:- pragma ", + PragmaType, "' declaration"], ErrorMsg), Result = error(ErrorMsg, PredAndArityTerm) ). @@ -896,55 +798,37 @@ parse_threadsafe(term__functor(term__atom("not_thread_safe"), [], _), :- mode parse_pragma_c_code(in, in, in, in, in, out) is det. parse_pragma_c_code(ModuleName, Flags, PredAndVarsTerm0, PragmaImpl, - VarSet, Result) :- + VarSet0, Result) :- + parse_pred_or_func_and_args(yes(ModuleName), PredAndVarsTerm0, + PredAndVarsTerm0, "`:- pragma c_code' declaration", PredAndArgsResult), ( - PredAndVarsTerm0 = term__functor(Const, Terms0, _) - -> + PredAndArgsResult = ok(PredName, VarList0 - MaybeRetTerm), ( % is this a function or a predicate? - Const = term__atom("="), - Terms0 = [FuncAndVarsTerm, FuncResultTerm0] + MaybeRetTerm = yes(FuncResultTerm0) -> % function PredOrFunc = function, - PredAndVarsTerm = FuncAndVarsTerm, - FuncResultTerms = [FuncResultTerm0] + list__append(VarList0, [FuncResultTerm0], VarList) ; % predicate PredOrFunc = predicate, - PredAndVarsTerm = PredAndVarsTerm0, - FuncResultTerms = [] + VarList = VarList0 ), - parse_implicitly_qualified_term(ModuleName, - PredAndVarsTerm, PredAndVarsTerm0, - "pragma c_code declaration", PredNameResult), + parse_pragma_c_code_varlist(VarSet0, VarList, PragmaVars, Error), ( - PredNameResult = ok(PredName, VarList0), - ( - PredOrFunc = predicate, - VarList = VarList0 - ; - PredOrFunc = function, - list__append(VarList0, FuncResultTerms, VarList) - ), - varset__coerce(VarSet, ProgVarSet), - parse_pragma_c_code_varlist(VarSet, VarList, PragmaVars, - Error), - ( - Error = no, - Result = ok(pragma(c_code(Flags, PredName, - PredOrFunc, PragmaVars, ProgVarSet, PragmaImpl))) - ; - Error = yes(ErrorMessage), - Result = error(ErrorMessage, PredAndVarsTerm) - ) - ; - PredNameResult = error(Msg, Term), - Result = error(Msg, Term) + Error = no, + varset__coerce(VarSet0, VarSet), + Result = ok(pragma(c_code(Flags, PredName, + PredOrFunc, PragmaVars, VarSet, PragmaImpl))) + ; + Error = yes(ErrorMessage), + Result = error(ErrorMessage, PredAndVarsTerm0) + ) ; - Result = error("unexpected variable in `pragma c_code' declaration", - PredAndVarsTerm0) + PredAndArgsResult = error(Msg, Term), + Result = error(Msg, Term) ). % parse the variable list in the pragma c code declaration. @@ -996,7 +880,36 @@ parse_tabling_pragma(ModuleName, PragmaName, TablingType, PragmaTerms, ( PragmaTerms = [PredAndModesTerm0] -> + string__append_list(["`:- pragma ", PragmaName, "' declaration"], + ParseMsg), + parse_arity_or_modes(ModuleName, PredAndModesTerm0, + ErrorTerm, ParseMsg, ArityModesResult), ( + ArityModesResult = ok(arity_or_modes(PredName, + Arity, MaybePredOrFunc, MaybeModes)), + Result = ok(pragma(tabled(TablingType, PredName, Arity, + MaybePredOrFunc, MaybeModes))) + ; + ArityModesResult = error(Msg, Term), + Result = error(Msg, Term) + ) + ; + string__append_list(["wrong number of arguments in `:- pragma ", + PragmaName, "' declaration"], ErrorMessage), + Result = error(ErrorMessage, ErrorTerm) + ). + +:- type arity_or_modes + ---> arity_or_modes(sym_name, arity, + maybe(pred_or_func), maybe(list(mode))). + +:- pred parse_arity_or_modes(module_name, term, term, + string, maybe1(arity_or_modes)). +:- mode parse_arity_or_modes(in, in, in, in, out) is det. + +parse_arity_or_modes(ModuleName, PredAndModesTerm0, + ErrorTerm, ErrorMsg, Result) :- + ( % Is this a simple pred/arity pragma PredAndModesTerm0 = term__functor(term__atom("/"), [PredNameTerm, ArityTerm], _) @@ -1006,104 +919,101 @@ parse_tabling_pragma(ModuleName, PragmaName, TablingType, PragmaTerms, PredNameTerm, PredAndModesTerm0, "", ok(PredName, [])), ArityTerm = term__functor(term__integer(Arity), [], _) -> - Result = ok(pragma(tabled(TablingType, PredName, Arity, - no, no))) + Result = ok(arity_or_modes(PredName, Arity, no, no)) ; - string__append_list( - ["expected predname/arity for `pragma ", - PragmaName, "(...)' declaration"], ErrorMsg), - Result = error(ErrorMsg, PredAndModesTerm0) + string__append("expected predname/arity for", ErrorMsg, Msg), + Result = error(Msg, ErrorTerm) ) ; - % Is this a specific mode pragma - PredAndModesTerm0 = term__functor(Const, Terms0, _) - -> - ( - % is this a function or a predicate? - Const = term__atom("="), - Terms0 = [FuncAndModesTerm, FuncResultTerm0] - -> - % function - PredOrFunc = function, - PredAndModesTerm = FuncAndModesTerm, - FuncResultTerms = [ FuncResultTerm0 ] - ; - % predicate - PredOrFunc = predicate, - PredAndModesTerm = PredAndModesTerm0, - FuncResultTerms = [] - ), - string__append_list(["`pragma ", PragmaName, "(...)' declaration"], - ParseMsg), - parse_qualified_term(PredAndModesTerm, PredAndModesTerm0, - ParseMsg, PredNameResult), - ( - PredNameResult = ok(PredName, ModeList0), - ( - PredOrFunc = predicate, - ModeList = ModeList0 + parse_pred_or_func_and_arg_modes(yes(ModuleName), + PredAndModesTerm0, PredAndModesTerm0, ErrorMsg, + PredAndModesResult), + ( + PredAndModesResult = ok(PredName - PredOrFunc, Modes), + list__length(Modes, Arity0), + ( PredOrFunc = function -> + Arity is Arity0 - 1 ; - PredOrFunc = function, - list__append(ModeList0, FuncResultTerms, ModeList) + Arity = Arity0 ), - ( - convert_mode_list(ModeList, Modes) - -> - list__length(Modes, Arity0), - ( - PredOrFunc = function - -> - Arity is Arity0 - 1 - ; - Arity = Arity0 - ), - Result = ok(pragma(tabled(TablingType, PredName, Arity, - yes(PredOrFunc), yes(Modes)))) - ; - string__append_list(["syntax error in pragma '", - PragmaName, "(...)' declaration"],ErrorMessage), - Result = error(ErrorMessage, PredAndModesTerm) - ) + Result = ok(arity_or_modes(PredName, Arity, + yes(PredOrFunc), yes(Modes))) ; - PredNameResult = error(Msg, Term), + PredAndModesResult = error(Msg, Term), Result = error(Msg, Term) ) - ; - string__append_list(["unexpected variable in `pragma ", PragmaName, - "'"], ErrorMessage), - Result = error(ErrorMessage, PredAndModesTerm0) - ) - ; - string__append_list(["wrong number of arguments in `pragma ", - PragmaName, "(...)' declaration"], ErrorMessage), - Result = error(ErrorMessage, ErrorTerm) - ). + ). -:- pred convert_int_list(term::in, maybe1(list(int))::out) is det. +:- type maybe_pred_or_func_modes == + maybe2(pair(sym_name, pred_or_func), list(mode)). +:- type maybe_pred_or_func(T) == maybe2(sym_name, pair(list(T), maybe(T))). -convert_int_list(term__variable(V), - error("variable in int list", term__variable(V))). -convert_int_list(term__functor(Functor, Args, Context), Result) :- - ( - Functor = term__atom("."), - Args = [term__functor(term__integer(Int), [], _), RestTerm] - -> - convert_int_list(RestTerm, RestResult), +:- pred parse_pred_or_func_and_arg_modes(maybe(module_name), term, term, + string, maybe_pred_or_func_modes). +:- mode parse_pred_or_func_and_arg_modes(in, in, in, in, out) is det. + +parse_pred_or_func_and_arg_modes(MaybeModuleName, PredAndModesTerm, + ErrorTerm, Msg, Result) :- + parse_pred_or_func_and_args(MaybeModuleName, PredAndModesTerm, + ErrorTerm, Msg, PredAndArgsResult), + ( + PredAndArgsResult = + ok(PredName, ArgModeTerms - MaybeRetModeTerm), + ( convert_mode_list(ArgModeTerms, ArgModes0) -> ( - RestResult = ok(List0), - Result = ok([Int | List0]) + MaybeRetModeTerm = yes(RetModeTerm), + ( convert_mode(RetModeTerm, RetMode) -> + list__append(ArgModes0, [RetMode], ArgModes), + Result = ok(PredName - function, ArgModes) + ; + string__append("error in return mode in ", + Msg, ErrorMsg), + Result = error(ErrorMsg, ErrorTerm) + ) ; - RestResult = error(_, _), - Result = RestResult + MaybeRetModeTerm = no, + Result = ok(PredName - predicate, ArgModes0) ) + ; + string__append("error in argument modes in ", Msg, + ErrorMsg), + Result = error(ErrorMsg, ErrorTerm) + ) ; - Functor = term__atom("[]"), - Args = [] + PredAndArgsResult = error(ErrorMsg, Term), + Result = error(ErrorMsg, Term) + ). + +:- pred parse_pred_or_func_and_args(maybe(sym_name), term, term, string, + maybe_pred_or_func(term)). +:- mode parse_pred_or_func_and_args(in, in, in, in, out) is det. + +parse_pred_or_func_and_args(MaybeModuleName, PredAndArgsTerm, ErrorTerm, + Msg, PredAndArgsResult) :- + ( + PredAndArgsTerm = term__functor(term__atom("="), + [FuncAndArgsTerm, FuncResultTerm], _) -> - Result = ok([]) + FunctorTerm = FuncAndArgsTerm, + MaybeFuncResult = yes(FuncResultTerm) ; - Result = error("error in int list", - term__functor(Functor, Args, Context)) + FunctorTerm = PredAndArgsTerm, + MaybeFuncResult = no + ), + ( + MaybeModuleName = yes(ModuleName), + parse_implicitly_qualified_term(ModuleName, FunctorTerm, + ErrorTerm, Msg, Result) + ; + MaybeModuleName = no, + parse_qualified_term(FunctorTerm, ErrorTerm, Msg, Result) + ), + ( + Result = ok(SymName, Args), + PredAndArgsResult = ok(SymName, Args - MaybeFuncResult) + ; + Result = error(ErrorMsg, Term), + PredAndArgsResult = error(ErrorMsg, Term) ). :- pred convert_bool_list(term::in, list(bool)::out) is semidet. @@ -1126,3 +1036,56 @@ convert_bool_list(term__functor(Functor, Args, _), Bools) :- Args = [], Bools = [] ). + +:- pred convert_int_list(term::in, maybe1(list(int))::out) is det. + +convert_int_list(ListTerm, Result) :- + convert_list(ListTerm, + lambda([Term::in, Int::out] is semidet, ( + Term = term__functor(term__integer(Int), [], _) + )), Result). + + % + % convert_list(T, P, M) will convert a term T into a list of + % type X where P is a predicate that converts each element of + % the list into the correct type. M will hold the list if the + % conversion succeded for each element of M, otherwise it will + % hold the error. + % +:- pred convert_list(term, pred(term, T), maybe1(list(T))). +:- mode convert_list(in, pred(in, out) is semidet, out) is det. + +convert_list(term__variable(V),_, error("variable in list", term__variable(V))). +convert_list(term__functor(Functor, Args, Context), Pred, Result) :- + ( + Functor = term__atom("."), + Args = [Term, RestTerm], + call(Pred, Term, Element) + -> + convert_list(RestTerm, Pred, RestResult), + ( + RestResult = ok(List0), + Result = ok([Element | List0]) + ; + RestResult = error(_, _), + Result = RestResult + ) + ; + Functor = term__atom("[]"), + Args = [] + -> + Result = ok([]) + ; + Result = error("error in list", + term__functor(Functor, Args, Context)) + ). + +:- pred convert_type_spec_pair(term::in, pair(tvar, type)::out) is semidet. + +convert_type_spec_pair(Term, TypeSpec) :- + Term = term__functor(term__atom("="), [TypeVarTerm, SpecTypeTerm0], _), + TypeVarTerm = term__variable(TypeVar0), + term__coerce_var(TypeVar0, TypeVar), + term__coerce(SpecTypeTerm0, SpecType), + TypeSpec = TypeVar - SpecType. + diff --git a/compiler/prog_io_util.m b/compiler/prog_io_util.m index 7957d9071..c8edb6eb2 100644 --- a/compiler/prog_io_util.m +++ b/compiler/prog_io_util.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1996-1998 The University of Melbourne. +% Copyright (C) 1996-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -32,13 +32,11 @@ :- type maybe2(T1, T2) ---> error(string, term) ; ok(T1, T2). -:- type maybe1(T) ---> error(string, term) - ; ok(T). - +:- type maybe1(T) == maybe1(T, generic). :- type maybe1(T, U) ---> error(string, term(U)) ; ok(T). -:- type maybe_functor == maybe2(sym_name, list(term)). +:- type maybe_functor == maybe_functor(generic). :- type maybe_functor(T) == maybe2(sym_name, list(term(T))). :- type maybe_item_and_context diff --git a/compiler/prog_util.m b/compiler/prog_util.m index b1e5fe9eb..104770a5e 100644 --- a/compiler/prog_util.m +++ b/compiler/prog_util.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1994-1998 The University of Melbourne. +% Copyright (C) 1994-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -73,6 +73,15 @@ %-----------------------------------------------------------------------------% + % make_pred_name_with_context(ModuleName, Prefix, PredOrFunc, PredName, + % Line, Counter, SymName). + % + % Create a predicate name with context, e.g. for introduced + % lambda or deforestation predicates. +:- pred make_pred_name(module_name, string, maybe(pred_or_func), + string, new_pred_id, sym_name). +:- mode make_pred_name(in, in, in, in, in, out) is det. + % make_pred_name_with_context(ModuleName, Prefix, PredOrFunc, PredName, % Line, Counter, SymName). % @@ -82,6 +91,11 @@ string, int, int, sym_name). :- mode make_pred_name_with_context(in, in, in, in, in, in, out) is det. +:- type new_pred_id + ---> counter(int, int) % Line number, Counter + ; type_subst(tvarset, type_subst) + . + %-----------------------------------------------------------------------------% % A pred declaration may contains just types, as in @@ -113,8 +127,8 @@ %-----------------------------------------------------------------------------% :- implementation. -:- import_module (inst). -:- import_module bool, string, int, map. +:- import_module mercury_to_mercury, (inst). +:- import_module bool, string, int, map, varset. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -306,15 +320,62 @@ match_sym_name(unqualified(Name), qualified(_, Name)). make_pred_name_with_context(ModuleName, Prefix, PredOrFunc, PredName, Line, Counter, SymName) :- + make_pred_name(ModuleName, Prefix, yes(PredOrFunc), PredName, + counter(Line, Counter), SymName). + +make_pred_name(ModuleName, Prefix, MaybePredOrFunc, PredName, + NewPredId, SymName) :- ( - PredOrFunc = predicate, - PFS = "pred" + MaybePredOrFunc = yes(PredOrFunc), + ( + PredOrFunc = predicate, + PFS = "pred" + ; + PredOrFunc = function, + PFS = "func" + ) ; - PredOrFunc = function, - PFS = "func" + MaybePredOrFunc = no, + PFS = "pred_or_func" ), - string__format("%s__%s__%s__%d__%d", - [s(Prefix), s(PFS), s(PredName), i(Line), i(Counter)], Name), + ( + NewPredId = counter(Line, Counter), + string__format("%d__%d", [i(Line), i(Counter)], PredIdStr) + ; + NewPredId = type_subst(VarSet, TypeSubst), + SubstToString = lambda([SubstElem::in, SubstStr::out] is det, ( + SubstElem = Var - Type, + varset__lookup_name(VarSet, Var, VarName), + mercury_type_to_string(VarSet, Type, TypeString), + string__append_list([VarName, " = ", TypeString], + SubstStr) + )), + list_to_string(SubstToString, TypeSubst, PredIdStr) + ), + + string__format("%s__%s__%s__%s", + [s(Prefix), s(PredIdStr), s(PFS), s(PredName)], Name), SymName = qualified(ModuleName, Name). +:- pred list_to_string(pred(T, string), list(T), string). +:- mode list_to_string(pred(in, out) is det, in, out) is det. + +list_to_string(Pred, List, String) :- + list_to_string_2(Pred, List, Strings, ["]"]), + string__append_list(["[" | Strings], String). + +:- pred list_to_string_2(pred(T, string), list(T), list(string), list(string)). +:- mode list_to_string_2(pred(in, out) is det, in, out, in) is det. + +list_to_string_2(_, []) --> []. +list_to_string_2(Pred, [T | Ts]) --> + { call(Pred, T, String) }, + [String], + ( { Ts = [] } -> + [] + ; + [", "], + list_to_string_2(Pred, Ts) + ). + %-----------------------------------------------------------------------------% diff --git a/compiler/type_util.m b/compiler/type_util.m index f46948811..e963618e5 100644 --- a/compiler/type_util.m +++ b/compiler/type_util.m @@ -88,6 +88,12 @@ :- pred construct_type(type_id, list(type), prog_context, (type)). :- mode construct_type(in, in, in, out) is det. + % Construct builtin types. +:- func int_type = (type). +:- func string_type = (type). +:- func float_type = (type). +:- func char_type = (type). + % Given a constant and an arity, return a type_id. % Fails if the constant is not an atom. @@ -386,6 +392,11 @@ construct_type(TypeId, Args, Context, Type) :- TypeId = SymName - _, construct_qualified_term(SymName, NewArgs, Context, Type). +int_type = Type :- construct_type(unqualified("int") - 0, [], Type). +string_type = Type :- construct_type(unqualified("string") - 0, [], Type). +float_type = Type :- construct_type(unqualified("float") - 0, [], Type). +char_type = Type :- construct_type(unqualified("character") - 0, [], Type). + %-----------------------------------------------------------------------------% % Given a constant and an arity, return a type_id. diff --git a/doc/reference_manual.texi b/doc/reference_manual.texi index eedd33b56..97a085101 100644 --- a/doc/reference_manual.texi +++ b/doc/reference_manual.texi @@ -3352,6 +3352,8 @@ There are several uses for @code{pragma} declarations: * Impurity:: Users can write impure Mercury code * Inlining:: Pragmas can be used to suggest or prevent procedure inlining. +* Type specialization:: Pragmas can be used to produce specialized + versions of polymorphic procedures. * Obsolescence:: Library developers can declare old versions of predicates or functions to be obsolete. * Source file name:: The @samp{source_file} pragma and @@ -4574,6 +4576,90 @@ simply for performance concerns (inlining can cause unwanted code bloat in some cases) or to prevent possibly dangerous inlining when using low-level C code. +@node Type specialization +@section Type specialization + +The overhead of polymorphism can in some cases be significant, especially +where polymorphic predicates make heavy use of class method calls or the +built-in unification and comparison routines. To avoid this, the programmer +can suggest to the compiler that a specialized version of a procedure should +be created for a specific set of argument types. + +@menu +* Syntax and semantics of type specialization pragmas:: +* When to use type specialization:: +* Implementation specific details:: +@end menu + +@node Syntax and semantics of type specialization pragmas +@subsection Syntax and semantics of type specialization pragmas + +A declaration of the form + +@example +:- pragma type_spec(@var{Name}/@var{Arity}, @var{Subst}). +:- pragma type_spec(@var{Name}(@var{Modes}), @var{Subst}). +@end example + +@noindent +suggests to the compiler that a specialized version of predicate(s) +or function(s) with name @var{Name} and arity @var{Arity} should be +created with the type substitution given by @var{Subst} applied to the +argument types. The second form of the declaration only suggests +specialization of the specified mode of the predicate or function. + +The substitution is written as a conjunction of bindings of the form +@w{@samp{@var{TypeVar} = @var{Type}}}, for example @w{@samp{K = int}} or +@w{@samp{(K = int, V = list(int))}}. + +The declarations + +@example +:- pred map__lookup(map(K, V), K, V). +:- pragma type_spec(map__lookup/3, K = int). +@end example + +@noindent +give a hint to the compiler that a version of @samp{map__lookup/3} should +be created for integer keys. + +Implementations are free to ignore @samp{pragma type_spec} declarations. +Implementations are also free to perform type specialization +even in the absense of any @samp{pragma type_spec} declarations. + +@node When to use type specialization +@subsection When to use type specialization + +The set of types for which a predicate or function should be specialized is +best determined by profiling your application. Overuse of type specialization +will result in code bloat. + +Type specialization of predicates or functions which +unify or compare polymorphic variables is most effective when +the specialized types are built-in types such as @samp{int}, @samp{float} +and @samp{string}, or enumeration types, since their unification and +comparison procedures are simple and can be inlined. + +Predicates or functions which make use of type class method calls +may also be candidates for specialization. Again, this is most effective +when the called type class methods are simple enough to be inlined. + +@node Implementation specific details +@subsection Implementation specific details + +The University of Melbourne Mercury compiler performs user-requested type +specializations when invoked with @samp{--user-guided-type-specialization}, +which is enabled at optimization level @samp{-O2} or higher. + +In the current implementation, the replacement types must be ground. +Substitutions such as @w{@samp{T = list(U)}} are not supported. +The compiler will warn about such substitutions, and will ignore +the request for specialization. This restriction may be lifted in the future. +@c The main reason for this restriction is that it is tricky to ensure that +@c any extra typeclass_infos that may be needed are ordered the same way in +@c different modules. The efficiency gain from replacing a type variable with +@c a non-ground type will usually be pretty small anyway. + @node Obsolescence @section Obsolescence diff --git a/doc/user_guide.texi b/doc/user_guide.texi index cc72e14b0..06ea5a089 100644 --- a/doc/user_guide.texi +++ b/doc/user_guide.texi @@ -3346,6 +3346,13 @@ the higher-order arguments are known. Specialize calls to polymorphic predicates where the polymorphic types are known. +@sp 1 +@item --user-guided-type-specialization +Enable specialization of polymorphic predicates for which +there are `:- pragma type_spec' declarations. +See the ``Type specialization'' section in the ``Pragmas'' +chapter of the Mercury Language Reference Manual for more details. + @sp 1 @item --higher-order-size-limit Set the maximum goal size of specialized versions created by diff --git a/library/private_builtin.m b/library/private_builtin.m index c05e9366e..bd01f5d4e 100644 --- a/library/private_builtin.m +++ b/library/private_builtin.m @@ -90,6 +90,11 @@ :- implementation. :- import_module require, string, std_util, int, float, char, string, list. +:- pragma inline(builtin_compare_int/3). +:- pragma inline(builtin_compare_character/3). +:- pragma inline(builtin_compare_string/3). +:- pragma inline(builtin_compare_float/3). + builtin_unify_int(X, X). builtin_index_int(X, X). @@ -150,7 +155,7 @@ builtin_compare_float(R, F1, F2) :- :- mode builtin_strcmp(out, in, in) is det. :- pragma c_code(builtin_strcmp(Res::out, S1::in, S2::in), - will_not_call_mercury, + [will_not_call_mercury, thread_safe], "Res = strcmp(S1, S2);"). :- external(builtin_unify_pred/2). @@ -224,12 +229,20 @@ compare_error :- :- mode type_info_from_typeclass_info(in, in, out) is det. % superclass_from_typeclass_info(TypeClassInfo, Index, SuperClass) - % extracts SuperClass from TypeClassInfo where TypeInfo is the Indexth - % superclass of the class. + % extracts SuperClass from TypeClassInfo where SuperClass is the + % Indexth superclass of the class. :- pred superclass_from_typeclass_info(typeclass_info(_), int, typeclass_info(_)). :- mode superclass_from_typeclass_info(in, in, out) is det. + % instance_constraint_from_typeclass_info(TypeClassInfo, Index, + % InstanceConstraintTypeClassInfo) + % extracts the typeclass_info for the Indexth typeclass constraint + % of the instance described by TypeClassInfo. +:- pred instance_constraint_from_typeclass_info( + typeclass_info(_), int, typeclass_info(_)). +:- mode instance_constraint_from_typeclass_info(in, in, out) is det. + %-----------------------------------------------------------------------------% :- implementation. @@ -397,18 +410,25 @@ void sys_init_type_info_module(void) { "). :- pragma c_code(type_info_from_typeclass_info(TypeClassInfo::in, Index::in, - TypeInfo::out), will_not_call_mercury, + TypeInfo::out), [will_not_call_mercury, thread_safe], " TypeInfo = MR_typeclass_info_type_info(TypeClassInfo, Index); "). :- pragma c_code(superclass_from_typeclass_info(TypeClassInfo0::in, Index::in, - TypeClassInfo::out), will_not_call_mercury, + TypeClassInfo::out), [will_not_call_mercury, thread_safe], " TypeClassInfo = MR_typeclass_info_superclass_info(TypeClassInfo0, Index); "). +:- pragma c_code(instance_constraint_from_typeclass_info(TypeClassInfo0::in, + Index::in, TypeClassInfo::out), [will_not_call_mercury, thread_safe], +" + TypeClassInfo = + MR_typeclass_info_arg_typeclass_info(TypeClassInfo0, Index); +"). + %-----------------------------------------------------------------------------% :- interface. diff --git a/samples/ultra_sub.m b/samples/ultra_sub.m index 3fffb4634..b9c3c9555 100644 --- a/samples/ultra_sub.m +++ b/samples/ultra_sub.m @@ -7,7 +7,7 @@ % % 'ultra_sub' is an extended version of zs' 'sub' command. The idea is that % it takes a pattern, a template and some strings, and matches the strings -% against the patter, binding some variables in the process. Then it +% against the pattern, binding some variables in the process. Then it % substitutes the variables in the template for the bindings from the pattern. % % usage: ultra_sub