for review: change library to use existential types

Fergus Henderson fjh at cs.mu.OZ.AU
Wed Nov 18 20:03:11 AEDT 1998
Previous message: [m-dev.] for review: announce MCORBA paper
Next message: [m-dev.] for review: change library to use existential types
Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]
Hi,

I suppose dgj is the exisential types export -- could you
please review this one for me, David?

--------------------

Change the standard library to use existential types.

library/std_util.m:
	Add new existentially typed procedures univ_value/1 and has_type/2.

library/term.m:
library/io.m:
	Use existential types rather than unsafe casts and other hacks.

Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.136
diff -u -r1.136 std_util.m
--- std_util.m	1998/11/17 00:57:39	1.136
+++ std_util.m	1998/11/18 08:43:24
@@ -78,6 +78,14 @@
 	%
 :- func univ_type(univ) = type_info.
 
+
+	% univ_value(Univ):
+	%	returns the value of the object stored in Univ.
+	%
+	% Warning: support for existential types is still experimental.
+	%
+:- some [T] func univ_value(univ) = T.
+
 %-----------------------------------------------------------------------------%
 
 % The "maybe" type.
@@ -214,11 +222,21 @@
 	% get_functor/5 and construct/3 will fail if used upon a value
 	% of this type.)
 
-	% type_of(Data) returns a representation of the type of Data.
+	% The function type_of/1 returns a representation of the type
+	% of its argument.
 	%
 :- func type_of(T) = type_info.
 :- mode type_of(unused) = out is det.
 
+	% The predicate has_type/2 is basically an existentially typed
+	% inverse to the function type_of/1.  It constrains the type
+	% of the first argument to be the type represented by the
+	% second argument.
+	%
+	% Warning: support for existential types is still experimental.
+	%
+:- some [T] pred has_type(T::unused, type_info::in) is det.
+
 	% type_name(Type) returns the name of the specified type
 	% (e.g. type_name(type_of([2,3])) = "list:list(int)").
 	% Any equivalence types will be fully expanded.
@@ -970,24 +988,11 @@
 		error(ErrorString)
 	).
 
