diff: type_name for higher order, round 2
Tyson Richard DOWD
trd at cs.mu.oz.au
Wed Jul 16 18:07:38 AEST 1997
Hi,
Here's an improved diff - further testing revealed a bug in
ML_create_type_info, and fixing that meant updating code in deep_copy as
well (two functions that need to be kept in sync). This in turn meant
that code should be moved to the runtime library. Hence the following
changes...
===================================================================
Estimated hours taken: 5
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:
Move base_type_* for pred/0 out of library (into runtime).
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).
Fix ML_create_type_info so it works correctly with higher order
types.
runtime/type_info.h:
Define macros to deal with new representation of higher order
ctor_infos.
runtime/deep_copy.c:
Fix make_type_info so it works correctly with higher order
types.
runtime/Mmakefile:
runtime/type_info.mod:
Add definitions for pred/0 and func/0 in runtime, they are
needed by deep copy.
tests/hard_coded/Mmake:
tests/hard_coded/higher_order_type_manip.exp:
tests/hard_coded/higher_order_type_manip.m:
Test case for this change.
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/16 02:45:52
@@ -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 find 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/16 02:47:09
@@ -719,19 +719,20 @@
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,
+ hlds_out__pred_or_func_to_string(PredOrFunc, PredOrFuncStr),
+ TypeId = unqualified(PredOrFuncStr) - 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/16 06:36:00
@@ -311,24 +311,9 @@
:- pragma(c_code, builtin_strcmp(Res::out, S1::in, S2::in),
"Res = strcmp(S1, S2);").
-builtin_unify_pred(_Pred1, _Pred2) :-
- % suppress determinism warning
- ( semidet_succeed ->
- error("attempted unification of higher-order predicate terms")
- ;
- semidet_fail
- ).
-
-builtin_index_pred(_, -1).
-
-builtin_compare_pred(Res, _Pred1, _Pred2) :-
- % suppress determinism warning
- ( semidet_succeed ->
- error("attempted comparison of higher-order predicate terms")
- ;
- % the following is never executed
- Res = (<)
- ).
+:- external(builtin_unify_pred/2).
+:- external(builtin_index_pred/2).
+:- external(builtin_compare_pred/3).
unused :-
( semidet_succeed ->
@@ -383,16 +368,6 @@
mkbody(TYPELAYOUT_FLOAT_VALUE))
};
- /* base_type_layout for `pred' */
- /* (this is used for all higher-order types) */
-
-const struct mercury_data___base_type_layout_pred_0_struct {
- TYPE_LAYOUT_FIELDS
-} mercury_data___base_type_layout_pred_0 = {
- make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
- mkbody(TYPELAYOUT_PREDICATE_VALUE))
-};
-
/* base_type_layout for `void' */
const struct mercury_data___base_type_layout_void_0_struct {
@@ -436,15 +411,6 @@
MR_TYPEFUNCTORS_SPECIAL
};
- /* base_type_functors for `pred' */
- /* (this is used for all higher-order types) */
-
-const struct mercury_data___base_type_functors_pred_0_struct {
- Integer f1;
-} mercury_data___base_type_functors_pred_0 = {
- MR_TYPEFUNCTORS_SPECIAL
-};
-
/* base_type_functors for `void' */
const struct mercury_data___base_type_functors_void_0_struct {
@@ -579,38 +545,6 @@
(const Word *) & mercury_data___base_type_layout_float_0,
(const Word *) & mercury_data___base_type_functors_float_0,
(const Word *) string_const(""float"", 5)
-#endif
-};
-
- /* base_type_info for `pred' */
- /* (this is used for all higher-order types) */
-
-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_pred_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_pred_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(""pred"", 4)
#endif
};
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/16 05:55:13
@@ -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,38 @@
{
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 = (String) (Word)
+ 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 +1428,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 +1731,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 +1744,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);
}
@@ -2311,7 +2397,7 @@
** type_info.
**
** NOTE: If you are changing this code, you might also need
- ** to change the code in ML_create_type_info in runtime/deep_copy.c,
+ ** to change the code in make_type_info in runtime/deep_copy.c,
** which does much the same thing, only allocating using malloc
** instead of on the heap.
*/
@@ -2319,8 +2405,8 @@
Word *
ML_create_type_info(Word *term_type_info, Word *arg_pseudo_type_info)
{
- int i, arity;
- Word base_type_info;
+ int i, arity, extra_args;
+ Word *base_type_info;
Word *type_info;
/*
@@ -2337,30 +2423,69 @@
fatal_error(""ML_create_type_info: unbound type variable"");
}
- base_type_info = arg_pseudo_type_info[0];
+ base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(arg_pseudo_type_info);
/* no arguments - optimise common case */
- if (base_type_info == 0) {
+ if (base_type_info == arg_pseudo_type_info) {
return arg_pseudo_type_info;
}
- arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+ if (MR_BASE_TYPEINFO_IS_HO_PRED(base_type_info) ||
+ MR_BASE_TYPEINFO_IS_HO_FUNC(base_type_info)) {
+ arity = MR_TYPEINFO_GET_HIGHER_ARITY(arg_pseudo_type_info);
+ extra_args = 2;
+ } else {
+ arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+ extra_args = 1;
+ }
- incr_saved_hp(LVALUE_CAST(Word, type_info), arity + 1);
- for (i = 0; i <= arity; i++) {
+ /*
+ ** Check for type variables -- if there are none,
+ ** we don't need to create a new type_info.
+ */
+ for (i = arity + extra_args - 1; i >= extra_args; i--) {
if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info[i])) {
- type_info[i] = term_type_info[arg_pseudo_type_info[i]];
- if (TYPEINFO_IS_VARIABLE(type_info[i])) {
- fatal_error(""ML_create_type_info: ""
- ""unbound type variable"");
- }
+ break;
+ }
+ }
- } else {
+ /*
+ ** Do we need to create a new type_info?
+ */
+ if (i >= extra_args) {
+ incr_saved_hp(LVALUE_CAST(Word, type_info), arity + extra_args);
+
+ /*
+ ** Copy any preliminary arguments to the type_info
+ ** (this means the base_type_info and possibly
+ ** arity for higher order terms).
+ */
+ for (i = 0; i < extra_args; i++) {
type_info[i] = arg_pseudo_type_info[i];
}
+
+ /*
+ ** Copy type arguments, substituting for any
+ ** type variables.
+ */
+ for (i = extra_args; i < arity + extra_args; i++) {
+ if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info[i])) {
+ type_info[i] = term_type_info[
+ arg_pseudo_type_info[i]];
+ if (TYPEINFO_IS_VARIABLE(type_info[i])) {
+ fatal_error(""ML_create_type_info: ""
+ ""unbound type variable"");
+ }
+
+ } else {
+ type_info[i] = arg_pseudo_type_info[i];
+ }
+ }
+ return type_info;
+ } else {
+ return arg_pseudo_type_info;
}
- return type_info;
}
").
Index: runtime/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/Mmakefile,v
retrieving revision 1.6
diff -u -r1.6 Mmakefile
--- Mmakefile 1997/06/16 13:35:29 1.6
+++ Mmakefile 1997/07/16 06:20:35
@@ -35,8 +35,8 @@
machdeps/mips_regs.h machdeps/sparc_regs.h \
machdeps/alpha_regs.h machdeps/pa_regs.h \
machdeps/rs6000_regs.h
-MODS = engine.mod wrapper.mod call.mod context.mod
-MOD_CS = engine.c wrapper.c call.c context.c
+MODS = engine.mod wrapper.mod call.mod context.mod type_info.mod
+MOD_CS = engine.c wrapper.c call.c context.c type_info.c
MOD_OS = $(MOD_CS:.c=.o)
ORIG_CS = deep_copy.c dlist.c dummy.c label.c \
memory.c misc.c regs.c table.c timing.c prof.c prof_mem.c \
Index: runtime/deep_copy.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/deep_copy.c,v
retrieving revision 1.11
diff -u -r1.11 deep_copy.c
--- deep_copy.c 1997/04/28 12:11:15 1.11
+++ deep_copy.c 1997/07/16 06:24:44
@@ -23,6 +23,9 @@
static Word * deep_copy_type_info(Word *type_info,
Word *lower_limit, Word *upper_limit);
+MR_DECLARE_STRUCT(mercury_data___base_type_info_pred_0);
+MR_DECLARE_STRUCT(mercury_data___base_type_info_func_0);
+
/*
** Due to the depth of the control here, we'll use 4 space indentation.
*/
@@ -383,46 +386,74 @@
make_type_info(Word *term_type_info, Word *arg_pseudo_type_info,
bool *allocated)
{
- int arity, i;
- Word base_type_info;
+ int arity, i, extra_args;
+ Word *base_type_info;
Word *type_info;
*allocated = FALSE;
- /* The arg_pseudo_type_info might be a polymorphic variable */
+ /*
+ ** The arg_pseudo_type_info might be a polymorphic variable,
+ ** is so - substitute.
+ */
- if ((Word) arg_pseudo_type_info < TYPELAYOUT_MAX_VARINT) {
+ if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info)) {
return (Word *) term_type_info[(Word) arg_pseudo_type_info];
}
-
- base_type_info = arg_pseudo_type_info[0];
+ base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(arg_pseudo_type_info);
/* no arguments - optimise common case */
- if (base_type_info == 0) {
+ if (base_type_info == arg_pseudo_type_info) {
return arg_pseudo_type_info;
- } else {
- arity = ((Word *) base_type_info)[0];
- }
+ }
+
+ if (MR_BASE_TYPEINFO_IS_HO_PRED(base_type_info) ||
+ MR_BASE_TYPEINFO_IS_HO_FUNC(base_type_info)) {
+ arity = MR_TYPEINFO_GET_HIGHER_ARITY(arg_pseudo_type_info);
+ extra_args = 2;
+ } else {
+ arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+ extra_args = 1;
+ }
- for (i = arity; i > 0; i--) {
- if (arg_pseudo_type_info[i] < TYPELAYOUT_MAX_VARINT) {
+ /*
+ ** Check for type variables -- if there are none,
+ ** we don't need to create a new type_info.
+ */
+ for (i = arity + extra_args - 1; i >= extra_args; i--) {
+ if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info[i])) {
break;
}
}
- /*
- ** See if any of the arguments were polymorphic.
- ** If so, substitute.
- */
- if (i > 0) {
- type_info = checked_malloc(arity * sizeof(Word));
+ /*
+ ** Do we need to create a new type_info?
+ */
+ if (i >= extra_args) {
+ type_info = checked_malloc((arity + extra_args) * sizeof(Word));
*allocated = TRUE;
- for (i = 0; i <= arity; i++) {
- if (arg_pseudo_type_info[i] < TYPELAYOUT_MAX_VARINT) {
- type_info[i] = term_type_info[arg_pseudo_type_info[i]];
+
+ /*
+ ** Copy any preliminary arguments to the type_info
+ ** (this means the base_type_info and possibly
+ ** arity for higher order terms).
+ */
+ for (i = 0; i < extra_args; i++) {
+ type_info[i] = arg_pseudo_type_info[i];
+ }
+
+ /*
+ ** Copy type arguments, substituting for any
+ ** type variables.
+ */
+ for (i = extra_args; i < arity + extra_args; i++) {
+ if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info[i])) {
+ type_info[i] = term_type_info[
+ arg_pseudo_type_info[i]];
if (type_info[i] < TYPELAYOUT_MAX_VARINT) {
- fatal_error("Error! Can't instantiate type variable.");
+ fatal_error("make_type_info: "
+ "unbound type variable.");
}
} else {
type_info[i] = arg_pseudo_type_info[i];
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/16 02:49:06
@@ -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) \
+ ((ConstString) ( ( ((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: runtime/type_info.mod
===================================================================
/*
** Copyright (C) 1995-1997 University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
** Public License - see the file COPYING.LIB in the Mercury distribution.
*/
/*
** type_info.c -
** Definitions for type_infos, type_layouts, and
** type_functors tables needed by the Mercury runtime system..
*/
#include "imp.h"
#include "type_info.h"
/*---------------------------------------------------------------------------*/
/* base_type_layout for `pred' */
/* (this is used for all higher-order types) */
const struct mercury_data___base_type_layout_pred_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_pred_0 = {
make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
mkbody(TYPELAYOUT_PREDICATE_VALUE))
};
/* base_type_functors for `pred' */
/* (this is used for all higher-order types) */
const struct mercury_data___base_type_functors_pred_0_struct {
Integer f1;
} mercury_data___base_type_functors_pred_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
/*
** 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);
Declare_entry(mercury__builtin_compare_pred_3_0);
MR_STATIC_CODE_CONST struct mercury_data___base_type_info_pred_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_pred_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("pred", 4)
#endif
};
Define_extern_entry(mercury__builtin_unify_pred_2_0);
Define_extern_entry(mercury__builtin_index_pred_2_0);
Define_extern_entry(mercury__builtin_compare_pred_3_0);
Declare_label(mercury__builtin_compare_pred_3_0_i4);
BEGIN_MODULE(mercury__builtin_unify_pred_module)
BEGIN_CODE
/* code for predicate 'builtin_unify_pred'/2 in mode 0 */
mercury__builtin_unify_pred_2_0:
incr_sp_push_msg(2, "mercury_builtin:builtin_unify_pred");
fatal_error("attempted unification of higher-order terms");
END_MODULE
BEGIN_MODULE(mercury__builtin_index_pred_module)
BEGIN_CODE
/* code for predicate 'builtin_index_pred'/2 in mode 0 */
mercury__builtin_index_pred_2_0:
r1 = (Integer) -1;
proceed();
END_MODULE
BEGIN_MODULE(mercury__builtin_compare_pred_module)
BEGIN_CODE
/* code for predicate 'builtin_compare_pred'/3 in mode 0 */
mercury__builtin_compare_pred_3_0:
incr_sp_push_msg(2, "mercury_builtin:builtin_compare_pred");
fatal_error("attempted comparison of higher-order terms");
END_MODULE
/*---------------------------------------------------------------------------*/
New File: tests/hard_coded/higher_order_type_manip.exp
===================================================================
func(type_info) = string
pred(type_info, c_pointer, list(type_info))
int
container(list(int))
container(pred(state, state))
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.
:- func tryme = int.
:- type container(T) ---> container(T).
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"),
io__write_string(type_name(type_of(tryme))),
io__write_string("\n"),
io__write_string(type_name(type_of(container([1,2,3])))),
io__write_string("\n"),
io__write_string(type_name(type_of(container(main)))),
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").
tryme = 4.
--
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