diff: type_name for higher order types.
Tyson Richard DOWD
trd at cs.mu.oz.au
Wed Jul 16 00:17:35 AEST 1997
Hi,
Could someone review this change?
(I gave up on implementing this by generating closure type_infos at
compile time - it was difficult to bootstrap, required too many changes,
and was too time consuming).
===================================================================
Estimated hours taken: 3
Allow the names of higher order types to be generated.
LIMITATIONS:
Document limitations introduced by this change.
compiler/polymorphism.m:
Map higher order predicates to pred/0 and functions to func/0.
library/mercury_builtin.m:
Create base_type_info for func/0.
library/std_util.m:
Check for pred/0 and func/0 when comparing type infos.
Create different ctor_infos for higher order preds, decode them
correctly for args and functors when needed.
Print functions nicely (eg func(foo) = bar).
runtime/type_info.h:
Define macros to deal with new representation of higher order
ctor_infos.
Index: LIMITATIONS
===================================================================
RCS file: /home/staff/zs/imp/mercury/LIMITATIONS,v
retrieving revision 1.8
diff -u -r1.8 LIMITATIONS
--- LIMITATIONS 1996/12/20 17:36:52 1.8
+++ LIMITATIONS 1997/07/15 06:29:48
@@ -19,12 +19,16 @@
* The order of mode declarations is significant:
unique mode declarations must precede non-unique mode declarations.
+We are working on eliminating all of these problems.
+
+In addition, design decisions in this implementation have imposed the
+following fixed limits:
+
* Predicates can have at most about 1000 arguments.
-We are working on eliminating all of these problems.
+* Higher order terms are limited to arity of about 500.
-Of course, those are not the only things we're working on. Among other
-things, we'd like to provide better support for debugging, and a better
-garbage collector. We're also working on a parallel/multithreaded
-version of Mercury, and on adding support for constraint solving.
+These limits can be lifted (with some effort), but would possibly incur
+performance penalties. Contact the Mercury team (mercury at cs.mu.oz.au) if
+you are these limits are affecting your application.
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.106
diff -u -r1.106 polymorphism.m
--- polymorphism.m 1997/06/02 06:36:09 1.106
+++ polymorphism.m 1997/07/15 12:35:35
@@ -719,19 +719,25 @@
polymorphism__make_var(Type, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes) :-
(
- type_is_higher_order(Type, _PredOrFunc, TypeArgs)
+ type_is_higher_order(Type, PredOrFunc, TypeArgs)
->
% This occurs for code where a predicate calls a polymorphic
% predicate with a known higher-order value of the type
% variable.
- % The transformation we perform is basically the same
- % as in the first-order case below, except that
- % we ignore the PredOrFunc and map all pred/func types to
- % builtin pred/0 for the purposes of creating type_infos.
+ % The transformation we perform is basically the same as
+ % in the first-order case below, except that we map
+ % pred/func types to builtin pred/0 or func/0 for the
+ % purposes of creating type_infos.
% To allow univ_to_type to check the type_infos
- % correctly, the actual arity of the pred is added to
+ % correctly, the actual arity of the pred is added to
% the type_info of higher-order types.
- TypeId = unqualified("pred") - 0,
+ (
+ PredOrFunc = predicate,
+ TypeId = unqualified("pred") - 0
+ ;
+ PredOrFunc = function,
+ TypeId = unqualified("func") - 0
+ ),
polymorphism__construct_type_info(Type, TypeId, TypeArgs,
yes, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes)
Index: library/mercury_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/mercury_builtin.m,v
retrieving revision 1.75
diff -u -r1.75 mercury_builtin.m
--- mercury_builtin.m 1997/06/04 09:59:33 1.75
+++ mercury_builtin.m 1997/07/15 12:35:35
@@ -314,7 +314,7 @@
builtin_unify_pred(_Pred1, _Pred2) :-
% suppress determinism warning
( semidet_succeed ->
- error("attempted unification of higher-order predicate terms")
+ error("attempted unification of higher-order terms")
;
semidet_fail
).
@@ -582,8 +582,47 @@
#endif
};
- /* base_type_info for `pred' */
- /* (this is used for all higher-order types) */
+ /*
+ ** base_type_info for `func'
+ ** (this is used for all higher-order func types)
+ **
+ ** Note: we use the special predicates, functors and layout for
+ ** `pred'.
+ */
+
+Declare_entry(mercury__builtin_unify_pred_2_0);
+Declare_entry(mercury__builtin_index_pred_2_0);
+Declare_entry(mercury__builtin_compare_pred_3_0);
+MR_STATIC_CODE_CONST struct mercury_data___base_type_info_func_0_struct {
+ Integer f1;
+ Code *f2;
+ Code *f3;
+ Code *f4;
+#ifdef USE_TYPE_TO_TERM
+ Code *f5;
+ Code *f6;
+#endif
+#ifdef USE_TYPE_LAYOUT
+ const Word *f7;
+ const Word *f8;
+ const Word *f9;
+#endif
+} mercury_data___base_type_info_func_0 = {
+ ((Integer) 0),
+ MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_unify_pred_2_0)),
+ MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_index_pred_2_0)),
+ MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_compare_pred_3_0)),
+#ifdef USE_TYPE_LAYOUT
+ (const Word *) & mercury_data___base_type_layout_pred_0,
+ (const Word *) & mercury_data___base_type_functors_pred_0,
+ (const Word *) string_const(""func"", 4)
+#endif
+};
+
+ /*
+ ** base_type_info for `pred'
+ ** (this is used for all higher-order pred types)
+ */
Declare_entry(mercury__builtin_unify_pred_2_0);
Declare_entry(mercury__builtin_index_pred_2_0);
Index: library/std_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/std_util.m,v
retrieving revision 1.93
diff -u -r1.93 std_util.m
--- std_util.m 1997/06/04 09:59:37 1.93
+++ std_util.m 1997/07/15 12:35:35
@@ -397,7 +397,7 @@
:- implementation.
-:- import_module require, set, int, string.
+:- import_module require, set, int, string, bool.
%-----------------------------------------------------------------------------%
@@ -757,8 +757,6 @@
** calls to this function.
*/
-MR_DECLARE_STRUCT(mercury_data___base_type_info_pred_0);
-
int
ML_compare_type_info(Word t1, Word t2)
{
@@ -818,8 +816,8 @@
** But we need to recursively compare the argument types, if any.
*/
/* Check for higher order */
- if (base_type_info_1 ==
- (const Word *) &mercury_data___base_type_info_pred_0)
+ if (MR_BASE_TYPEINFO_IS_HO_PRED(base_type_info_1) ||
+ MR_BASE_TYPEINFO_IS_HO_FUNC(base_type_info_1))
{
int num_arg_types_2;
@@ -1204,20 +1202,25 @@
( Arity = 0 ->
TypeName = Name
;
- type_arg_names(ArgTypes, ArgTypeNames),
- string__append_list([Name, "(" | ArgTypeNames], TypeName)
+ ( Name = "func" -> IsFunc = yes ; IsFunc = no ),
+ type_arg_names(ArgTypes, IsFunc, ArgTypeNames),
+ string__append_list([Name, "(" | ArgTypeNames],
+ TypeName)
).
-:- pred type_arg_names(list(type_info), list(string)).
-:- mode type_arg_names(in, out) is det.
+:- pred type_arg_names(list(type_info), bool, list(string)).
+:- mode type_arg_names(in, in, out) is det.
-type_arg_names([], []).
-type_arg_names([Type|Types], ArgNames) :-
+type_arg_names([], _, []).
+type_arg_names([Type|Types], IsFunc, ArgNames) :-
Name = type_name(Type),
( Types = [] ->
ArgNames = [Name, ")"]
+ ; IsFunc = yes, Types = [FuncReturnType] ->
+ FuncReturnName = type_name(FuncReturnType),
+ ArgNames = [Name, ") = ", FuncReturnName]
;
- type_arg_names(Types, Names),
+ type_arg_names(Types, IsFunc, Names),
ArgNames = [Name, ", " | Names]
).
@@ -1240,31 +1243,82 @@
:- pragma c_code(type_ctor(TypeInfo::in) = (TypeCtor::out),
will_not_call_mercury, "
{
- Word *type_info;
+ Word *type_info, *base_type_info;
save_transient_registers();
type_info = (Word *) ML_collapse_equivalences(TypeInfo);
restore_transient_registers();
- TypeCtor = (Word) MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
+ base_type_info = (Word *) MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
+
+ TypeCtor = ML_make_ctor_info(type_info, base_type_info);
}
").
+:- pragma c_header_code("
+
+Word ML_make_ctor_info(Word *type_info, Word *base_type_info);
+
+ /*
+ ** Several predicates use these (the MR_BASE_TYPEINFO_IS_HO_*
+ ** macros need access to these addresses).
+ */
+MR_DECLARE_STRUCT(mercury_data___base_type_info_pred_0);
+MR_DECLARE_STRUCT(mercury_data___base_type_info_func_0);
+
+
+").
+
+:- pragma c_code("
+
+
+Word ML_make_ctor_info(Word *type_info, Word *base_type_info)
+{
+ Word ctor_info = (Word) base_type_info;
+
+ if (MR_BASE_TYPEINFO_IS_HO_PRED(base_type_info)) {
+ ctor_info = MR_TYPECTOR_MAKE_PRED(
+ MR_TYPEINFO_GET_HIGHER_ARITY(type_info));
+ if (!MR_TYPECTOR_IS_HIGHER_ORDER(ctor_info)) {
+ fatal_error(""std_util:ML_make_ctor_info""
+ ""- arity out of range."");
+ }
+ } else if (MR_BASE_TYPEINFO_IS_HO_FUNC(base_type_info)) {
+ ctor_info = MR_TYPECTOR_MAKE_FUNC(
+ MR_TYPEINFO_GET_HIGHER_ARITY(type_info));
+ if (!MR_TYPECTOR_IS_HIGHER_ORDER(ctor_info)) {
+ fatal_error(""std_util:ML_make_ctor_info""
+ ""- arity out of range."");
+ }
+ }
+ return ctor_info;
+}
+
+").
+
+
:- pragma c_code(type_ctor_and_args(TypeInfo::in,
TypeCtor::out, TypeArgs::out), will_not_call_mercury, "
{
- Word *type_info;
- Word *base_type_info;
+ Word *type_info, *base_type_info;
Integer arity;
save_transient_registers();
type_info = (Word *) ML_collapse_equivalences(TypeInfo);
base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
- TypeCtor = (Word) base_type_info;
- arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
- TypeArgs = ML_copy_argument_typeinfos(arity, 0,
+ TypeCtor = ML_make_ctor_info(type_info, base_type_info);
+
+ if (MR_TYPECTOR_IS_HIGHER_ORDER(TypeCtor)) {
+ arity = MR_TYPECTOR_GET_HOT_ARITY(TypeCtor);
+ TypeArgs = ML_copy_argument_typeinfos(arity, 0,
+ type_info + TYPEINFO_OFFSET_FOR_PRED_ARGS);
+ } else {
+ arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+ TypeArgs = ML_copy_argument_typeinfos(arity, 0,
type_info + OFFSET_FOR_ARG_TYPE_INFOS);
+ }
restore_transient_registers();
+
}
").
@@ -1286,7 +1340,11 @@
base_type_info = (Word *) TypeCtor;
- arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+ if (MR_TYPECTOR_IS_HIGHER_ORDER(base_type_info)) {
+ arity = MR_TYPECTOR_GET_HOT_ARITY(base_type_info);
+ } else {
+ arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+ }
arg_type = ArgTypes;
for (list_length = 0; !list_is_empty(arg_type); list_length++) {
@@ -1315,21 +1373,37 @@
{
Word *type_info = (Word *) TypeInfo;
Word *base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
- Integer arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
- TypeCtor = (Word) base_type_info;
- save_transient_registers();
- ArgTypes = ML_copy_argument_typeinfos(arity, 0,
+ Integer arity;
+
+ TypeCtor = ML_make_ctor_info(type_info, base_type_info);
+ if (MR_TYPECTOR_IS_HIGHER_ORDER(TypeCtor)) {
+ arity = MR_TYPECTOR_GET_HOT_ARITY(base_type_info);
+ save_transient_registers();
+ ArgTypes = ML_copy_argument_typeinfos(arity, 0,
+ type_info + TYPEINFO_OFFSET_FOR_PRED_ARGS);
+ restore_transient_registers();
+ } else {
+ arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+ save_transient_registers();
+ ArgTypes = ML_copy_argument_typeinfos(arity, 0,
type_info + OFFSET_FOR_ARG_TYPE_INFOS);
- restore_transient_registers();
+ restore_transient_registers();
+ }
}
").
:- pragma c_code(type_ctor_name_and_arity(TypeCtor::in,
TypeCtorName::out, TypeCtorArity::out), will_not_call_mercury, "
{
- Word *base_type_info = (Word *) TypeCtor;
- TypeCtorName = MR_BASE_TYPEINFO_GET_TYPE_NAME(base_type_info);
- TypeCtorArity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+ Word *type_ctor = (Word *) TypeCtor;
+
+ if (MR_TYPECTOR_IS_HIGHER_ORDER(type_ctor)) {
+ TypeCtorName = MR_TYPECTOR_GET_HOT_NAME(type_ctor);
+ TypeCtorArity = MR_TYPECTOR_GET_HOT_ARITY(type_ctor);
+ } else {
+ TypeCtorName = MR_BASE_TYPEINFO_GET_TYPE_NAME(type_ctor);
+ TypeCtorArity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(type_ctor);
+ }
}
").
@@ -1353,7 +1427,7 @@
** Get information for this functor number and
** store in info. If this is a discriminated union
** type and if the functor number is in range, we
- ** succeed.
+ ** succeed.
*/
save_transient_registers();
success = ML_get_functors_check_range(FunctorNumber,
@@ -1656,7 +1730,7 @@
** ML_make_type(arity, base_type_info, arg_types_list):
**
** Construct and return a type_info for a type using the
- ** specified base_type_info for the type constructor,
+ ** specified type_ctor for the type constructor,
** and using the arguments specified in arg_types_list
** for the type arguments (if any).
**
@@ -1669,28 +1743,39 @@
*/
Word
-ML_make_type(int arity, Word *base_type_info, Word arg_types_list)
+ML_make_type(int arity, Word *type_ctor, Word arg_types_list)
{
- int i;
+ int i, extra_args;
+ Word base_type_info;
/*
** XXX: do we need to treat higher-order predicates as
** a special case here?
*/
+ if (MR_TYPECTOR_IS_HIGHER_ORDER(type_ctor)) {
+ base_type_info = MR_TYPECTOR_GET_HOT_BASE_TYPE_INFO(type_ctor);
+ extra_args = 2;
+ } else {
+ base_type_info = (Word) type_ctor;
+ extra_args = 1;
+ }
if (arity == 0) {
- return (Word) base_type_info;
+ return base_type_info;
} else {
Word *type_info;
restore_transient_registers();
- incr_hp(LVALUE_CAST(Word, type_info), arity + 1);
+ incr_hp(LVALUE_CAST(Word, type_info), arity + extra_args);
save_transient_registers();
- field(mktag(0), type_info, 0) = (Word) base_type_info;
+ field(mktag(0), type_info, 0) = base_type_info;
+ if (MR_TYPECTOR_IS_HIGHER_ORDER(type_ctor)) {
+ field(mktag(0), type_info, 1) = (Word) arity;
+ }
for (i = 0; i < arity; i++) {
- field(mktag(0), type_info, i + 1) =
+ field(mktag(0), type_info, i + extra_args) =
list_head(arg_types_list);
arg_types_list = list_tail(arg_types_list);
}
Index: runtime/type_info.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/type_info.h,v
retrieving revision 1.26
diff -u -r1.26 type_info.h
--- type_info.h 1997/05/20 02:05:11 1.26
+++ type_info.h 1997/07/15 12:35:35
@@ -268,6 +268,38 @@
#define TYPEINFO_IS_VARIABLE(T) ( (Word) T <= TYPELAYOUT_MAX_VARINT )
/*
+** This constant is also used for other information - for
+** ctor infos a small integer is used for higher order types.
+** Even integers represent preds, odd represent functions.
+** The arity of the pred or function can be found by dividing by
+** two (integer division).
+*/
+
+#define MR_BASE_TYPEINFO_HO_PRED \
+ ((const Word *) &mercury_data___base_type_info_pred_0)
+#define MR_BASE_TYPEINFO_HO_FUNC \
+ ((const Word *) &mercury_data___base_type_info_func_0)
+#define MR_BASE_TYPEINFO_IS_HO_PRED(T) \
+ (T == MR_BASE_TYPEINFO_HO_PRED)
+#define MR_BASE_TYPEINFO_IS_HO_FUNC(T) \
+ (T == MR_BASE_TYPEINFO_HO_FUNC)
+
+#define MR_TYPECTOR_IS_HIGHER_ORDER(T) \
+ ( (Word) T <= TYPELAYOUT_MAX_VARINT )
+#define MR_TYPECTOR_MAKE_PRED(Arity) \
+ ( (Word) ((Integer) (Arity) * 2) )
+#define MR_TYPECTOR_MAKE_FUNC(Arity) \
+ ( (Word) ((Integer) (Arity) * 2 + 1) )
+#define MR_TYPECTOR_GET_HOT_ARITY(T) \
+ ((Integer) (T) / 2 )
+#define MR_TYPECTOR_GET_HOT_NAME(T) \
+ ((String) (Word) ( ( ((Integer) (T)) % 2 ) ? "func" : "pred" ))
+#define MR_TYPECTOR_GET_HOT_BASE_TYPE_INFO(T) \
+ ((Word) ( ( ((Integer) (T)) % 2 ) ? \
+ (const Word *) &mercury_data___base_type_info_func_0 : \
+ (const Word *) &mercury_data___base_type_info_pred_0 ))
+
+/*
** Offsets into the type_layout structure for functors and arities.
**
** Constant and enumeration values start at 0, so the functor
@@ -654,6 +686,9 @@
#define MR_TYPEINFO_GET_BASE_TYPEINFO(TypeInfo) \
((*TypeInfo) ? ((Word *) *TypeInfo) : TypeInfo)
+
+#define MR_TYPEINFO_GET_HIGHER_ARITY(TypeInfo) \
+ ((Integer) (Word *) (TypeInfo)[TYPEINFO_OFFSET_FOR_PRED_ARITY])
#define MR_BASE_TYPEINFO_GET_TYPEFUNCTORS(BaseTypeInfo) \
((Word *) (BaseTypeInfo)[OFFSET_FOR_BASE_TYPE_FUNCTORS])
Index: tests/hard_coded/Mmake
===================================================================
RCS file: /home/staff/zs/imp/tests/hard_coded/Mmake,v
retrieving revision 1.50
diff -u -r1.50 Mmake
--- Mmake 1997/07/09 08:21:08 1.50
+++ Mmake 1997/07/15 06:29:48
@@ -31,6 +31,7 @@
getopt_test \
higher_order_func_test \
higher_order_syntax \
+ higher_order_type_manip \
ho_func_reg \
ho_solns \
ho_univ_to_type \
New File: tests/hard_coded/higher_order_type_manip.exp
===================================================================
func(type_info) = string
pred(type_info, c_pointer, list(type_info))
func(int) = int
New File: tests/hard_coded/higher_order_type_manip.m
===================================================================
%
% File: ho_type_manip.m
%
% Test case for higher order type manipulation.
%
% Author: trd
:- module higher_order_type_manip.
:- interface.
:- import_module io.
:- pred main(io__state::di, io__state::uo) is det.
:- implementation.
:- import_module std_util, list.
main -->
io__write_string(type_name(type_of(type_name))),
io__write_string("\n"),
io__write_string(type_name(type_of(type_ctor_and_args))),
io__write_string("\n"),
{ Ctor = type_ctor(type_of(type_name)) },
{ IntType = type_of(8) },
{ NewType = det_make_type(Ctor, [IntType, IntType]) },
io__write_string(type_name(NewType)),
io__write_string("\n").
--
Tyson Dowd # 4.4: People keep saying the behavior is undefined,
# but I just tried it on an ANSI-conforming compiler
trd at cs.mu.oz.au # and got the results I expected.
http://www.cs.mu.oz.au/~trd # A: They were wrong. Flame them mercilessly. C-IAQ
More information about the developers
mailing list