-/****
-
-% univ_value/1 can't be implemented yet, due to the lack of support for
-% existential types in Mercury.
-
-	% univ_value(Univ):
-	%	returns the value of the object stored in Univ.
-:- some [T] (
-   func univ_value(univ) = T
-).
-
-:- pragma c_code(univ_value(Univ::uo) = (Value), will_not_call_mercury, "
+:- pragma c_code(univ_value(Univ::in) = (Value::out), will_not_call_mercury, "
 	TypeInfo_for_T = field(mktag(0), Univ, UNIV_OFFSET_FOR_TYPEINFO);
-	Value = field(mktag(0), Univ, UNIV_OFFSET_FOR_Data);
+	Value = field(mktag(0), Univ, UNIV_OFFSET_FOR_DATA);
 ").
 
-****/
-
 :- pragma c_header_code("
 /*
 **	`univ' is represented as a two word structure.
@@ -1322,14 +1327,9 @@
 	% small integers.  See runtime/type_info.h.
 :- type type_ctor_info == c_pointer.  
 
-:- pragma c_code(type_of(Value::unused) = (TypeInfo::out),
+:- pragma c_code(type_of(_Value::unused) = (TypeInfo::out),
 	will_not_call_mercury, " 
 {
-	/* 
-	** `Value' isn't used in this c_code, but the compiler
-	** gives a warning if you don't mention it.
-	*/ 
-
 	TypeInfo = TypeInfo_for_T;
 
 	/*
@@ -1345,6 +1345,10 @@
 #endif
 
 }
+").
+
+:- pragma c_code(has_type(_Arg::unused, TypeInfo::in), will_not_call_mercury, "
+	TypeInfo_for_T = TypeInfo;
 ").
 
 % Export this function in order to use it in runtime/mercury_trace_external.c
Index: library/io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/io.m,v
retrieving revision 1.171
diff -u -r1.171 io.m
--- io.m	1998/11/15 16:47:40	1.171
+++ io.m	1998/11/18 08:43:22
@@ -1792,6 +1792,8 @@
 	io__write(X),
 	io__set_output_stream(OrigStream, _Stream).
 
+%-----------------------------------------------------------------------------%
+
 io__write(Term) -->
 	{ type_to_univ(Term, Univ) },
 	io__write_univ(Univ).
@@ -1808,6 +1810,7 @@
 	% we need to special-case the builtin types:
 	%	int, char, float, string
 	%	type_info, univ, c_pointer, array
+	%	and private_builtin:type_info
 	%
 	( { univ_to_type(Univ, String) } ->
 		term_io__quote_string(String)
@@ -1818,64 +1821,69 @@
 	; { univ_to_type(Univ, Float) } ->
 		io__write_float(Float)
 	; { univ_to_type(Univ, TypeInfo) } ->
-		io__write_string(type_name(TypeInfo))
+		io__write_type_info(TypeInfo)
 	; { univ_to_type(Univ, OrigUniv) } ->
 		io__write_univ_as_univ(OrigUniv)
 	; { univ_to_type(Univ, C_Pointer) } ->
 		io__write_c_pointer(C_Pointer)
-	; { type_ctor_name(type_ctor(univ_type(Univ))) = "type_info" },
-	  { type_ctor_module_name(type_ctor(univ_type(Univ))) =
-			"private_builtin" } ->
-	  	% XXX This is a hack (see the comment for array below).
-		{ TypeInfo = unsafe_cast(univ_value_as_type_any(Univ)) },
-		io__write_string(type_name(TypeInfo))
-	; { type_ctor_name(type_ctor(univ_type(Univ))) = "array" },
-	  { type_ctor_module_name(type_ctor(univ_type(Univ))) = "array" } ->
-		%
-		% Note that we can't use univ_to_type above, because we
-		% want to match on a non-ground type `array(T)'
-		% (matching against `array(void)' isn't much use).
-		% Instead, we explicitly check the type name.
-		% That makes it tricky to get the value, so
-		% we can't use io__write_array below... instead we
-		% use the following, which is a bit of a hack.
-		%
-		{ term__univ_to_term(Univ, Term) },
-		{ varset__init(VarSet) },
-		term_io__write_term(VarSet, Term)
 	;
+		%
+		% Check if the type is array:array/1.
+		% We can't just use univ_to_type here since 
+		% array:array/1 is a polymorphic type.
+		%
+		% The calls to type_ctor_name and type_ctor_module_name
+		% are not really necessary -- we could use univ_to_type
+		% in the condition instead of det_univ_to_type in the body.
+		% However, this way of doing things is probably more efficient
+		% in the common case when the thing being printed is
+		% *not* of type array:array/1.
+		%
+		% The ordering of the tests here (arity, then name, then
+		% module name, rather than the reverse) is also chosen
+		% for efficiency, to find failure cheaply in the common cases,
+		% rather than for readability.
+		%
+		{ type_ctor_and_args(univ_type(Univ), TypeCtor, ArgTypes) },
+		{ ArgTypes = [ElemType] },
+		{ type_ctor_name(TypeCtor) = "array" },
+		{ type_ctor_module_name(TypeCtor) = "array" }
+	->
+		%
+		% Now that we know the element type, we can
+		% constrain the type of the variable `Array'
+		% so that we can use det_univ_to_type.
+		%
+		{ has_type(Elem, ElemType) },
+		{ same_array_elem_type(Array, Elem) },
+		{ det_univ_to_type(Univ, Array) },
+		io__write_array(Array)
+	; 
+		%
+		% Check if the type is private_builtin:type_info/1.
+		% See the comments above for array:array/1.
+		%
+		{ type_ctor_and_args(univ_type(Univ), TypeCtor, ArgTypes) },
+		{ ArgTypes = [ElemType] },
+		{ type_ctor_name(TypeCtor) = "type_info" },
+		{ type_ctor_module_name(TypeCtor) = "private_builtin" }
+	->
+		{ has_type(Elem, ElemType) },
+		{ same_private_builtin_type(PrivateBuiltinTypeInfo, Elem) },
+		{ det_univ_to_type(Univ, PrivateBuiltinTypeInfo) },
+		io__write_private_builtin_type_info(PrivateBuiltinTypeInfo)
+	; 
 		io__write_ordinary_term(Univ, Priority)
 	).
 
-	% XXX These two functions and the type definition 
-	% are just temporary, they are used for the
-	% horrible hack above.
-
-:- func unsafe_cast(T1::in) = (T2::out) is det.
-:- pragma c_code(unsafe_cast(VarIn::in) = (VarOut::out),
-	[will_not_call_mercury, thread_safe], "
-	VarOut = VarIn;
-").
-
-:- type any == c_pointer.
-
-:- func univ_value_as_type_any(univ) = any.
-:- pragma c_code(univ_value_as_type_any(Univ::in) = (Val::out),
-	[will_not_call_mercury, thread_safe], "
-	Val = field(mktag(0), Univ, UNIV_OFFSET_FOR_DATA);
-").
-
-
-:- pred io__write_univ_as_univ(univ, io__state, io__state).
-:- mode io__write_univ_as_univ(in, di, uo) is det.
+:- pred same_array_elem_type(array(T), T).
+:- mode same_array_elem_type(unused, unused) is det.
+same_array_elem_type(_, _).
+
+:- pred same_private_builtin_type(private_builtin__type_info(T), T).
+:- mode same_private_builtin_type(unused, unused) is det.
+same_private_builtin_type(_, _).
 
-io__write_univ_as_univ(Univ) -->
-	io__write_string("univ("),
-	io__write_univ(Univ),
-	% XXX what is the right TYPE_QUAL_OP to use here?
-	io__write_string(" : "),
-	io__write_string(type_name(univ_type(Univ))),
-	io__write_string(")").
 
 :- pred io__write_ordinary_term(univ, ops__priority, io__state, io__state).
 :- mode io__write_ordinary_term(in, in, di, uo) is det.
@@ -2029,6 +2037,32 @@
 	io__write_univ(X),
 	io__write_term_args(Xs).
 
+%-----------------------------------------------------------------------------%
+
+:- pred io__write_type_info(type_info, io__state, io__state).
+:- mode io__write_type_info(in, di, uo) is det.
+
+io__write_type_info(TypeInfo) -->
+	io__write_string(type_name(TypeInfo)).
+
+:- pred io__write_univ_as_univ(univ, io__state, io__state).
+:- mode io__write_univ_as_univ(in, di, uo) is det.
+
+io__write_univ_as_univ(Univ) -->
+	io__write_string("univ("),
+	io__write_univ(Univ),
+	% XXX what is the right TYPE_QUAL_OP to use here?
+	io__write_string(" : "),
+	io__write_string(type_name(univ_type(Univ))),
+	io__write_string(")").
+
+:- pred io__write_c_pointer(c_pointer, io__state, io__state).
+:- mode io__write_c_pointer(in, di, uo) is det.
+
+io__write_c_pointer(_C_Pointer) -->
+	% XXX what should we do here?
+	io__write_string("'<<c_pointer>>'").
+
 :- pred io__write_array(array(T), io__state, io__state).
 :- mode io__write_array(in, di, uo) is det.
 
@@ -2038,12 +2072,18 @@
 	io__write(List),
 	io__write_string(")").
 
-:- pred io__write_c_pointer(c_pointer, io__state, io__state).
-:- mode io__write_c_pointer(in, di, uo) is det.
+:- pred io__write_private_builtin_type_info(private_builtin__type_info(T)::in,
+		io__state::di, io__state::uo) is det.
+io__write_private_builtin_type_info(PrivateBuiltinTypeInfo) -->
+	{ TypeInfo = unsafe_cast(PrivateBuiltinTypeInfo) },
+	io__write_type_info(TypeInfo).
 
-io__write_c_pointer(_C_Pointer) -->
-	% XXX what should we do here?
-	io__write_string("'<<c_pointer>>'").
+:- func unsafe_cast(T1::in) = (T2::out) is det.
+:- pragma c_code(unsafe_cast(VarIn::in) = (VarOut::out),
+	[will_not_call_mercury, thread_safe],
+"
+	VarOut = VarIn;
+").
 
 %-----------------------------------------------------------------------------%
 
Index: library/term.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/term.m,v
retrieving revision 1.86
diff -u -r1.86 term.m
--- term.m	1998/10/02 20:14:52	1.86
+++ term.m	1998/10/27 16:33:35
@@ -434,31 +434,18 @@
 	% convert the term representing the list of elements back to a list,
 	% and then (if successful) we just call the array/1 function.
 	%
-	ListTypeCtor = type_ctor(type_of([0])),
-	ListType = det_make_type(ListTypeCtor, [ElemType]),
+	has_type(Elem, ElemType),
+	ListType = type_of([Elem]),
 	ArgContext = arg_context(term__atom("array"), 1, TermContext),
 	NewContext = [ArgContext | PrevContext],
 	term__try_term_to_univ_2(ArgList, ListType, NewContext, ArgResult),
 	(
 		ArgResult = ok(ListUniv),
-/***************
-% XXX existential types not yet implemented...
-		% :- some [T] pred has_type(T::unused, type_info::in) is det.
-		has_type(List, ListType),
+		has_type(Elem2, ElemType),
+		same_type(List, [Elem2]),
 		det_univ_to_type(ListUniv, List),
 		Array = array(List),
 		Result = ok(univ(Array))
-****************/
-		% since we don't have existential types, we have to use
-		% some unsafe casts...
-		require_equal(univ_type(ListUniv), ListType),
-		list_of_any(List),   % explicit type qualification
-				     % to avoid unbound type variables
-		List = unsafe_cast(univ_value_as_type_any(ListUniv)),
-		Array = array(List),
-		ArrayTypeCtor = type_ctor(type_of(Array)),
-		ArrayType = det_make_type(ArrayTypeCtor, [ElemType]),
-		Result = ok(unsafe_any_to_univ(ArrayType, unsafe_cast(Array)))
 	;
 		ArgResult = error(Error),
 		Result = error(Error)
@@ -476,9 +463,6 @@
 	% ditto
 	fail.
 
-:- pred same_type(T::unused, T::unused) is det.
-same_type(_, _).
-
 :- pred term__term_list_to_univ_list(list(term)::in, list(type_info)::in,
 		term__const::in, int::in, term_to_type_context::in,
 		term__context::in, term_to_type_result(list(univ))::out)
@@ -542,48 +526,6 @@
 
 %-----------------------------------------------------------------------------%
 
-/**********
-XXX existential types not yet implemented
-:- some [T] pred has_type(T::unused, type_info::in) is det.
-:- pragma c_code(has_type(Arg::unused, TypeInfo::in), will_not_call_mercury,
-	"TypeInfo_for_T = TypeInfo;"
-).
-**********/
-
-:- func unsafe_cast(T1::in) = (T2::out) is det.
-:- pragma c_code(unsafe_cast(VarIn::in) = (VarOut::out), will_not_call_mercury,
-	"VarOut = VarIn;").
-
-:- type any == c_pointer.
-
-:- pred array_of_any(array(any)::unused) is det.
-array_of_any(_).
-
-:- pred list_of_any(list(any)::unused) is det.
-list_of_any(_).
-
-:- func univ_value_as_type_any(univ) = any.
-:- pragma c_code(univ_value_as_type_any(Univ::in) = (Val::out),
-		will_not_call_mercury,
-"
-	Val = field(mktag(0), Univ, UNIV_OFFSET_FOR_DATA);
-").
-
-:- func unsafe_any_to_univ(type_info, any) = univ.
-	% Forward mode - convert from type to univ.
-	% Allocate heap space, set the first field to contain the address
-	% of the type_info for this type, and then store the input argument
-	% in the second field.
-:- pragma c_code(unsafe_any_to_univ(TypeInfo::in, Value::in) = (Univ::out),
-		will_not_call_mercury,
-"
-	incr_hp(Univ, 2);
-	field(mktag(0), Univ, UNIV_OFFSET_FOR_TYPEINFO) = (Word) TypeInfo;
-	field(mktag(0), Univ, UNIV_OFFSET_FOR_DATA) = (Word) Value;
-").
-
-%-----------------------------------------------------------------------------%
-
 term__type_to_term(Val, Term) :- type_to_univ(Val, Univ),
 	term__univ_to_term(Univ, Term).
 
@@ -661,36 +603,21 @@
 			[term__functor(term__atom(":"),	 % TYPE_QUAL_OP
 				[ValueTerm, TypeTerm],
 				Context)], Context),
-/****
-XXX existential types not implemented
-	det_univ_to_type(univ_value(Univ), UnivValue),
-****/
-	% instead, we use some unsafe casts...
-	require_equal(univ_type(Univ), type_of(UnivValue)),
-	UnivValue = unsafe_cast(univ_value_as_type_any(Univ)),
-
-	type_info_to_term(Context, univ_type(UnivValue), TypeTerm),
-	term__univ_to_term(UnivValue, ValueTerm).
+	type_info_to_term(Context, univ_type(Univ), TypeTerm),
+	UnivValue = univ_value(Univ),
+	term__type_to_term(UnivValue, ValueTerm).
 
 term__univ_to_term_special_case("array", "array", [ElemType], Univ, Context, 
 		Term) :-
 	Term = term__functor(term__atom("array"), [ArgsTerm], Context),
-	ListTypeCtor = type_ctor(type_of([0])),
-	ListType = det_make_type(ListTypeCtor, [ElemType]),
-/***
-XXX existential types not yet implemented
-	has_type(List, ListType),
-	det__univ_to_type(Univ, Array),	
+	has_type(Elem, ElemType),
+	same_type(List, [Elem]),
+	det_univ_to_type(Univ, Array),	
 	array__to_list(Array, List),
 	term__type_to_term(List, ArgsTerm).
-***/
-	% instead, we need to use some unsafe casts...
-	array_of_any(Array), % explicit type qualification
-			     % to avoid unbound type variables
-	Array = unsafe_cast(univ_value_as_type_any(Univ)),	
-	array__to_list(Array, List),
-	ListUniv = unsafe_any_to_univ(ListType, unsafe_cast(List)),
-	term__univ_to_term(ListUniv, ArgsTerm).
+
+:- pred same_type(T::unused, T::unused) is det.
+same_type(_, _).
 
 :- pred term__univ_list_to_term_list(list(univ)::in,
 				list(term)::out) is det.

-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "Binaries may die
WWW: <http://www.cs.mu.oz.au/~fjh>  |   but source code lives forever"
PGP: finger fjh at 128.250.37.3        |     -- leaked Microsoft memo.
Previous message: [m-dev.] for review: announce MCORBA paper
Next message: [m-dev.] for review: change library to use existential types
Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]
More information about the developers mailing list