for review: type specialization [2]
Simon Taylor
stayl at cs.mu.OZ.AU
Thu Apr 15 15:38:14 AEST 1999
Index: compiler/intermod.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/intermod.m,v
retrieving revision 1.63
diff -u -u -r1.63 intermod.m
--- intermod.m 1998/12/06 23:43:25 1.63
+++ intermod.m 1999/02/10 05:01:08
@@ -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_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 @@
% 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 @@
{ 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_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, 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.
@@ -1085,6 +1105,21 @@
[]
),
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.
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.292
diff -u -u -r1.292 make_hlds.m
--- make_hlds.m 1999/03/30 05:32:57 1.292
+++ make_hlds.m 1999/03/30 07:00:44
@@ -401,9 +401,14 @@
;
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).
{ Pragma = fact_table(_, _, _) },
@@ -776,6 +781,373 @@
%-----------------------------------------------------------------------------%
+:- 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
+ % - the replacement types are not ground
+:- 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").
+
+:- 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 +1321,7 @@
;
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 +1346,7 @@
;
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 +1354,7 @@
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 +1371,7 @@
% 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 +1416,9 @@
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 +1456,7 @@
{ 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 +3309,8 @@
{ 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 +3329,8 @@
{ 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 +5544,7 @@
)
;
undefined_pred_or_func_error(Pred, Arity, Context,
- "pragma fact_table"),
+ "`:- pragma fact_table' declaration"),
{ Module = Module0 },
{ Info = Info0 }
).
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_compile.m,v
retrieving revision 1.121
diff -u -u -r1.121 mercury_compile.m
--- mercury_compile.m 1999/03/28 07:30:40 1.121
+++ mercury_compile.m 1999/04/14 04:53:52
@@ -1635,14 +1635,15 @@
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)
;
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.155
diff -u -u -r1.155 mercury_to_mercury.m
--- mercury_to_mercury.m 1999/03/22 08:07:30 1.155
+++ mercury_to_mercury.m 1999/03/24 03:56:19
@@ -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 @@
%-----------------------------------------------------------------------------%
-:- 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) -->
@@ -347,6 +346,11 @@
{ 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")
;
@@ -2178,6 +2182,62 @@
io__write_string(", ")
),
mercury_output_pragma_c_code_vars(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).
%-----------------------------------------------------------------------------%
Index: compiler/module_qual.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/module_qual.m,v
retrieving revision 1.43
diff -u -u -r1.43 module_qual.m
--- module_qual.m 1999/02/14 13:02:37 1.43
+++ module_qual.m 1999/03/19 04:03:45
@@ -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_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),
@@ -726,6 +739,16 @@
[pragma_var(Var, Name, Mode) | PragmaVars], Info0, Info) -->
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,
Index: compiler/modules.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modules.m,v
retrieving revision 1.96
diff -u -u -r1.96 modules.m
--- modules.m 1999/02/09 00:27:44 1.96
+++ modules.m 1999/02/10 05:48:09
@@ -864,6 +864,7 @@
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).
Index: compiler/options.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/options.m,v
retrieving revision 1.255
diff -u -u -r1.255 options.m
--- options.m 1999/04/05 07:35:17 1.255
+++ options.m 1999/04/15 02:45:48
@@ -232,6 +232,7 @@
; intermod_unused_args
; optimize_higher_order
; type_specialization
+ ; user_guided_type_specialization
; higher_order_size_limit
; optimize_constructor_last_call
; optimize_duplicate_calls
@@ -574,6 +575,7 @@
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),
@@ -904,6 +906,10 @@
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).
@@ -1228,6 +1234,8 @@
optimize_saved_vars - bool(yes),
optimize_unused_args - bool(yes),
optimize_higher_order - bool(yes),
+ user_guided_type_specialization
+ - bool(yes),
deforestation - bool(yes),
constant_propagation - bool(yes),
optimize_repeat - int(4)
@@ -1832,10 +1840,10 @@
"--fact-table-max-array-size <n>",
"\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 <percentage>",
- "\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)."
]).
@@ -1942,7 +1950,11 @@
"--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'.",
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.162
diff -u -u -r1.162 polymorphism.m
--- polymorphism.m 1999/04/08 08:41:07 1.162
+++ polymorphism.m 1999/04/13 04:35:52
@@ -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
@@ -501,6 +507,9 @@
"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__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 @@
;
PredName = "superclass_from_typeclass_info",
TypeClassManipulator = superclass_from_typeclass_info
+ ;
+ PredName = "instance_constraint_from_typeclass_info",
+ TypeClassManipulator = instance_constraint_from_typeclass_info
).
%---------------------------------------------------------------------------%
Index: compiler/prog_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_data.m,v
retrieving revision 1.44
diff -u -u -r1.44 prog_data.m
--- prog_data.m 1999/02/12 03:46:58 1.44
+++ prog_data.m 1999/03/19 04:03:48
@@ -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
@@ -214,6 +221,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'.
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.18
diff -u -u -r1.18 prog_io_pragma.m
--- prog_io_pragma.m 1998/12/06 23:44:34 1.18
+++ prog_io_pragma.m 1999/04/15 01:20:16
@@ -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 @@
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 @@
)
;
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 @@
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 @@
;
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 @@
;
Result =
error(
- "wrong number of arguments in `pragma export(...)' declaration",
+ "wrong number of arguments in `:- pragma export' declaration",
ErrorTerm)
).
@@ -457,8 +329,8 @@
% 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 @@
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 @@
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 @@
;
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 @@
;
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 @@
)
;
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 @@
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 @@
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,45 @@
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'",
+ ErrorTerm)
).
parse_pragma_type(ModuleName, "terminates", PragmaTerms,
@@ -758,8 +659,8 @@
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 +682,13 @@
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 +797,37 @@
:- 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 +879,36 @@
(
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 +918,101 @@
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.
+ ).
-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),
+:- 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))).
+
+:- 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 +1035,56 @@
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.
+
Index: compiler/prog_io_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_util.m,v
retrieving revision 1.12
diff -u -u -r1.12 prog_io_util.m
--- prog_io_util.m 1998/11/20 04:09:02 1.12
+++ prog_io_util.m 1999/02/10 05:01:15
@@ -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
Index: compiler/prog_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_util.m,v
retrieving revision 1.43
diff -u -u -r1.43 prog_util.m
--- prog_util.m 1998/11/20 04:09:04 1.43
+++ prog_util.m 1999/04/15 01:23:14
@@ -78,10 +78,24 @@
%
% 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).
+ %
+ % Create a predicate name with context, e.g. for introduced
+ % lambda or deforestation predicates.
:- pred make_pred_name_with_context(module_name, string, pred_or_func,
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 @@
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) :-
+ (
+ MaybePredOrFunc = yes(PredOrFunc),
+ (
+ PredOrFunc = predicate,
+ PFS = "pred"
+ ;
+ PredOrFunc = function,
+ PFS = "func"
+ )
+ ;
+ MaybePredOrFunc = no,
+ PFS = "pred_or_func"
+ ),
(
- PredOrFunc = predicate,
- PFS = "pred"
+ NewPredId = counter(Line, Counter),
+ string__format("%d__%d", [i(Line), i(Counter)], PredIdStr)
;
- PredOrFunc = function,
- PFS = "func"
+ 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__%d__%d",
- [s(Prefix), s(PFS), s(PredName), i(Line), i(Counter)], Name),
+
+ 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)
+ ).
%-----------------------------------------------------------------------------%
Index: compiler/type_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/type_util.m,v
retrieving revision 1.64
diff -u -u -r1.64 type_util.m
--- type_util.m 1999/03/24 03:11:16 1.64
+++ type_util.m 1999/04/08 02:00:38
@@ -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.
@@ -385,6 +391,11 @@
),
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).
%-----------------------------------------------------------------------------%
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/staff/zs/imp/mercury/doc/reference_manual.texi,v
retrieving revision 1.136
diff -u -u -r1.136 reference_manual.texi
--- reference_manual.texi 1999/03/24 13:09:00 1.136
+++ reference_manual.texi 1999/03/30 01:31:11
@@ -3352,6 +3352,8 @@
* 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
@@ -4573,6 +4575,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.
+
+ at node Type specialization
+ at 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.
+
+ at menu
+* Syntax and semantics of type specialization pragmas::
+* When to use type specialization::
+* Implementation specific details::
+ at end menu
+
+ at node Syntax and semantics of type specialization pragmas
+ at subsection Syntax and semantics of type specialization pragmas
+
+A declaration of the form
+
+ at example
+:- pragma type_spec(@var{Name}/@var{Arity}, @var{Subst}).
+:- pragma type_spec(@var{Name}(@var{Modes}), @var{Subst}).
+ at end example
+
+ at 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
+ at w{@samp{@var{TypeVar} = @var{Type}}}, for example @w{@samp{K = int}} or
+ at w{@samp{(K = int, V = list(int))}}.
+
+The declarations
+
+ at example
+:- pred map__lookup(map(K, V), K, V).
+:- pragma type_spec(map__lookup/3, K = int).
+ at end example
+
+ at 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.
+
+ at node When to use type specialization
+ at 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 small 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 small enough to be inlined.
+
+ at node Implementation specific details
+ at 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.
+ at c The main reason for this restriction is that it is tricky to ensure that
+ at c any extra typeclass_infos that may be needed are ordered the same way in
+ at c different modules. The efficiency gain from replacing a type variable with
+ at c a non-ground type will usually be pretty small anyway.
@node Obsolescence
@section Obsolescence
Index: doc/user_guide.texi
===================================================================
RCS file: /home/staff/zs/imp/mercury/doc/user_guide.texi,v
retrieving revision 1.164
diff -u -u -r1.164 user_guide.texi
--- user_guide.texi 1999/04/14 22:50:54 1.164
+++ user_guide.texi 1999/04/15 02:43:10
@@ -3303,6 +3303,13 @@
the polymorphic types are known.
@sp 1
+ at 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.
+
+ at sp 1
@item --higher-order-size-limit
Set the maximum goal size of specialized versions created by
@samp{--optimize-higher-order} and @samp{--type-specialization}.
Index: library/private_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/private_builtin.m,v
retrieving revision 1.18
diff -u -u -r1.18 private_builtin.m
--- private_builtin.m 1999/04/08 08:42:02 1.18
+++ private_builtin.m 1999/04/13 04:53:40
@@ -113,12 +113,21 @@
:- 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 typeclass_info for the Indexth superclass of the class
+ % described by TypeClassInfo.
:- 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.
+
% the builtin < operator on ints, used in the code generated
% for compare/3 preds
:- pred builtin_int_lt(int, int).
@@ -403,20 +412,32 @@
% the compiler generates code for them inline.
:- 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);
+").
+
%-----------------------------------------------------------------------------%
+:- 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).
@@ -477,7 +498,7 @@
:- 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);").
builtin_index_non_canonical_type(_, -1).
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/tests/hard_coded/Mmakefile,v
retrieving revision 1.54
diff -u -u -r1.54 Mmakefile
--- Mmakefile 1999/03/26 04:34:14 1.54
+++ Mmakefile 1999/04/13 04:13:08
@@ -89,6 +89,7 @@
test_imported_no_tag \
term_io_test \
tim_qual1 \
+ type_spec \
write \
write_reg1
@@ -99,6 +100,7 @@
# some tests need to be compiled with particular options
+MCFLAGS-bigtest = --intermodule-optimization -O3
MCFLAGS-boyer = --infer-all
MCFLAGS-func_test = --infer-all
MCFLAGS-ho_order = --optimize-higher-order
@@ -106,7 +108,7 @@
MCFLAGS-no_fully_strict = --no-fully-strict
MCFLAGS-nondet_ctrl_vn = --optimize-value-number
MCFLAGS-rnd = -O6
-MCFLAGS-bigtest = --intermodule-optimization -O3
+MCFLAGS-type_spec = --user-guided-type-specialization
# In grade `none' with options `-O1 --opt-space' on kryten
# (a sparc-sun-solaris2.5 system), mode_choice needs to be linked
Index: tests/hard_coded/type_spec.exp
===================================================================
RCS file: type_spec.exp
diff -N type_spec.exp
--- /dev/null Thu Apr 15 15:17:20 1999
+++ type_spec.exp Thu Apr 15 10:42:53 1999
@@ -0,0 +1,4 @@
+[3]
+[3]
+Succeeded
+Succeeded
Index: tests/hard_coded/type_spec.m
===================================================================
RCS file: type_spec.m
diff -N type_spec.m
--- /dev/null Thu Apr 15 15:17:20 1999
+++ type_spec.m Thu Apr 15 10:41:42 1999
@@ -0,0 +1,108 @@
+:- module type_spec.
+
+:- interface.
+
+:- import_module io.
+:- import_module int, list.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- typeclass comparable_t(T) where [
+ pred compare_t(comparison_result::out, T::in, T::in) is det
+].
+
+:- instance comparable_t(int) where [
+ pred(compare_t/3) is compare_int
+].
+:- pred compare_int(comparison_result::out, int::in, int::in) is det.
+
+:- pred type_spec(list(T)::in, list(T)::in, list(T)::out) is det.
+:- pragma type_spec(type_spec/3, T = int).
+
+:- pred typeclass_spec(list(T)::in, list(T)::in,
+ list(T)::out) is det <= comparable_t(T).
+:- pragma type_spec(typeclass_spec/3, T = int).
+
+:- typeclass all_zero(T) where [
+ pred all_zero(T::in) is semidet
+ ].
+
+:- instance all_zero(list(T)) <= all_zero(T) where [
+ pred(all_zero/1) is list_all_zero
+ ].
+
+:- instance all_zero(int) where [
+ pred(all_zero/1) is is_zero
+ ].
+
+:- pred is_zero(int::in) is semidet.
+
+ % This tests the case where higher_order.m must extract
+ % the typeclass_infos for the constraints on an instance
+ % declaration when specializing a class method call.
+:- pred list_all_zero(list(T)::in) is semidet <= all_zero(T).
+:- pragma type_spec(list_all_zero/1, T = int).
+
+:- implementation.
+
+main -->
+ { type_spec([1,2,3], [3,4,5], Result1) },
+ io__write(Result1),
+ io__nl,
+ { typeclass_spec([1,2,3], [3,4,5], Result2) },
+ io__write(Result2),
+ io__nl,
+ ( { all_zero([0,1,2,3]) } ->
+ io__write_string("Failed\n")
+ ;
+ io__write_string("Succeeded\n")
+ ),
+ ( { all_zero([0,0,0]) } ->
+ io__write_string("Succeeded\n")
+ ;
+ io__write_string("Failed\n")
+ ).
+
+type_spec([], [], []).
+type_spec([_ | _], [], []).
+type_spec([], [_ | _], []).
+type_spec([A | As], [B | Bs], Cs) :-
+ compare(Result, A, B),
+ ( Result = (<) ->
+ type_spec(As, [B | Bs], Cs)
+ ; Result = (=) ->
+ type_spec(As, Bs, Cs1),
+ Cs = [A | Cs1]
+ ;
+ type_spec([A | As], Bs, Cs)
+ ).
+
+typeclass_spec([], [], []).
+typeclass_spec([_ | _], [], []).
+typeclass_spec([], [_ | _], []).
+typeclass_spec([A | As], [B | Bs], Cs) :-
+ compare_t(Result, A, B),
+ ( Result = (<) ->
+ typeclass_spec(As, [B | Bs], Cs)
+ ; Result = (=) ->
+ typeclass_spec(As, Bs, Cs1),
+ Cs = [A | Cs1]
+ ;
+ typeclass_spec([A | As], Bs, Cs)
+ ).
+
+compare_int(Result, Int1, Int2) :-
+ ( Int1 < Int2 ->
+ Result = (<)
+ ; Int1 = Int2 ->
+ Result = (=)
+ ;
+ Result = (>)
+ ).
+
+list_all_zero([]).
+list_all_zero([H | T]) :-
+ all_zero(H),
+ list_all_zero(T).
+
+is_zero(0).
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/tests/invalid/Mmakefile,v
retrieving revision 1.37
diff -u -u -r1.37 Mmakefile
--- Mmakefile 1999/02/12 04:19:30 1.37
+++ Mmakefile 1999/03/30 06:44:54
@@ -56,6 +56,7 @@
typeclass_test_7.m \
typeclass_test_9.m \
types.m \
+ type_spec.m \
unbound_inst_var.m \
undef_lambda_mode.m \
undef_mode.m \
Index: tests/invalid/type_spec.err_exp
===================================================================
RCS file: type_spec.err_exp
diff -N type_spec.err_exp
--- /dev/null Thu Apr 15 15:17:20 1999
+++ type_spec.err_exp Tue Mar 30 17:05:20 1999
@@ -0,0 +1,13 @@
+type_spec.m:010: In `:- pragma type_spec' declaration for predicate `type_spec:type_spec1/1':
+type_spec.m:010: error: variable `U' does not occur in the `:- pred' declaration.
+type_spec.m:011: Error: `:- pragma type_spec' declaration for
+type_spec.m:011: `type_spec:type_spec1/1' specifies non-existent mode.
+type_spec.m:012: In `:- pragma type_spec' declaration for predicate `type_spec:type_spec1/1':
+type_spec.m:012: warning: the substitution does not make the substituted
+type_spec.m:012: types ground. The declaration will be ignored.
+type_spec.m:013: Error: `:- pragma type_spec' declaration for type_spec:type_spec1/2
+type_spec.m:013: without corresponding `pred' or `func' declaration.
+type_spec.m:024: In `:- pragma type_spec' declaration for predicate `type_spec:type_spec2/1':
+type_spec.m:024: error: the substitution includes the existentially
+type_spec.m:024: quantified type variable `U'.
+For more information, try recompiling with `-E'.
Index: tests/invalid/type_spec.m
===================================================================
RCS file: type_spec.m
diff -N type_spec.m
--- /dev/null Thu Apr 15 15:17:20 1999
+++ type_spec.m Tue Mar 30 16:43:14 1999
@@ -0,0 +1,25 @@
+:- module type_spec.
+
+:- interface.
+
+:- import_module list.
+
+:- pred type_spec1(list(T)::in) is semidet.
+:- external(type_spec1/1).
+
+:- pragma type_spec(type_spec1/1, U = int).
+:- pragma type_spec(type_spec1(out), T = int).
+:- pragma type_spec(type_spec1/1, T = list(U)).
+:- pragma type_spec(type_spec1/2, T = int).
+
+:- typeclass fooable(T) where [
+ pred foo(T),
+ mode foo(in) is semidet
+ ].
+
+:- type the_type(T, U).
+:- some [U] pred type_spec2(the_type(T, U)::in) is semidet => fooable(U).
+:- external(type_spec2/1).
+
+:- pragma type_spec(type_spec2/1, U = int).
+
More information about the developers
mailing list