[m-dev.] for review: type specialization (relative) [2]
Simon Taylor
stayl at cs.mu.OZ.AU
Tue Apr 20 14:20:11 AEST 1999
diff --recursive -u ./compiler/options.m /home/pgrad/stayl/mercury0/compiler/options.m
--- ./compiler/options.m Tue Apr 20 12:01:18 1999
+++ /home/pgrad/stayl/mercury0/compiler/options.m Tue Apr 20 12:52:35 1999
@@ -1841,10 +1841,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)."
]).
@@ -1955,7 +1955,7 @@
"\tpolymorphic types are known.",
"--user-guided-type-specialization",
"\tEnable specialization of polymorphic predicates for which",
- "\tthere are `pragma type_spec(...)' declarations.",
+ "\tthere are `:- pragma type_spec' declarations.",
"--higher-order-size-limit",
"\tSet the maximum goal size of specialized versions created by",
"\t`--optimize-higher-order' and `--type-specialization'.",
diff --recursive -u ./compiler/polymorphism.m /home/pgrad/stayl/mercury0/compiler/polymorphism.m
--- ./compiler/polymorphism.m Thu Apr 8 18:41:07 1999
+++ /home/pgrad/stayl/mercury0/compiler/polymorphism.m Tue Apr 13 14:35:52 1999
@@ -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
).
%---------------------------------------------------------------------------%
diff --recursive -u ./compiler/prog_data.m /home/pgrad/stayl/mercury0/compiler/prog_data.m
--- ./compiler/prog_data.m Tue Apr 20 12:01:18 1999
+++ /home/pgrad/stayl/mercury0/compiler/prog_data.m Fri Mar 19 15:03:48 1999
@@ -112,7 +112,7 @@
% VarNames, C Code Implementation Info
; type_spec(sym_name, sym_name, arity, maybe(pred_or_func),
- maybe(list(mode)), assoc_list(tvar, type), tvarset)
+ maybe(list(mode)), type_subst, tvarset)
% PredName, SpecializedPredName, Arity,
% PredOrFunc, Modes if a specific procedure was
% specified, type substitution (using the variable
@@ -221,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'.
diff --recursive -u ./compiler/prog_io.m /home/pgrad/stayl/mercury0/compiler/prog_io.m
All changes to prog_io.m were undone.
diff --recursive -u ./compiler/prog_io_pragma.m /home/pgrad/stayl/mercury0/compiler/prog_io_pragma.m
--- ./compiler/prog_io_pragma.m Tue Apr 20 12:01:18 1999
+++ /home/pgrad/stayl/mercury0/compiler/prog_io_pragma.m Thu Apr 15 11:20:16 1999
@@ -17,8 +17,8 @@
:- import_module list, varset, term.
% parse the pragma declaration.
-:- pred parse_pragma(module_name, varset, list(term), maybe1(item), int, int).
-:- mode parse_pragma(in, in, in, out, in, out) is semidet.
+:- pred parse_pragma(module_name, varset, list(term), maybe1(item)).
+:- mode parse_pragma(in, in, in, out) is semidet.
:- implementation.
@@ -26,16 +26,15 @@
:- import_module term_util, term_errors, rl.
:- import_module int, map, string, std_util, bool, require.
-parse_pragma(ModuleName, VarSet, PragmaTerms, Result, Counter0, Counter) :-
+parse_pragma(ModuleName, VarSet, PragmaTerms, Result) :-
(
% new syntax: `:- pragma foo(...).'
PragmaTerms = [SinglePragmaTerm],
SinglePragmaTerm = term__functor(term__atom(PragmaType),
PragmaArgs, _),
parse_pragma_type(ModuleName, PragmaType, PragmaArgs,
- SinglePragmaTerm, VarSet, Result0, Counter0, Counter1)
+ SinglePragmaTerm, VarSet, Result0)
->
- Counter = Counter1,
Result = Result0
;
% old syntax: `:- pragma(foo, ...).'
@@ -43,20 +42,18 @@
PragmaTerms = [PragmaTypeTerm | PragmaArgs2],
PragmaTypeTerm = term__functor(term__atom(PragmaType), [], _),
parse_pragma_type(ModuleName, PragmaType, PragmaArgs2,
- PragmaTypeTerm, VarSet, Result1, Counter0, Counter1)
+ PragmaTypeTerm, VarSet, Result1)
->
- Counter = Counter1,
Result = Result1
;
fail
).
:- pred parse_pragma_type(module_name, string, list(term), term,
- varset, maybe1(item), int, int).
-:- mode parse_pragma_type(in, in, in, in, in, out, in, out) is semidet.
+ varset, maybe1(item)).
+:- mode parse_pragma_type(in, in, in, in, in, out) is semidet.
-parse_pragma_type(_, "source_file", PragmaTerms, ErrorTerm, _VarSet,
- Result, Counter, Counter) :-
+parse_pragma_type(_, "source_file", PragmaTerms, ErrorTerm, _VarSet, Result) :-
( PragmaTerms = [SourceFileTerm] ->
(
SourceFileTerm = term__functor(term__string(SourceFile), [], _)
@@ -64,17 +61,17 @@
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)
).
parse_pragma_type(_, "c_header_code", PragmaTerms,
- ErrorTerm, _VarSet, Result, Counter, Counter) :-
+ ErrorTerm, _VarSet, Result) :-
(
PragmaTerms = [HeaderTerm]
->
@@ -87,12 +84,12 @@
)
;
Result = error(
-"wrong number of arguments in `pragma c_header_code(...) declaration",
+"wrong number of arguments in `:- pragma c_header_code' declaration",
ErrorTerm)
).
parse_pragma_type(ModuleName, "c_code", PragmaTerms,
- ErrorTerm, VarSet, Result, Counter, Counter) :-
+ ErrorTerm, VarSet, Result) :-
(
PragmaTerms = [Just_C_Code_Term]
->
@@ -215,7 +212,7 @@
).
parse_pragma_type(ModuleName, "import", PragmaTerms,
- ErrorTerm, _VarSet, Result, Counter, Counter) :-
+ ErrorTerm, _VarSet, Result) :-
(
(
PragmaTerms = [PredAndModesTerm, FlagsTerm, C_FunctionTerm],
@@ -234,8 +231,9 @@
(
C_FunctionTerm = term__functor(term__string(C_Function), [], _)
->
- parse_pred_or_func_and_arg_modes(ModuleName, PredAndModesTerm,
- ErrorTerm, "pragma import declaration",
+ parse_pred_or_func_and_arg_modes(yes(ModuleName),
+ PredAndModesTerm, ErrorTerm,
+ "`:- pragma import' declaration",
PredAndArgModesResult),
(
PredAndArgModesResult = ok(PredName - PredOrFunc,
@@ -260,22 +258,21 @@
;
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, Counter, Counter) :-
+ ErrorTerm, _VarSet, Result) :-
(
PragmaTerms = [PredAndModesTerm, C_FunctionTerm]
->
(
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),
+ parse_pred_or_func_and_arg_modes(no, PredAndModesTerm,
+ ErrorTerm, "`:- pragma export' declaration",
+ PredAndModesResult),
(
PredAndModesResult = ok(PredName - PredOrFunc, Modes),
Result = ok(pragma(export(PredName, PredOrFunc,
@@ -292,39 +289,39 @@
;
Result =
error(
- "wrong number of arguments in `pragma export(...)' declaration",
+ "wrong number of arguments in `:- pragma export' declaration",
ErrorTerm)
).
-parse_pragma_type(ModuleName, "inline", PragmaTerms,
- ErrorTerm, _VarSet, Result, Counter, Counter) :-
+parse_pragma_type(ModuleName, "inline", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
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, Counter, Counter) :-
+ _VarSet, Result) :-
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, Counter, Counter) :-
+parse_pragma_type(ModuleName, "memo", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
parse_tabling_pragma(ModuleName, "memo", eval_memo,
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "loop_check", PragmaTerms,
- ErrorTerm, _VarSet, Result, Counter, Counter) :-
+ ErrorTerm, _VarSet, Result) :-
parse_tabling_pragma(ModuleName, "loop_check", eval_loop_check,
PragmaTerms, ErrorTerm, Result).
-parse_pragma_type(ModuleName, "minimal_model", PragmaTerms,
- ErrorTerm, _VarSet, Result, Counter, Counter) :-
+parse_pragma_type(ModuleName, "minimal_model", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
parse_tabling_pragma(ModuleName, "minimal_model", eval_minimal,
PragmaTerms, ErrorTerm, Result).
-parse_pragma_type(ModuleName, "obsolete", PragmaTerms,
- ErrorTerm, _VarSet, Result, Counter, Counter) :-
+parse_pragma_type(ModuleName, "obsolete", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
parse_simple_pragma(ModuleName, "obsolete",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = obsolete(Name, Arity)),
@@ -333,7 +330,7 @@
% pragma unused_args should never appear in user programs,
% only in .opt files.
parse_pragma_type(ModuleName, "unused_args", PragmaTerms,
- ErrorTerm, _VarSet, Result, Counter, Counter) :-
+ ErrorTerm, _VarSet, Result) :-
(
PragmaTerms = [
PredOrFuncTerm,
@@ -353,7 +350,7 @@
PredOrFunc = function
),
parse_implicitly_qualified_term(ModuleName, PredNameTerm,
- ErrorTerm, "pragma unused args declaration",
+ ErrorTerm, "`:- pragma unused_args' declaration",
PredNameResult),
PredNameResult = ok(PredName, []),
convert_int_list(UnusedArgsTerm, UnusedArgsResult),
@@ -362,11 +359,11 @@
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, Counter0, Counter) :-
+ VarSet0, Result) :-
(
(
PragmaTerms = [PredAndModesTerm, TypeSubnTerm],
@@ -386,67 +383,45 @@
)
->
parse_arity_or_modes(ModuleName, PredAndModesTerm, ErrorTerm,
- "pragma type_spec declaration", ArityOrModesResult),
+ "`:- 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),
+ 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) ->
- 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
+ make_pred_name(ModuleName, "TypeSpecOf",
+ MaybePredOrFunc, UnqualName,
+ type_subst(TVarSet, TypeSubn),
+ SpecializedName)
),
- varset__coerce(VarSet0, VarSet),
Result = ok(pragma(type_spec(PredName,
SpecializedName, Arity, MaybePredOrFunc,
- MaybeModes, TypeSubn, VarSet)))
+ MaybeModes, TypeSubn, TVarSet)))
;
- TypeSubnResult = error(_, _),
- Counter = Counter0,
Result = error(
- "expected type substitution in `pragma type_spec(...)' declaration",
+ "expected type substitution in `:- pragma type_spec' declaration",
TypeSubnTerm)
)
;
ArityOrModesResult = error(Msg, Term),
- Result = error(Msg, Term),
- Counter = Counter0
+ Result = error(Msg, Term)
)
;
- Counter = Counter0,
Result = error(
- "wrong number of arguments in `pragma type_spec' declaration",
+ "wrong number of arguments in `:- pragma type_spec' declaration",
ErrorTerm)
).
-parse_pragma_type(ModuleName, "fact_table", PragmaTerms,
- ErrorTerm, _VarSet, Result, Counter, Counter) :-
+parse_pragma_type(ModuleName, "fact_table", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
(
PragmaTerms = [PredAndArityTerm, FileNameTerm]
->
@@ -469,26 +444,25 @@
;
Result =
error(
- "wrong number of arguments in pragma fact_table(..., ...) declaration",
+ "wrong number of arguments in `:- pragma fact_table' declaration",
ErrorTerm)
).
-parse_pragma_type(ModuleName, "aditi", PragmaTerms, ErrorTerm, _,
- Result, Counter, Counter) :-
+parse_pragma_type(ModuleName, "aditi", PragmaTerms, ErrorTerm, _, Result) :-
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, Counter, Counter) :-
+ ErrorTerm, _, Result) :-
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, Counter, Counter) :-
+ ErrorTerm, _, Result) :-
( PragmaTerms = [PredNameArityTerm, IndexTypeTerm, AttributesTerm] ->
parse_pred_name_and_arity(ModuleName, "aditi_index",
PredNameArityTerm, ErrorTerm, NameArityResult),
@@ -513,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)
)
;
@@ -527,54 +501,52 @@
)
;
Result = error(
-"wrong number of arguments in pragma aditi_index(..., ..., ...) declaration",
+ "wrong number of arguments in `:- pragma aditi_index' declaration",
ErrorTerm)
).
-parse_pragma_type(ModuleName, "naive", PragmaTerms, ErrorTerm, _,
- Result, Counter, Counter) :-
+parse_pragma_type(ModuleName, "naive", PragmaTerms, ErrorTerm, _, Result) :-
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, Counter, Counter) :-
+parse_pragma_type(ModuleName, "psn", PragmaTerms, ErrorTerm, _, Result) :-
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, Counter, Counter) :-
+ PragmaTerms, ErrorTerm, _, Result) :-
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, Counter, Counter) :-
+ PragmaTerms, ErrorTerm, _, Result) :-
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, Counter, Counter) :-
+ PragmaTerms, ErrorTerm, _, Result) :-
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, Counter, Counter) :-
+parse_pragma_type(ModuleName, "context",
+ PragmaTerms, ErrorTerm, _, Result) :-
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, Counter, Counter) :-
+ PragmaTerms, ErrorTerm, _, Result) :-
( PragmaTerms = [SymNameAndArityTerm, OwnerTerm] ->
( OwnerTerm = term__functor(term__atom(Owner), [], _) ->
parse_simple_pragma(ModuleName, "owner",
@@ -582,33 +554,31 @@
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)
).
parse_pragma_type(ModuleName, "promise_pure", PragmaTerms, ErrorTerm,
- _VarSet, Result, Counter, Counter) :-
+ _VarSet, Result) :-
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, Counter, Counter) :-
+ _VarSet, Result) :-
(
PragmaTerms = [
PredAndModesTerm0,
ArgSizeTerm,
TerminationTerm
],
- parse_pred_or_func_and_arg_modes(ModuleName, PredAndModesTerm0,
- ErrorTerm, "`pragma termination_info declaration'",
+ parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
+ ErrorTerm, "`:- pragma termination_info' declaration",
NameAndModesResult),
NameAndModesResult = ok(PredName - PredOrFunc, ModeList),
(
@@ -644,25 +614,26 @@
->
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,
- ErrorTerm, _VarSet, Result, Counter, Counter) :-
+ ErrorTerm, _VarSet, Result) :-
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, Counter, Counter) :-
+ ErrorTerm, _VarSet, Result) :-
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, Counter, Counter) :-
+ ErrorTerm, _VarSet, Result) :-
parse_simple_pragma(ModuleName, "check_termination",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = check_termination(Name, Arity)),
@@ -688,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)
).
@@ -711,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)
).
@@ -827,8 +798,8 @@
parse_pragma_c_code(ModuleName, Flags, PredAndVarsTerm0, PragmaImpl,
VarSet0, Result) :-
- parse_pred_or_func_and_args(ModuleName, PredAndVarsTerm0, PredAndVarsTerm0,
- "`pragma c_code' declaration", PredAndArgsResult),
+ parse_pred_or_func_and_args(yes(ModuleName), PredAndVarsTerm0,
+ PredAndVarsTerm0, "`:- pragma c_code' declaration", PredAndArgsResult),
(
PredAndArgsResult = ok(PredName, VarList0 - MaybeRetTerm),
(
@@ -908,7 +879,7 @@
(
PragmaTerms = [PredAndModesTerm0]
->
- string__append_list(["`pragma ", PragmaName, "(...)' declaration"],
+ string__append_list(["`:- pragma ", PragmaName, "' declaration"],
ParseMsg),
parse_arity_or_modes(ModuleName, PredAndModesTerm0,
ErrorTerm, ParseMsg, ArityModesResult),
@@ -922,8 +893,8 @@
Result = error(Msg, Term)
)
;
- string__append_list(["wrong number of arguments in `pragma ",
- PragmaName, "(...)' declaration"], ErrorMessage),
+ string__append_list(["wrong number of arguments in `:- pragma ",
+ PragmaName, "' declaration"], ErrorMessage),
Result = error(ErrorMessage, ErrorTerm)
).
@@ -953,8 +924,9 @@
Result = error(Msg, ErrorTerm)
)
;
- parse_pred_or_func_and_arg_modes(ModuleName, PredAndModesTerm0,
- PredAndModesTerm0, ErrorMsg, PredAndModesResult),
+ parse_pred_or_func_and_arg_modes(yes(ModuleName),
+ PredAndModesTerm0, PredAndModesTerm0, ErrorMsg,
+ PredAndModesResult),
(
PredAndModesResult = ok(PredName - PredOrFunc, Modes),
list__length(Modes, Arity0),
@@ -975,14 +947,14 @@
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).
+:- 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(ModuleName, PredAndModesTerm,
+parse_pred_or_func_and_arg_modes(MaybeModuleName, PredAndModesTerm,
ErrorTerm, Msg, Result) :-
- parse_pred_or_func_and_args(ModuleName, PredAndModesTerm, ErrorTerm,
- Msg, PredAndArgsResult),
+ parse_pred_or_func_and_args(MaybeModuleName, PredAndModesTerm,
+ ErrorTerm, Msg, PredAndArgsResult),
(
PredAndArgsResult =
ok(PredName, ArgModeTerms - MaybeRetModeTerm),
@@ -1011,11 +983,11 @@
Result = error(ErrorMsg, Term)
).
-:- pred parse_pred_or_func_and_args(sym_name, term, term, string,
+:- 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(ModuleName, PredAndArgsTerm, ErrorTerm,
+parse_pred_or_func_and_args(MaybeModuleName, PredAndArgsTerm, ErrorTerm,
Msg, PredAndArgsResult) :-
(
PredAndArgsTerm = term__functor(term__atom("="),
@@ -1027,8 +999,14 @@
FunctorTerm = PredAndArgsTerm,
MaybeFuncResult = no
),
- parse_implicitly_qualified_term(ModuleName, FunctorTerm,
- ErrorTerm, Msg, Result),
+ (
+ 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)
@@ -1104,7 +1082,7 @@
:- 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], _),
+ Term = term__functor(term__atom("="), [TypeVarTerm, SpecTypeTerm0], _),
TypeVarTerm = term__variable(TypeVar0),
term__coerce_var(TypeVar0, TypeVar),
term__coerce(SpecTypeTerm0, SpecType),
diff --recursive -u ./compiler/prog_util.m /home/pgrad/stayl/mercury0/compiler/prog_util.m
--- ./compiler/prog_util.m Fri Nov 20 15:09:04 1998
+++ /home/pgrad/stayl/mercury0/compiler/prog_util.m Thu Apr 15 11:23:14 1999
@@ -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)
+ ).
%-----------------------------------------------------------------------------%
diff --recursive -u ./compiler/type_util.m /home/pgrad/stayl/mercury0/compiler/type_util.m
--- ./compiler/type_util.m Wed Mar 24 14:11:16 1999
+++ /home/pgrad/stayl/mercury0/compiler/type_util.m Thu Apr 8 12:00:38 1999
@@ -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).
%-----------------------------------------------------------------------------%
--- ./doc/reference_manual.texi Tue Apr 20 12:01:18 1999
+++ /home/pgrad/stayl/mercury0/doc/reference_manual.texi Tue Mar 30 11:31:11 1999
@@ -3352,8 +3352,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.
+* 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
@@ -4580,14 +4580,19 @@
@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.
+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
@@ -4597,39 +4602,63 @@
@end example
@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.
+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))}}.
-For example, the declarations
+The declarations
@example
:- pred map__lookup(map(K, V), K, V).
-:- pragma type_spec(map__lookup/3, [K - int]).
+:- pragma type_spec(map__lookup/3, K = int).
@end example
@noindent
-give a hint to the compiler that a version of @samp{map__lookup}/3 should
+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
+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.
+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}.
+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
diff --recursive -u ./doc/user_guide.texi /home/pgrad/stayl/mercury0/doc/user_guide.texi
--- ./doc/user_guide.texi Tue Apr 20 12:01:18 1999
+++ /home/pgrad/stayl/mercury0/doc/user_guide.texi Tue Apr 20 12:52:45 1999
@@ -3305,7 +3305,7 @@
@sp 1
@item --user-guided-type-specialization
Enable specialization of polymorphic predicates for which
-there are `pragma type_spec(...)' declarations.
+there are `:- pragma type_spec' declarations.
See the ``Type specialization'' section in the ``Pragmas''
chapter of the Mercury Language Reference Manual for more details.
diff --recursive -u ./library/private_builtin.m /home/pgrad/stayl/mercury0/library/private_builtin.m
--- ./library/private_builtin.m Thu Apr 8 18:42:02 1999
+++ /home/pgrad/stayl/mercury0/library/private_builtin.m Tue Apr 13 14:53:40 1999
@@ -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).
+
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list