for review: type specialization [2]
Simon Taylor
stayl at cs.mu.OZ.AU
Wed Feb 17 12:25:19 AEDT 1999
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_compile.m,v
retrieving revision 1.117
diff -u -r1.117 mercury_compile.m
--- mercury_compile.m 1998/12/06 23:43:45 1.117
+++ mercury_compile.m 1999/02/10 05:01:11
@@ -1632,14 +1632,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.152
diff -u -r1.152 mercury_to_mercury.m
--- mercury_to_mercury.m 1998/12/06 23:43:48 1.152
+++ mercury_to_mercury.m 1999/02/10 05:01:11
@@ -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")
;
@@ -2174,6 +2178,63 @@
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(", ["),
+ list__foldl(mercury_output_type_subst(VarSet), Subst),
+
+ 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.42
diff -u -r1.42 module_qual.m
--- module_qual.m 1998/12/06 23:43:55 1.42
+++ module_qual.m 1999/02/10 05:01:12
@@ -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 -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.252
diff -u -r1.252 options.m
--- options.m 1998/12/06 23:44:15 1.252
+++ options.m 1999/02/10 05:01:13
@@ -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).
@@ -1224,6 +1230,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)
@@ -1939,7 +1947,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/prog_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_data.m,v
retrieving revision 1.43
diff -u -r1.43 prog_data.m
--- prog_data.m 1998/12/06 23:44:32 1.43
+++ prog_data.m 1999/02/10 05:01:14
@@ -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)), assoc_list(tvar, type), 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
Index: compiler/prog_io.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io.m,v
retrieving revision 1.180
diff -u -r1.180 prog_io.m
--- prog_io.m 1999/02/08 20:52:38 1.180
+++ prog_io.m 1999/02/10 05:48:13
@@ -110,21 +110,15 @@
:- pred search_for_file(list(dir_name), file_name, bool, io__state, io__state).
:- mode search_for_file(in, in, out, di, uo) is det.
- % parse_item(ModuleName, VarSet, Term, MaybeItem)
- %
- % parse Term. If successful, MaybeItem is bound to the parsed item,
- % otherwise it is bound to an appropriate error message.
- % Qualify appropriate parts of the item, with ModuleName as the
- % module name.
-:- pred parse_item(module_name, varset, term, maybe_item_and_context).
-:- mode parse_item(in, in, in, out) is det.
-
% parse_decl(ModuleName, VarSet, Term, Result)
%
% parse Term as a declaration. If successful, Result is bound to the
% parsed item, otherwise it is bound to an appropriate error message.
% Qualify appropriate parts of the item, with ModuleName as the module
% name.
+ % The item should not be a `:- pragma type_spec(...)'
+ % declaration, since that would require a counter to be
+ % threaded through.
:- pred parse_decl(module_name, varset, term, maybe_item_and_context).
:- mode parse_decl(in, in, in, out) is det.
@@ -177,6 +171,12 @@
maybe_functor(T)).
:- mode parse_implicitly_qualified_term(in, in, in, in, out) is det.
+ % We use the empty module name ('') as the "root" module name;
+ % when adding default module qualifiers in
+ % parse_implicitly_qualified_{term,symbol}, if the default module
+ % is the root module then we don't add any qualifier.
+:- pred root_module_name(module_name::out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -448,7 +448,8 @@
%
parser__read_term(SourceFileName, MaybeFirstTerm),
{ root_module_name(RootModuleName) },
- { process_read_term(RootModuleName, MaybeFirstTerm, MaybeFirstItem) },
+ { process_read_term(RootModuleName, MaybeFirstTerm, MaybeFirstItem,
+ 0, _) },
(
%
% apply and then skip `pragma source_file' decls,
@@ -501,7 +502,8 @@
{ make_module_decl(ModuleName, FirstContext, FixedFirstItem) },
{ Items0 = [FixedFirstItem] },
{ Error0 = no },
- read_items_loop(ModuleName, SourceFileName,
+ { Counter = 0 },
+ read_items_loop(ModuleName, SourceFileName, Counter,
Messages0, Items0, Error0,
Messages, Items, Error)
;
@@ -532,13 +534,14 @@
% `:- module' decl rather than in the root module.
%
{ MaybeSecondTerm = MaybeFirstTerm },
+ { Counter0 = 0 },
{ process_read_term(ModuleName, MaybeSecondTerm,
- MaybeSecondItem) },
+ MaybeSecondItem, Counter0, Counter) },
{ Items0 = [FixedFirstItem] },
{ Error0 = no },
read_items_loop_2(MaybeSecondItem, ModuleName, SourceFileName,
- Messages0, Items0, Error0,
+ Counter, Messages0, Items0, Error0,
Messages, Items, Error)
).
@@ -574,34 +577,36 @@
% via io__gc_call/1, which called the goal with garbage collection.
% But optimizing for NU-Prolog is no longer a big priority...
-:- pred read_items_loop(module_name, file_name,
+:- pred read_items_loop(module_name, file_name, int,
message_list, item_list, module_error,
message_list, item_list, module_error,
io__state, io__state).
-:- mode read_items_loop(in, in, in, in, in, out, out, out, di, uo) is det.
+:- mode read_items_loop(in, in, in, in, in, in, out, out, out, di, uo) is det.
-read_items_loop(ModuleName, SourceFileName, Msgs1, Items1, Error1,
+read_items_loop(ModuleName, SourceFileName, Counter0, Msgs1, Items1, Error1,
Msgs, Items, Error) -->
- read_item(ModuleName, SourceFileName, MaybeItem),
- read_items_loop_2(MaybeItem, ModuleName, SourceFileName,
+ read_item(ModuleName, SourceFileName, MaybeItem, Counter0, Counter1),
+ read_items_loop_2(MaybeItem, ModuleName, SourceFileName, Counter1,
Msgs1, Items1, Error1, Msgs, Items, Error).
%-----------------------------------------------------------------------------%
-:- pred read_items_loop_2(maybe_item_or_eof, module_name, file_name,
+:- pred read_items_loop_2(maybe_item_or_eof, module_name, file_name, int,
message_list, item_list, module_error,
message_list, item_list, module_error,
io__state, io__state).
-:- mode read_items_loop_2(in, in, in, in, in, in, out, out, out, di, uo) is det.
+:- mode read_items_loop_2(in, in, in, in, in, in, in,
+ out, out, out, di, uo) is det.
% do a switch on the type of the next item
-read_items_loop_2(eof, _ModuleName, _SourceFileName, Msgs, Items, Error,
- Msgs, Items, Error) --> [].
+read_items_loop_2(eof, _ModuleName, _SourceFileName, _Counter,
+ Msgs, Items, Error, Msgs, Items, Error) --> [].
% if the next item was end-of-file, then we're done.
read_items_loop_2(syntax_error(ErrorMsg, LineNumber), ModuleName,
- SourceFileName, Msgs0, Items0, _Error0, Msgs, Items, Error) -->
+ SourceFileName, Counter, Msgs0, Items0,
+ _Error0, Msgs, Items, Error) -->
% if the next item was a syntax error, then insert it in
% the list of messages and continue looping
{
@@ -612,10 +617,10 @@
Items1 = Items0,
Error1 = yes
},
- read_items_loop(ModuleName, SourceFileName, Msgs1, Items1, Error1,
- Msgs, Items, Error).
+ read_items_loop(ModuleName, SourceFileName, Counter,
+ Msgs1, Items1, Error1, Msgs, Items, Error).
-read_items_loop_2(error(M, T), ModuleName, SourceFileName,
+read_items_loop_2(error(M, T), ModuleName, SourceFileName, Counter,
Msgs0, Items0, _Error0, Msgs, Items, Error) -->
% if the next item was a semantic error, then insert it in
% the list of messages and continue looping
@@ -624,10 +629,10 @@
Items1 = Items0,
Error1 = yes
},
- read_items_loop(ModuleName, SourceFileName, Msgs1, Items1, Error1,
- Msgs, Items, Error).
+ read_items_loop(ModuleName, SourceFileName, Counter,
+ Msgs1, Items1, Error1, Msgs, Items, Error).
-read_items_loop_2(ok(Item, Context), ModuleName0, SourceFileName0,
+read_items_loop_2(ok(Item, Context), ModuleName0, SourceFileName0, Counter,
Msgs0, Items0, Error0, Msgs, Items, Error) -->
% if the next item was a valid item, check whether it was
% a declaration that affects the current parsing context --
@@ -656,8 +661,8 @@
ModuleName = ModuleName0,
Items1 = [Item - Context | Items0]
},
- read_items_loop(ModuleName, SourceFileName, Msgs0, Items1, Error0,
- Msgs, Items, Error).
+ read_items_loop(ModuleName, SourceFileName, Counter,
+ Msgs0, Items1, Error0, Msgs, Items, Error).
%-----------------------------------------------------------------------------%
@@ -669,23 +674,24 @@
; error(string, term)
; ok(item, term__context).
-:- pred read_item(module_name, file_name, maybe_item_or_eof,
+:- pred read_item(module_name, file_name, maybe_item_or_eof, int, int,
io__state, io__state).
-:- mode read_item(in, in, out, di, uo) is det.
+:- mode read_item(in, in, out, in, out, di, uo) is det.
-read_item(ModuleName, SourceFileName, MaybeItem) -->
+read_item(ModuleName, SourceFileName, MaybeItem, Counter0, Counter) -->
parser__read_term(SourceFileName, MaybeTerm),
- { process_read_term(ModuleName, MaybeTerm, MaybeItem) }.
+ { process_read_term(ModuleName, MaybeTerm, MaybeItem,
+ Counter0, Counter) }.
-:- pred process_read_term(module_name, read_term, maybe_item_or_eof).
-:- mode process_read_term(in, in, out) is det.
+:- pred process_read_term(module_name, read_term, maybe_item_or_eof, int, int).
+:- mode process_read_term(in, in, out, in, out) is det.
-process_read_term(_ModuleName, eof, eof).
+process_read_term(_ModuleName, eof, eof, Counter, Counter).
process_read_term(_ModuleName, error(ErrorMsg, LineNumber),
- syntax_error(ErrorMsg, LineNumber)).
+ syntax_error(ErrorMsg, LineNumber), Counter, Counter).
process_read_term(ModuleName, term(VarSet, Term),
- MaybeItemOrEof) :-
- parse_item(ModuleName, VarSet, Term, MaybeItem),
+ MaybeItemOrEof, Counter0, Counter) :-
+ parse_item(ModuleName, VarSet, Term, MaybeItem, Counter0, Counter),
convert_item(MaybeItem, MaybeItemOrEof).
:- pred convert_item(maybe_item_and_context, maybe_item_or_eof).
@@ -694,20 +700,32 @@
convert_item(ok(Item, Context), ok(Item, Context)).
convert_item(error(M, T), error(M, T)).
-parse_item(ModuleName, VarSet, Term, Result) :-
+ % parse_item(ModuleName, VarSet, Term, MaybeItem, Counter0, Counter)
+ %
+ % parse Term. If successful, MaybeItem is bound to the parsed item,
+ % otherwise it is bound to an appropriate error message.
+ % Qualify appropriate parts of the item, with ModuleName as the
+ % module name.
+:- pred parse_item(module_name, varset, term,
+ maybe_item_and_context, int, int).
+:- mode parse_item(in, in, in, out, in, out) is det.
+
+parse_item(ModuleName, VarSet, Term, Result, Counter0, Counter) :-
( %%% some [Decl, DeclContext]
Term = term__functor(term__atom(":-"), [Decl], _DeclContext)
->
% It's a declaration
- parse_decl(ModuleName, VarSet, Decl, Result)
+ parse_decl(ModuleName, VarSet, Decl, Result, Counter0, Counter)
; %%% some [DCG_H, DCG_B, DCG_Context]
% It's a DCG clause
Term = term__functor(term__atom("-->"), [DCG_H, DCG_B],
DCG_Context)
->
+ Counter = Counter0,
parse_dcg_clause(ModuleName, VarSet, DCG_H, DCG_B,
DCG_Context, Result)
;
+ Counter = Counter0,
% It's either a fact or a rule
( %%% some [H, B, TermContext]
Term = term__functor(term__atom(":-"), [H, B],
@@ -790,18 +808,26 @@
% where they are not allowed.
parse_decl(ModuleName, VarSet, F, Result) :-
- parse_decl_2(ModuleName, VarSet, F, [], Result).
+ parse_decl(ModuleName, VarSet, F, Result, 0, _).
+
+:- pred parse_decl(module_name, varset, term, maybe_item_and_context,
+ int, int).
+:- mode parse_decl(in, in, in, out, in, out) is det.
+
+parse_decl(ModuleName, VarSet, F, Result, Counter0, Counter) :-
+ parse_decl_2(ModuleName, VarSet, F, [], Result, Counter0, Counter).
- % parse_decl_2(ModuleName, VarSet, Term, Attributes, Result)
+ % parse_decl_2(ModuleName, VarSet, Term, Attributes, Result,
+ % Counter0, Counter)
% succeeds if Term is a declaration and binds Result to a
% representation of that declaration. Attributes is a list
% of enclosing declaration attributes, in the order innermost to
% outermost.
:- pred parse_decl_2(module_name, varset, term, decl_attrs,
- maybe_item_and_context).
-:- mode parse_decl_2(in, in, in, in, out) is det.
+ maybe_item_and_context, int, int).
+:- mode parse_decl_2(in, in, in, in, out, in, out) is det.
-parse_decl_2(ModuleName, VarSet, F, Attributes, Result) :-
+parse_decl_2(ModuleName, VarSet, F, Attributes, Result, Counter0, Counter) :-
(
F = term__functor(term__atom(Atom), Args, Context)
->
@@ -810,16 +836,19 @@
->
NewAttributes = [Attribute - F | Attributes],
parse_decl_2(ModuleName, VarSet, SubTerm,
- NewAttributes, Result)
+ NewAttributes, Result, Counter0, Counter)
;
process_decl(ModuleName, VarSet, Atom, Args,
- Attributes, R)
+ Attributes, R, Counter0, Counter1)
->
+ Counter = Counter1,
add_context(R, Context, Result)
;
+ Counter = Counter0,
Result = error("unrecognized declaration", F)
)
;
+ Counter = Counter0,
Result = error("atom expected after `:-'", F)
).
@@ -829,161 +858,172 @@
% of enclosing declaration attributes, in the order outermost to
% innermost.
:- pred process_decl(module_name, varset, string, list(term), decl_attrs,
- maybe1(item)).
-:- mode process_decl(in, in, in, in, in, out) is semidet.
+ maybe1(item), int, int).
+:- mode process_decl(in, in, in, in, in, out, in, out) is semidet.
-process_decl(ModuleName, VarSet, "type", [TypeDecl], Attributes, Result) :-
+process_decl(ModuleName, VarSet, "type", [TypeDecl], Attributes,
+ Result, Counter, Counter) :-
parse_type_decl(ModuleName, VarSet, TypeDecl, Result0),
check_no_attributes(Result0, Attributes, Result).
-process_decl(ModuleName, VarSet, "pred", [PredDecl], Attributes, Result) :-
+process_decl(ModuleName, VarSet, "pred", [PredDecl], Attributes,
+ Result, Counter, Counter) :-
parse_type_decl_pred(ModuleName, VarSet, PredDecl, Attributes, Result).
-process_decl(ModuleName, VarSet, "func", [FuncDecl], Attributes, Result) :-
+process_decl(ModuleName, VarSet, "func", [FuncDecl], Attributes,
+ Result, Counter, Counter) :-
parse_type_decl_func(ModuleName, VarSet, FuncDecl, Attributes, Result).
-process_decl(ModuleName, VarSet, "mode", [ModeDecl], Attributes, Result) :-
+process_decl(ModuleName, VarSet, "mode", [ModeDecl], Attributes,
+ Result, Counter, Counter) :-
parse_mode_decl(ModuleName, VarSet, ModeDecl, Result0),
check_no_attributes(Result0, Attributes, Result).
-process_decl(ModuleName, VarSet, "inst", [InstDecl], Attributes, Result) :-
+process_decl(ModuleName, VarSet, "inst", [InstDecl], Attributes,
+ Result, Counter, Counter) :-
parse_inst_decl(ModuleName, VarSet, InstDecl, Result0),
check_no_attributes(Result0, Attributes, Result).
process_decl(_ModuleName, VarSet, "import_module", [ModuleSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_module_specifier, make_module, make_import,
ModuleSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "use_module", [ModuleSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_module_specifier, make_module, make_use,
ModuleSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "export_module", [ModuleSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_module_specifier, make_module, make_export,
ModuleSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "import_sym", [SymSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_symbol_specifier, make_sym, make_import,
SymSpec, Attributes, VarSet, Result).
-process_decl(_ModuleName, VarSet, "use_sym", [SymSpec], Attributes, Result) :-
+process_decl(_ModuleName, VarSet, "use_sym", [SymSpec], Attributes,
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_symbol_specifier, make_sym, make_use,
SymSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "export_sym", [SymSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_symbol_specifier, make_sym, make_export,
SymSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "import_pred", [PredSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_predicate_specifier, make_pred, make_import,
PredSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "use_pred", [PredSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_predicate_specifier, make_pred, make_use,
PredSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "export_pred", [PredSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_predicate_specifier, make_pred, make_export,
PredSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "import_func", [FuncSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_function_specifier, make_func, make_import,
FuncSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "use_func", [FuncSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_function_specifier, make_func, make_use,
FuncSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "export_func", [FuncSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_function_specifier, make_func, make_export,
FuncSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "import_cons", [ConsSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_constructor_specifier, make_cons, make_import,
ConsSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "use_cons", [ConsSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_constructor_specifier, make_cons, make_use,
ConsSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "export_cons", [ConsSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_constructor_specifier, make_cons, make_export,
ConsSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "import_type", [TypeSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_type_specifier, make_type, make_import,
TypeSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "use_type", [TypeSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_type_specifier, make_type, make_use,
TypeSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "export_type", [TypeSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_type_specifier, make_type, make_export,
TypeSpec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "import_adt", [ADT_Spec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_adt_specifier, make_adt, make_import,
ADT_Spec, Attributes, VarSet, Result).
-process_decl(_ModuleName, VarSet, "use_adt", [ADT_Spec], Attributes, Result) :-
+process_decl(_ModuleName, VarSet, "use_adt", [ADT_Spec], Attributes, Result,
+ Counter, Counter) :-
parse_symlist_decl(parse_adt_specifier, make_adt, make_use,
ADT_Spec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "export_adt", [ADT_Spec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_adt_specifier, make_adt, make_export,
ADT_Spec, Attributes, VarSet, Result).
process_decl(_ModuleName, VarSet, "import_op", [OpSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symlist_decl(parse_op_specifier, make_op, make_import,
OpSpec, Attributes, VarSet, Result).
-process_decl(_ModuleName, VarSet, "use_op", [OpSpec], Attributes, Result) :-
+process_decl(_ModuleName, VarSet, "use_op", [OpSpec], Attributes, Result,
+ Counter, Counter) :-
parse_symlist_decl(parse_op_specifier, make_op, make_use,
OpSpec, Attributes, VarSet, Result).
-process_decl(_ModuleName, VarSet, "export_op", [OpSpec], Attributes, Result) :-
+process_decl(_ModuleName, VarSet, "export_op", [OpSpec], Attributes, Result,
+ Counter, Counter) :-
parse_symlist_decl(parse_op_specifier, make_op, make_export,
OpSpec, Attributes, VarSet, Result).
-process_decl(_ModuleName, VarSet0, "interface", [], Attributes, Result) :-
+process_decl(_ModuleName, VarSet0, "interface", [], Attributes, Result,
+ Counter, Counter) :-
varset__coerce(VarSet0, VarSet),
Result0 = ok(module_defn(VarSet, interface)),
check_no_attributes(Result0, Attributes, Result).
-process_decl(_ModuleName, VarSet0, "implementation", [], Attributes, Result) :-
+process_decl(_ModuleName, VarSet0, "implementation", [], Attributes, Result,
+ Counter, Counter) :-
varset__coerce(VarSet0, VarSet),
Result0 = ok(module_defn(VarSet, implementation)),
check_no_attributes(Result0, Attributes, Result).
process_decl(_ModuleName, VarSet, "external", [PredSpec], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_symbol_name_specifier(PredSpec, Result0),
process_maybe1(make_external(VarSet), Result0, Result1),
check_no_attributes(Result1, Attributes, Result).
process_decl(DefaultModuleName, VarSet0, "module", [ModuleName], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
parse_module_name(DefaultModuleName, ModuleName, Result0),
(
Result0 = ok(ModuleNameSym),
@@ -996,7 +1036,7 @@
check_no_attributes(Result1, Attributes, Result).
process_decl(DefaultModuleName, VarSet0, "include_module", [ModuleNames],
- Attributes, Result) :-
+ Attributes, Result, Counter, Counter) :-
parse_list(parse_module_name(DefaultModuleName), ModuleNames, Result0),
(
Result0 = ok(ModuleNameSyms),
@@ -1010,7 +1050,7 @@
check_no_attributes(Result1, Attributes, Result).
process_decl(DefaultModuleName, VarSet0, "end_module", [ModuleName],
- Attributes, Result) :-
+ Attributes, Result, Counter, Counter) :-
%
% The name in an `end_module' declaration not inside the
% scope of the module being ended, so the default module name
@@ -1033,19 +1073,22 @@
% NU-Prolog `when' declarations are silently ignored for
% backwards compatibility.
process_decl(_ModuleName, _VarSet, "when", [_Goal, _Cond], Attributes,
- Result) :-
+ Result, Counter, Counter) :-
Result0 = ok(nothing),
check_no_attributes(Result0, Attributes, Result).
-process_decl(ModuleName, VarSet, "pragma", Pragma, Attributes, Result):-
- parse_pragma(ModuleName, VarSet, Pragma, Result0),
+process_decl(ModuleName, VarSet, "pragma", Pragma, Attributes,
+ Result, Counter0, Counter) :-
+ parse_pragma(ModuleName, VarSet, Pragma, Result0, Counter0, Counter),
check_no_attributes(Result0, Attributes, Result).
-process_decl(ModuleName, VarSet, "typeclass", Args, Attributes, Result):-
+process_decl(ModuleName, VarSet, "typeclass", Args, Attributes,
+ Result, Counter, Counter) :-
parse_typeclass(ModuleName, VarSet, Args, Result0),
check_no_attributes(Result0, Attributes, Result).
-process_decl(ModuleName, VarSet, "instance", Args, Attributes, Result):-
+process_decl(ModuleName, VarSet, "instance", Args, Attributes,
+ Result, Counter, Counter) :-
parse_instance(ModuleName, VarSet, Args, Result0),
check_no_attributes(Result0, Attributes, Result).
@@ -2851,11 +2894,6 @@
%-----------------------------------------------------------------------------%
-% We use the empty module name ('') as the "root" module name; when adding
-% default module qualifiers in parse_implicitly_qualified_{term,symbol},
-% if the default module is the root module then we don't add any qualifier.
-
-:- pred root_module_name(module_name::out) is det.
root_module_name(unqualified("")).
%-----------------------------------------------------------------------------%
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 -r1.18 prog_io_pragma.m
--- prog_io_pragma.m 1998/12/06 23:44:34 1.18
+++ prog_io_pragma.m 1999/02/10 05:01:15
@@ -17,23 +17,25 @@
:- import_module list, varset, term.
% parse the pragma declaration.
-:- pred parse_pragma(module_name, varset, list(term), maybe1(item)).
-:- mode parse_pragma(in, in, in, out) is semidet.
+:- pred parse_pragma(module_name, varset, list(term), maybe1(item), int, int).
+:- mode parse_pragma(in, in, in, out, in, out) is semidet.
:- 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) :-
+parse_pragma(ModuleName, VarSet, PragmaTerms, Result, Counter0, Counter) :-
(
% new syntax: `:- pragma foo(...).'
PragmaTerms = [SinglePragmaTerm],
SinglePragmaTerm = term__functor(term__atom(PragmaType),
PragmaArgs, _),
parse_pragma_type(ModuleName, PragmaType, PragmaArgs,
- SinglePragmaTerm, VarSet, Result0)
+ SinglePragmaTerm, VarSet, Result0, Counter0, Counter1)
->
+ Counter = Counter1,
Result = Result0
;
% old syntax: `:- pragma(foo, ...).'
@@ -41,18 +43,20 @@
PragmaTerms = [PragmaTypeTerm | PragmaArgs2],
PragmaTypeTerm = term__functor(term__atom(PragmaType), [], _),
parse_pragma_type(ModuleName, PragmaType, PragmaArgs2,
- PragmaTypeTerm, VarSet, Result1)
+ PragmaTypeTerm, VarSet, Result1, Counter0, Counter1)
->
+ Counter = Counter1,
Result = Result1
;
fail
).
:- pred parse_pragma_type(module_name, string, list(term), term,
- varset, maybe1(item)).
-:- mode parse_pragma_type(in, in, in, in, in, out) is semidet.
+ varset, maybe1(item), int, int).
+:- mode parse_pragma_type(in, in, in, in, in, out, in, out) is semidet.
-parse_pragma_type(_, "source_file", PragmaTerms, ErrorTerm, _VarSet, Result) :-
+parse_pragma_type(_, "source_file", PragmaTerms, ErrorTerm, _VarSet,
+ Result, Counter, Counter) :-
( PragmaTerms = [SourceFileTerm] ->
(
SourceFileTerm = term__functor(term__string(SourceFile), [], _)
@@ -70,7 +74,7 @@
).
parse_pragma_type(_, "c_header_code", PragmaTerms,
- ErrorTerm, _VarSet, Result) :-
+ ErrorTerm, _VarSet, Result, Counter, Counter) :-
(
PragmaTerms = [HeaderTerm]
->
@@ -88,7 +92,7 @@
).
parse_pragma_type(ModuleName, "c_code", PragmaTerms,
- ErrorTerm, VarSet, Result) :-
+ ErrorTerm, VarSet, Result, Counter, Counter) :-
(
PragmaTerms = [Just_C_Code_Term]
->
@@ -210,136 +214,43 @@
ErrorTerm)
).
-parse_pragma_type(ModuleName, "import", PragmaTerms, ErrorTerm,
- _VarSet, Result) :-
- (
- PragmaTerms = [PredAndModesTerm, FlagsTerm,
- C_FunctionTerm]
- ->
+parse_pragma_type(ModuleName, "import", PragmaTerms,
+ ErrorTerm, _VarSet, Result, Counter, Counter) :-
+ (
(
- 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(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(
@@ -351,63 +262,27 @@
error(
"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, Counter, Counter) :-
(
PragmaTerms = [PredAndModesTerm, C_FunctionTerm]
->
(
- PredAndModesTerm = term__functor(_, _, _),
C_FunctionTerm = term__functor(term__string(C_Function), [], _)
->
+ root_module_name(RootModuleName),
+ parse_pred_or_func_and_arg_modes(RootModuleName,
+ 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(
@@ -421,35 +296,35 @@
ErrorTerm)
).
-parse_pragma_type(ModuleName, "inline", PragmaTerms, ErrorTerm,
- _VarSet, Result) :-
+parse_pragma_type(ModuleName, "inline", PragmaTerms,
+ ErrorTerm, _VarSet, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "inline",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = inline(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "no_inline", PragmaTerms, ErrorTerm,
- _VarSet, Result) :-
+ _VarSet, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "no_inline",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = no_inline(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
-parse_pragma_type(ModuleName, "memo", PragmaTerms, ErrorTerm,
- _VarSet, Result) :-
+parse_pragma_type(ModuleName, "memo", PragmaTerms,
+ ErrorTerm, _VarSet, Result, Counter, Counter) :-
parse_tabling_pragma(ModuleName, "memo", eval_memo,
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "loop_check", PragmaTerms,
- ErrorTerm, _VarSet, Result) :-
+ ErrorTerm, _VarSet, Result, Counter, Counter) :-
parse_tabling_pragma(ModuleName, "loop_check", eval_loop_check,
PragmaTerms, ErrorTerm, Result).
-parse_pragma_type(ModuleName, "minimal_model", PragmaTerms, ErrorTerm,
- _VarSet, Result) :-
+parse_pragma_type(ModuleName, "minimal_model", PragmaTerms,
+ ErrorTerm, _VarSet, Result, Counter, Counter) :-
parse_tabling_pragma(ModuleName, "minimal_model", eval_minimal,
PragmaTerms, ErrorTerm, Result).
-parse_pragma_type(ModuleName, "obsolete", PragmaTerms, ErrorTerm,
- _VarSet, Result) :-
+parse_pragma_type(ModuleName, "obsolete", PragmaTerms,
+ ErrorTerm, _VarSet, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "obsolete",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = obsolete(Name, Arity)),
@@ -457,8 +332,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, Counter, Counter) :-
(
PragmaTerms = [
PredOrFuncTerm,
@@ -477,8 +352,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)
@@ -489,8 +365,88 @@
Result = error("error in pragma unused_args", ErrorTerm)
).
-parse_pragma_type(ModuleName, "fact_table", PragmaTerms, ErrorTerm,
- _VarSet, Result) :-
+parse_pragma_type(ModuleName, "type_spec", PragmaTerms, ErrorTerm,
+ VarSet0, Result, Counter0, Counter) :-
+ (
+ (
+ 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)),
+ convert_list(TypeSubnTerm, convert_type_spec_pair,
+ TypeSubnResult),
+ (
+ TypeSubnResult = ok(TypeSubn),
+ ( MaybeName = yes(SpecializedName0) ->
+ Counter = Counter0,
+ SpecializedName = SpecializedName0
+ ;
+ unqualify_name(PredName, UnqualName),
+ ( ErrorTerm = term__functor(_, _, Context) ->
+ term__context_line(Context, Line)
+ ;
+ error("term__variable error term?")
+ ),
+
+ ( MaybePredOrFunc = yes(PredOrFunc0) ->
+ PredOrFunc = PredOrFunc0
+ ;
+ % XXX This is just a guess.
+ % The problem with this would
+ % be a misleading entry in the
+ % call profile, but there is a
+ % context attached to the name,
+ % so it isn't too much of a problem.
+ PredOrFunc = predicate
+ ),
+ make_pred_name_with_context(ModuleName,
+ "TypeSpecOf", PredOrFunc,
+ UnqualName, Line, Counter0,
+ SpecializedName),
+ Counter = Counter0 + 1
+ ),
+ varset__coerce(VarSet0, VarSet),
+ Result = ok(pragma(type_spec(PredName,
+ SpecializedName, Arity, MaybePredOrFunc,
+ MaybeModes, TypeSubn, VarSet)))
+ ;
+ TypeSubnResult = error(_, _),
+ Counter = Counter0,
+ Result = error(
+ "expected type substitution in `pragma type_spec(...)' declaration",
+ TypeSubnTerm)
+ )
+ ;
+ ArityOrModesResult = error(Msg, Term),
+ Result = error(Msg, Term),
+ Counter = Counter0
+ )
+ ;
+ Counter = Counter0,
+ Result = error(
+ "wrong number of arguments in `pragma type_spec' declaration",
+ ErrorTerm)
+ ).
+
+parse_pragma_type(ModuleName, "fact_table", PragmaTerms,
+ ErrorTerm, _VarSet, Result, Counter, Counter) :-
(
PragmaTerms = [PredAndArityTerm, FileNameTerm]
->
@@ -517,21 +473,22 @@
ErrorTerm)
).
-parse_pragma_type(ModuleName, "aditi", PragmaTerms, ErrorTerm, _, Result) :-
+parse_pragma_type(ModuleName, "aditi", PragmaTerms, ErrorTerm, _,
+ Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "aditi",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = aditi(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "base_relation", PragmaTerms,
- ErrorTerm, _, Result) :-
+ ErrorTerm, _, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "base_relation",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = base_relation(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "aditi_index", PragmaTerms,
- ErrorTerm, _, Result) :-
+ ErrorTerm, _, Result, Counter, Counter) :-
( PragmaTerms = [PredNameArityTerm, IndexTypeTerm, AttributesTerm] ->
parse_pred_name_and_arity(ModuleName, "aditi_index",
PredNameArityTerm, ErrorTerm, NameArityResult),
@@ -574,48 +531,50 @@
ErrorTerm)
).
-parse_pragma_type(ModuleName, "naive", PragmaTerms, ErrorTerm, _, Result) :-
+parse_pragma_type(ModuleName, "naive", PragmaTerms, ErrorTerm, _,
+ Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "naive",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = naive(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
-parse_pragma_type(ModuleName, "psn", PragmaTerms, ErrorTerm, _, Result) :-
+parse_pragma_type(ModuleName, "psn", PragmaTerms, ErrorTerm, _,
+ Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "psn",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = psn(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "aditi_memo",
- PragmaTerms, ErrorTerm, _, Result) :-
+ PragmaTerms, ErrorTerm, _, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "aditi_memo",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = aditi_memo(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "aditi_no_memo",
- PragmaTerms, ErrorTerm, _, Result) :-
+ PragmaTerms, ErrorTerm, _, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "aditi_no_memo",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = aditi_no_memo(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "supp_magic",
- PragmaTerms, ErrorTerm, _, Result) :-
+ PragmaTerms, ErrorTerm, _, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "supp_magic",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = supp_magic(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "context",
- PragmaTerms, ErrorTerm, _, Result) :-
+ PragmaTerms, ErrorTerm, _, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "context",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = context(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "owner",
- PragmaTerms, ErrorTerm, _, Result) :-
+ PragmaTerms, ErrorTerm, _, Result, Counter, Counter) :-
( PragmaTerms = [SymNameAndArityTerm, OwnerTerm] ->
( OwnerTerm = term__functor(term__atom(Owner), [], _) ->
parse_simple_pragma(ModuleName, "owner",
@@ -634,83 +593,54 @@
).
parse_pragma_type(ModuleName, "promise_pure", PragmaTerms, ErrorTerm,
- _VarSet, Result) :-
+ _VarSet, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "promise_pure",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = promise_pure(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "termination_info", PragmaTerms, ErrorTerm,
- _VarSet, Result) :-
+ _VarSet, Result, Counter, Counter) :-
(
PragmaTerms = [
PredAndModesTerm0,
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(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
;
@@ -718,21 +648,21 @@
).
parse_pragma_type(ModuleName, "terminates", PragmaTerms,
- ErrorTerm, _VarSet, Result) :-
+ ErrorTerm, _VarSet, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "terminates",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = terminates(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "does_not_terminate", PragmaTerms,
- ErrorTerm, _VarSet, Result) :-
+ ErrorTerm, _VarSet, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "does_not_terminate",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = does_not_terminate(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "check_termination", PragmaTerms,
- ErrorTerm, _VarSet, Result) :-
+ ErrorTerm, _VarSet, Result, Counter, Counter) :-
parse_simple_pragma(ModuleName, "check_termination",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = check_termination(Name, Arity)),
@@ -896,55 +826,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(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 +908,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 +947,94 @@
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(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(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(ModuleName, PredAndModesTerm,
+ ErrorTerm, Msg, Result) :-
+ parse_pred_or_func_and_args(ModuleName, 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(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(ModuleName, 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
+ ),
+ parse_implicitly_qualified_term(ModuleName, 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 +1057,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 -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: doc/reference_manual.texi
===================================================================
RCS file: /home/staff/zs/imp/mercury/doc/reference_manual.texi,v
retrieving revision 1.120
diff -u -r1.120 reference_manual.texi
--- reference_manual.texi 1999/02/08 22:42:51 1.120
+++ reference_manual.texi 1999/02/17 00:49:57
@@ -3201,6 +3201,8 @@
* Impurity:: Users can write impure Mercury code
* Inlining:: Pragmas can be used to suggest or prevent
procedure inlining.
+* Type specialization:: Produce specialized versions of polymorphic
+ predicates.
* Obsolescence:: Library developers can declare old versions
of predicates or functions to be obsolete.
* Source file name:: The @samp{source_file} pragma and
@@ -4422,6 +4424,61 @@
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 the built-in unification
+and comparison routines. The Mercury compiler includes a pass which perform
+type specialization of polymorphic procedures. Unfortunately, the current
+implementation of inter-module optimization is not suited to performing type
+specialization because it would create copies of a type-specialized version
+of a predicate in each module it is needed, rather than just creating
+one shared copy. To avoid this, the programmer can specify which specialized
+versions should be created, ensuring that they are only created once.
+
+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 the named predicate
+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.
+
+The substitution is written as a list of @samp{type variable - type} pairs.
+The replacement types must be ground -- this restriction may be lifted later.
+ 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.
+
+For example, 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.
+
+The set of types for which a predicate should be specialized is best
+determined by profiling your application. Overuse of type specialization
+will result in code bloat. Type specialization 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.
+
+An implementation is free to ignore @samp{:- pragma type_spec(...)}
+declarations. The Melbourne Mercury compiler does not when invoked with
+ at samp{--user-guided-type-specialization}, which is enabled at @samp{-O2}.
@node Obsolescence
@section Obsolescence
Index: doc/user_guide.texi
===================================================================
RCS file: /home/staff/zs/imp/mercury/doc/user_guide.texi,v
retrieving revision 1.156
diff -u -r1.156 user_guide.texi
--- user_guide.texi 1999/01/31 11:51:46 1.156
+++ user_guide.texi 1999/02/17 00:49:57
@@ -3260,6 +3260,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}.
More information about the developers
mailing list