[m-rev.] for review: implement RTTI for io__write on .NET
Tyson Dowd
trd at miscrit.be
Thu Sep 20 22:56:30 AEST 2001
Hi,
Most of the time spent on this was actually spent grappling with the
problem that generated structs were being generated as nested arrays,
and not nested structures.
I attribute that debugging time to this change because the behaviour
might be considered correct, only that for the purposes of RTTI it isn't
what we want to be able to effectively use these data structures.
As a side effect of this change uncaught exceptions are now printed
correctly.
===================================================================
Estimated hours taken: 50
Branches: main
Implement most of the RTTI required for io__write to work in the .NET
backend. With this code most of tests/hard_coded/write.m work (up until
the point where we try to write a univ).
We don't yet handle higher-order terms or existentially quantified type
variables.
library/io.m:
Prepend an "_" to some unused variables.
Move unsafe_cast from io.m into rtti_implementation.m -- it is
useful in rtti_implementation (and possibly elsewhere), and it's
better to have io depend on rtti_implementation than vice-versa.
library/rtti_implementation.m:
Implement type_ctor_name_and_arity for commonly occuring data
representations.
Add type_ctor_is_variable_arity to simplfy this test.
Rename index as type_info_index to make it clear what we are
indexing into.
library/std_util.m:
Improve some of the error messages to make it easier to track
down unimplemented code.
Call into rtti_implementation for type_ctor_and_args.
Use pragma export to generate ML_call_rtti_compare_type_infos
(it wasn't available before so we jumped through a few more
hoops to call into rtti_implementation).
Index: library/io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/io.m,v
retrieving revision 1.231
diff -u -r1.231 io.m
--- library/io.m 12 Sep 2001 10:34:45 -0000 1.231
+++ library/io.m 20 Sep 2001 10:23:28 -0000
@@ -1120,6 +1120,7 @@
:- import_module map, dir, term, term_io, varset, require, benchmarking, array.
:- import_module bool, int, parser, exception.
:- use_module table_builtin.
+:- use_module rtti_implementation.
:- type io__state ---> io__state(c_pointer).
% Values of type `io__state' are never really used:
@@ -1594,7 +1595,7 @@
MR_PROC_LABEL, RetStr);
}").
-:- pragma foreign_proc("MC++", ferror(Stream::in, RetVal::out, RetStr::out,
+:- pragma foreign_proc("MC++", ferror(_Stream::in, RetVal::out, _RetStr::out,
IO0::di, IO::uo),
[will_not_call_mercury, thread_safe],
"{
@@ -2410,23 +2411,9 @@
:- 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) },
+ { TypeInfo = rtti_implementation__unsafe_cast(PrivateBuiltinTypeInfo) },
io__write_type_desc(TypeInfo).
-:- func unsafe_cast(T1::in) = (T2::out) is det.
-:- pragma foreign_proc("C",
- unsafe_cast(VarIn::in) = (VarOut::out),
- [will_not_call_mercury, thread_safe],
-"
- VarOut = VarIn;
-").
-:- pragma foreign_proc("C#",
- unsafe_cast(VarIn::in) = (VarOut::out),
- [will_not_call_mercury, thread_safe],
-"
- VarOut = VarIn;
-").
-
%-----------------------------------------------------------------------------%
io__write_list([], _Separator, _OutputPred) --> [].
@@ -3621,7 +3608,7 @@
}").
:- pragma foreign_proc("MC++",
- io__putback_byte(File::in, Character::in, IO0::di, IO::uo),
+ io__putback_byte(File::in, _Character::in, IO0::di, IO::uo),
may_call_mercury, "{
MR_MercuryFile mf = ML_DownCast(MR_MercuryFile,
Index: library/rtti_implementation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/rtti_implementation.m,v
retrieving revision 1.4
diff -u -r1.4 rtti_implementation.m
--- library/rtti_implementation.m 22 Aug 2001 12:29:01 -0000 1.4
+++ library/rtti_implementation.m 20 Sep 2001 10:23:29 -0000
@@ -28,6 +28,10 @@
:- interface.
+:- import_module list.
+
+:- use_module std_util.
+
% Our type_info and type_ctor_info implementations are both
% abstract types.
:- type type_info.
@@ -42,12 +46,26 @@
:- pred compare_type_infos(comparison_result::out,
type_info::in, type_info::in) is det.
+:- pred type_ctor_and_args(type_info::in,
+ type_ctor_info::out,
+ list(type_info)::out) is det.
+
+:- pred type_ctor_name_and_arity(type_ctor_info::in,
+ string::out, string::out, int::out) is det.
+
+:- pred deconstruct(T::in, string::out, int::out,
+ list(std_util__univ)::out) is det.
+
+ % This is useful in a few places, so we'd like to share the code, but
+ % it's better to put it into an implementation module such as this one.
+:- func unsafe_cast(T1::in) = (T2::out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module require, string.
+:- import_module require, string, int.
% std_util has a lot of types and functions with the same names,
% so we prefer to keep the namespace separate.
@@ -80,7 +98,7 @@
; array
; succip
; hp
- ; currfr
+ ; curfr
; maxfr
; redofr
; redoip
@@ -135,26 +153,32 @@
result_call_4(ComparePred, Res, X, Y)
; Arity = 1 ->
result_call_5(ComparePred, Res,
- TypeInfo ^ index(1), X, Y)
+ TypeInfo ^ type_info_index(1), X, Y)
; Arity = 2 ->
result_call_6(ComparePred, Res,
- TypeInfo ^ index(1), TypeInfo ^ index(2),
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
X, Y)
; Arity = 3 ->
result_call_7(ComparePred, Res,
- TypeInfo ^ index(1), TypeInfo ^ index(2),
- TypeInfo ^ index(3),
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
X, Y)
; Arity = 4 ->
result_call_8(ComparePred, Res,
- TypeInfo ^ index(1), TypeInfo ^ index(2),
- TypeInfo ^ index(3), TypeInfo ^ index(4),
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
+ TypeInfo ^ type_info_index(4),
X, Y)
; Arity = 5 ->
result_call_9(ComparePred, Res,
- TypeInfo ^ index(1), TypeInfo ^ index(2),
- TypeInfo ^ index(3), TypeInfo ^ index(4),
- TypeInfo ^ index(5),
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
+ TypeInfo ^ type_info_index(4),
+ TypeInfo ^ type_info_index(5),
X, Y)
;
error("compare/3: type arity > 5 not supported")
@@ -180,26 +204,33 @@
( Arity = 0 ->
semidet_call_3(UnifyPred, X, Y)
; Arity = 1 ->
- semidet_call_4(UnifyPred, TypeInfo ^ index(1), X, Y)
+ semidet_call_4(UnifyPred,
+ TypeInfo ^ type_info_index(1), X, Y)
; Arity = 2 ->
semidet_call_5(UnifyPred,
- TypeInfo ^ index(1), TypeInfo ^ index(2),
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
X, Y)
; Arity = 3 ->
semidet_call_6(UnifyPred,
- TypeInfo ^ index(1), TypeInfo ^ index(2),
- TypeInfo ^ index(3),
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
X, Y)
; Arity = 4 ->
semidet_call_7(UnifyPred,
- TypeInfo ^ index(1), TypeInfo ^ index(2),
- TypeInfo ^ index(3), TypeInfo ^ index(4),
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
+ TypeInfo ^ type_info_index(4),
X, Y)
; Arity = 5 ->
semidet_call_8(UnifyPred,
- TypeInfo ^ index(1), TypeInfo ^ index(2),
- TypeInfo ^ index(3), TypeInfo ^ index(4),
- TypeInfo ^ index(5),
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
+ TypeInfo ^ type_info_index(4),
+ TypeInfo ^ type_info_index(5),
X, Y)
;
error("unify/2: type arity > 5 not supported")
@@ -414,11 +445,7 @@
TypeCtorInfo2 ^ type_ctor_module_name),
(
Res = (=),
- TypeCtorInfo1 ^ type_ctor_module_name = "builtin",
- ( TypeCtorInfo1 ^ type_ctor_name = "tuple"
- ; TypeCtorInfo1 ^ type_ctor_name = "pred"
- ; TypeCtorInfo1 ^ type_ctor_name = "func"
- )
+ type_ctor_is_variable_arity(TypeCtorInfo1)
->
% XXX code to handle tuples and higher order
error("rtti_implementation.m: unimplemented: tuples and higher order type comparisons")
@@ -429,6 +456,12 @@
Res = NameRes
).
+:- pred type_ctor_is_variable_arity(type_ctor_info::in) is semidet.
+type_ctor_is_variable_arity(TypeCtorInfo) :-
+ ( TypeCtorInfo ^ type_ctor_rep = (pred)
+ ; TypeCtorInfo ^ type_ctor_rep = tuple
+ ).
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -455,6 +488,471 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
+
+type_ctor_name_and_arity(TypeCtorInfo, ModuleName, Name, Arity) :-
+ ModuleName = type_ctor_module_name(TypeCtorInfo),
+ Name = type_ctor_name(TypeCtorInfo),
+ Arity = type_ctor_arity(TypeCtorInfo).
+
+type_ctor_and_args(TypeInfo0, TypeCtorInfo, TypeArgs) :-
+ TypeInfo = collapse_equivalences(TypeInfo0),
+ TypeCtorInfo = get_type_ctor_info(TypeInfo),
+ (
+ type_ctor_is_variable_arity(TypeCtorInfo)
+ ->
+ error("rtti_implementation.m: unimplemented: tuples and higher order type comparisons")
+ ;
+ Arity = type_ctor_arity(TypeCtorInfo),
+ TypeArgs = iterate(1, Arity,
+ (func(X) = Y :-
+ Y = TypeInfo ^ type_info_index(X)
+ )
+ )
+ ).
+
+:- func iterate(int, int, func(int, T)) = list(T).
+iterate(Start, Max, Func) = Results :-
+ ( Start =< Max ->
+ Res = Func(Start),
+ Results = [Res | iterate(Start + 1, Max, Func)]
+ ;
+ Results = []
+ ).
+
+:- pred iterate_foldl(int, int, pred(int, T, T), T, T).
+:- mode iterate_foldl(in, in, pred(in, in, out) is det, in, out) is det.
+iterate_foldl(Start, Max, Pred) -->
+ ( { Start =< Max } ->
+ Pred(Start),
+ iterate_foldl(Start + 1, Max, Pred)
+ ;
+ []
+ ).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+
+ % Code to perform deconstructions (not yet complete).
+ %
+ % There are many cases to implement here, only the ones that were
+ % immediately useful (e.g. called by io__write) have been implemented
+ % so far.
+
+deconstruct(Term, Functor, Arity, Arguments) :-
+ TypeInfo = get_type_info(Term),
+ TypeCtorInfo = get_type_ctor_info(TypeInfo),
+ TypeCtorRep = type_ctor_rep(TypeCtorInfo),
+ (
+ TypeCtorRep = enum_usereq,
+ Functor = "some_enum_usereq",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = enum,
+ Functor = "some_enum",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = du_usereq,
+ Functor = "some_du_usereq",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = du,
+
+ LayoutInfo = type_layout(TypeCtorInfo),
+ PTag = get_primary_tag(Term),
+ PTagEntry = LayoutInfo ^ ptag_index(PTag),
+ SecTagLocn = PTagEntry ^ sectag_locn,
+ (
+ SecTagLocn = none,
+ FunctorDesc = PTagEntry ^ du_sectag_alternatives(0),
+ Functor = FunctorDesc ^ functor_name,
+ Arity = FunctorDesc ^ functor_arity,
+ Arguments = iterate(0, Arity - 1,
+ (func(X) = std_util__univ(
+ get_arg(Term, X, SecTagLocn,
+ FunctorDesc, TypeInfo))
+ ))
+ ;
+ SecTagLocn = local,
+ Functor = "some_du_local_sectag",
+ Arity = 0,
+ Arguments = []
+ ;
+ SecTagLocn = remote,
+ SecTag = get_remote_secondary_tag(Term),
+ FunctorDesc = PTagEntry ^
+ du_sectag_alternatives(SecTag),
+ Functor = FunctorDesc ^ functor_name,
+ Arity = FunctorDesc ^ functor_arity,
+ Arguments = iterate(0, Arity - 1,
+ (func(X) = std_util__univ(
+ get_arg(Term, X, SecTagLocn,
+ FunctorDesc, TypeInfo))
+ ))
+ ;
+ SecTagLocn = variable,
+ Functor = "some_du_variable_sectag",
+ Arity = 0,
+ Arguments = []
+ )
+ ;
+ TypeCtorRep = notag_usereq,
+ Functor = "some_notag_usereq",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = notag,
+ Functor = "some_notag",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = notag_ground_usereq,
+ Functor = "some_notag_ground_usereq",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = notag_ground,
+ Functor = "some_notag_ground",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = equiv_ground,
+ Functor = "some_equiv_ground",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = equiv_var,
+ Functor = "some_equiv_var",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = equiv,
+ Functor = "some_equiv",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = int,
+ Functor = "some_int",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = char,
+ Functor = "some_char",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = float,
+ Functor = "some_float",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = string,
+ Functor = "some_string",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = (pred),
+ Functor = "some_pred",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = tuple,
+ Functor = "some_tuple",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = univ,
+ Functor = "some_univ",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = void,
+ Functor = "some_void",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = c_pointer,
+ Functor = "some_c_pointer",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = typeinfo,
+ Functor = "some_typeinfo",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = typeclassinfo,
+ Functor = "some_typeclassinfo",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = array,
+ Functor = "some_array",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = succip,
+ Functor = "some_succip",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = hp,
+ Functor = "some_hp",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = curfr,
+ Functor = "some_curfr",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = maxfr,
+ Functor = "some_maxfr",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = redofr,
+ Functor = "some_redofr",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = redoip,
+ Functor = "some_redoip",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = trail_ptr,
+ Functor = "some_trail_ptr",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = ticket,
+ Functor = "some_ticket",
+ Arity = 0,
+ Arguments = []
+ ;
+ TypeCtorRep = unknown,
+ Functor = "some_unknown",
+ Arity = 0,
+ Arguments = []
+ ).
+
+
+
+ % Retrieve an argument number from a term, given the functor
+ % descriptor.
+
+:- some [T] func get_arg(
+ U, int, sectag_locn, du_functor_descriptor, type_info) = T.
+
+get_arg(Term, Index, SecTagLocn, FunctorDesc, TypeInfo) = (Arg) :-
+ ArgTypes = FunctorDesc ^ functor_arg_types,
+ PseudoTypeInfo = get_pti_from_arg_types(ArgTypes, Index),
+ ( SecTagLocn = none ->
+ TagOffset = 0
+ ;
+ TagOffset = 1
+ ),
+ ArgTypeInfo = get_type(TypeInfo, PseudoTypeInfo, Term, FunctorDesc),
+ Arg = get_subterm(ArgTypeInfo, Term, Index, TagOffset).
+
+:- func get_type(type_info, P, T, du_functor_descriptor) = type_info.
+
+get_type(TypeInfoParams, PseudoTypeInfo, Term, FunctorDesc) = (ArgTypeInfo) :-
+ (
+ typeinfo_is_variable(PseudoTypeInfo, VarNum)
+ ->
+ ExpandedTypeInfo = get_type_info_for_var(TypeInfoParams,
+ VarNum, Term, FunctorDesc),
+ ( typeinfo_is_variable(ExpandedTypeInfo, _) ->
+ error("unbound type variable")
+ ;
+ ArgTypeInfo = ExpandedTypeInfo
+ )
+ ;
+ CastTypeInfo = type_info_cast(PseudoTypeInfo),
+ TypeCtorInfo = get_type_ctor_info(CastTypeInfo),
+ (
+ type_ctor_is_variable_arity(TypeCtorInfo)
+ ->
+ Arity = pseudotypeinfo_get_higher_order_arity(
+ CastTypeInfo),
+ StartRegionSize = 2
+ ;
+ Arity = TypeCtorInfo ^ type_ctor_arity,
+ StartRegionSize = 1
+ ),
+ ArgTypeInfo0 = std_util__no,
+ UpperBound = Arity + StartRegionSize - 1,
+
+ iterate_foldl(StartRegionSize, UpperBound,
+ (pred(I::in, TI0::in, TI::out) is det :-
+
+ PTI = get_pti_from_type_info(CastTypeInfo, I),
+ ETypeInfo = get_type(
+ TypeInfoParams, PTI, Term, FunctorDesc),
+ % this comparison is not
+ % right...???
+ (
+ same_pointer_value_untyped(
+ ETypeInfo, PTI)
+ ->
+ TI = TI0
+ ;
+ TI0 = std_util__yes(TypeInfo)
+ ->
+ update_type_info_index(I,
+ TypeInfo, ETypeInfo),
+ TI = std_util__yes(TypeInfo)
+ ;
+ NewTypeInfo = new_type_info(
+ CastTypeInfo, UpperBound),
+ update_type_info_index(I,
+ NewTypeInfo, ETypeInfo),
+ TI = std_util__yes(NewTypeInfo)
+ )
+ ), ArgTypeInfo0, MaybeArgTypeInfo),
+ ( MaybeArgTypeInfo = std_util__yes(ArgTypeInfo1) ->
+ ArgTypeInfo = ArgTypeInfo1
+ ;
+ ArgTypeInfo = CastTypeInfo
+ )
+ ).
+
+
+ % XXX this is completely unimplemented.
+:- func pseudotypeinfo_get_higher_order_arity(type_info) = int.
+pseudotypeinfo_get_higher_order_arity(_) = 1 :-
+ det_unimplemented("pseudotypeinfo_get_higher_order_arity").
+
+
+ % Make a new type-info with the given arity, using the given type_info
+ % as the basis.
+
+:- func new_type_info(type_info, int) = type_info.
+new_type_info(TypeInfo::in, _::in) = (TypeInfo::out) :-
+ det_unimplemented("new_type_info").
+
+:- pragma foreign_proc("C#",
+ new_type_info(OldTypeInfo::in, Arity::in) = (NewTypeInfo::out), [], "
+ NewTypeInfo = new object[Arity + 1];
+ System.Array.Copy(OldTypeInfo, NewTypeInfo, OldTypeInfo.Length);
+").
+
+
+ % Get the pseudo-typeinfo at the given index from the argument types.
+
+:- some [T] func get_pti_from_arg_types(arg_types, int) = T.
+
+get_pti_from_arg_types(_::in, _::in) = (42::out) :-
+ det_unimplemented("get_pti_from_arg_types").
+
+:- pragma foreign_proc("C#",
+ get_pti_from_arg_types(ArgTypes::in, Index::in) =
+ (ArgTypeInfo::out), [], "
+ ArgTypeInfo = ArgTypes[Index];
+").
+
+
+ % Get the pseudo-typeinfo at the given index from a type-info.
+
+:- some [T] func get_pti_from_type_info(type_info, int) = T.
+
+get_pti_from_type_info(_::in, _::in) = (42::out) :-
+ det_unimplemented("get_pti_from_type_info").
+
+:- pragma foreign_proc("C#",
+ get_pti_from_type_info(TypeInfo::in, Index::in) = (PTI::out), [], "
+ PTI = TypeInfo[Index];
+").
+
+
+
+ % Get the type info for a particular type variable number
+ % (it might be in the type_info or in the term itself).
+ %
+ % XXX existentially quantified vars are not yet handled.
+
+:- func get_type_info_for_var(
+ type_info, int, T, du_functor_descriptor) = type_info.
+
+get_type_info_for_var(TypeInfo, VarNum, _Term, _FunctorDesc) = ArgTypeInfo :-
+ (
+ type_variable_is_univ_quant(VarNum)
+ ->
+ ArgTypeInfo = TypeInfo ^ type_info_index(VarNum)
+ ;
+ error("get_type_info_for_var for exist quant vars")
+ ).
+
+
+ % An unchecked cast to type_info (for pseudo-typeinfos).
+
+:- func type_info_cast(T) = type_info.
+
+type_info_cast(X::in) = (unsafe_cast(X)::out) :-
+ det_unimplemented("type_info_cast").
+
+:- pragma foreign_proc("C#",
+ type_info_cast(PseudoTypeInfo::in) = (TypeInfo::out), [], "
+
+ TypeInfo = (object[]) PseudoTypeInfo;
+").
+
+
+ % Get a subterm term, given its type_info, the original term, its
+ % index and the start region size.
+
+:- some [T] func get_subterm(type_info, U, int, int) = T.
+
+get_subterm(_::in, _::in, _::in, _::in) = (42::out) :-
+ det_unimplemented("get_subterm").
+
+:- pragma foreign_proc("C#",
+ get_subterm(TypeInfo::in, Term::in, Index::in,
+ TagOffset::in) = (Arg::out), [], "
+ Arg = ((object[]) Term)[Index + TagOffset];
+ TypeInfo_for_T = TypeInfo;
+").
+
+
+ % Test whether a type info is variable.
+
+:- pred typeinfo_is_variable(T::in, int::out) is semidet.
+
+typeinfo_is_variable(_::in, 42::out) :-
+ std_util__semidet_succeed,
+ det_unimplemented("typeinfo_is_variable").
+
+:- pragma foreign_proc("MC++",
+ typeinfo_is_variable(TypeInfo::in, VarNum::out), [], "
+ SUCCESS_INDICATOR = (dynamic_cast<MR_Word>(TypeInfo) == NULL);
+ if (SUCCESS_INDICATOR) {
+ VarNum = System::Convert::ToInt32(TypeInfo);
+ }
+").
+
+
+ % Tests for universal and existentially quantified variables.
+
+:- pred type_variable_is_univ_quant(int::in) is semidet.
+:- pred type_variable_is_exist_quant(int::in) is semidet.
+
+type_variable_is_exist_quant(X) :- X > pseudotypeinfo_exist_var_base.
+type_variable_is_univ_quant(X) :- X =< pseudotypeinfo_exist_var_base.
+
+:- func pseudotypeinfo_exist_var_base = int.
+:- func pseudotypeinfo_max_var = int.
+
+pseudotypeinfo_exist_var_base = 512.
+pseudotypeinfo_max_var = 1024.
+
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%
% XXX we have only implemented the .NET backend for the low-level data case.
@@ -466,16 +964,34 @@
// Fill this in as you add new field accessors.
enum type_ctor_info_field_nums {
- type_ctor_arity = 0,
- type_ctor_unify_pred = 1,
- type_ctor_compare_pred = 3,
- type_ctor_rep = 4,
- type_ctor_module_name = 7,
- type_ctor_name = 8,
- type_functors = 10,
- type_layout = 11,
- type_ctor_num_functors = 12,
- type_ctor_num_ptags = 13
+ type_ctor_arity = 0,
+ type_ctor_unify_pred = 1,
+ type_ctor_compare_pred = 3,
+ type_ctor_rep = 4,
+ type_ctor_module_name = 7,
+ type_ctor_name = 8,
+ type_functors = 10,
+ type_layout = 11,
+ type_ctor_num_functors = 12,
+ type_ctor_num_ptags = 13
+ }
+
+ enum ptag_layout_field_nums {
+ sectag_sharers = 0,
+ sectag_locn = 1,
+ sectag_alternatives = 2
+ }
+
+ enum du_functor_field_nums {
+ du_functor_name = 0,
+ du_functor_orig_arity = 1,
+ du_functor_arg_type_contains_var = 2,
+ du_functor_sectag_locn = 3,
+ du_functor_primary = 4,
+ du_functor_secondary = 5,
+ du_functor_ordinal = 6,
+ du_functor_arg_types = 7,
+ du_functor_exist_info = 8
}
").
@@ -499,30 +1015,156 @@
:- pred same_pointer_value(T::in, T::in) is semidet.
+:- pred same_pointer_value_untyped(T::in, U::in) is semidet.
+
+same_pointer_value(X, Y) :- same_pointer_value_untyped(X, Y).
:- pragma foreign_proc("MC++",
- same_pointer_value(T1::in, T2::in), [], "
+ same_pointer_value_untyped(T1::in, T2::in), [], "
SUCCESS_INDICATOR = (T1 == T2);
").
:- pragma foreign_proc("C",
- same_pointer_value(T1::in, T2::in), [], "
+ same_pointer_value_untyped(T1::in, T2::in), [], "
SUCCESS_INDICATOR = (T1 == T2);
").
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-:- func index(int, type_info) = type_info.
+
+:- func get_primary_tag(T) = int.
+:- func get_remote_secondary_tag(T) = int.
+
+get_primary_tag(_::in) = (0::out) :-
+ det_unimplemented("get_primary_tag").
+
+get_remote_secondary_tag(_::in) = (0::out) :-
+ det_unimplemented("get_remote_secondary_tag").
+
:- pragma foreign_proc("C#",
- index(X::in, TypeInfo::in) = (TypeInfoAtIndex::out), [], "
- TypeInfoAtIndex = (object[]) TypeInfo[X];
+ get_primary_tag(X::in) = (Tag::out), [], "
+ // We don't look at X to find the tag, for .NET low-level data
+ // there is no primary tag, so we always return zero.
+ Tag = 0;
").
+:- pragma foreign_proc("C#",
+ get_remote_secondary_tag(X::in) = (Tag::out), [], "
+ object[] data = (object[]) X;
+ Tag = (int) data[0];
+").
+
+
+
+:- type sectag_locn ---> none ; local ; remote ; variable.
+
+:- type du_sectag_alternatives ---> du_sectag_alternatives(c_pointer).
+
+:- type ptag_entry ---> ptag_entry(c_pointer).
+
+:- type du_functor_descriptor ---> du_functor_descriptor(c_pointer).
+
+:- type arg_types ---> arg_types(c_pointer).
+
+:- func ptag_index(int, type_layout) = ptag_entry.
+
% This is an "unimplemented" definition in Mercury, which will be
% used by default.
-index(_::in, TypeInfo::in) = (TypeInfo::out) :-
- det_unimplemented("index").
+ptag_index(_::in, TypeLayout::in) = (unsafe_cast(TypeLayout)::out) :-
+ det_unimplemented("ptag_index").
+
+:- pragma foreign_proc("C#",
+ ptag_index(X::in, TypeLayout::in) = (PtagEntry::out), [], "
+ PtagEntry = (object[]) TypeLayout[X];
+").
+
+:- func sectag_locn(ptag_entry) = sectag_locn.
+
+sectag_locn(PTagEntry::in) = (unsafe_cast(PTagEntry)::out) :-
+ det_unimplemented("sectag_locn").
+
+:- pragma foreign_proc("C#",
+ sectag_locn(PTagEntry::in) = (SectagLocn::out), [], "
+ SectagLocn = mercury.runtime.LowLevelData.make_enum((int)
+ PTagEntry[(int) ptag_layout_field_nums.sectag_locn]);
+").
+
+:- func du_sectag_alternatives(int, ptag_entry) = du_functor_descriptor.
+
+du_sectag_alternatives(_::in, PTagEntry::in) = (unsafe_cast(PTagEntry)::out) :-
+ det_unimplemented("sectag_alternatives").
+
+:- pragma foreign_proc("C#",
+ du_sectag_alternatives(X::in, PTagEntry::in) =
+ (FunctorDescriptor::out), [], "
+ object[] sectag_alternatives;
+ sectag_alternatives = (object [])
+ PTagEntry[(int) ptag_layout_field_nums.sectag_alternatives];
+ FunctorDescriptor = (object []) sectag_alternatives[X];
+").
+
+:- func functor_name(du_functor_descriptor) = string.
+
+functor_name(FunctorDescriptor::in) = (unsafe_cast(FunctorDescriptor)::out) :-
+ det_unimplemented("functor_name").
+
+:- pragma foreign_proc("C#",
+ functor_name(FunctorDescriptor::in) = (Name::out), [], "
+ Name = (string)
+ FunctorDescriptor[(int) du_functor_field_nums.du_functor_name];
+").
+
+:- func functor_arity(du_functor_descriptor) = int.
+
+functor_arity(FunctorDescriptor::in) = (unsafe_cast(FunctorDescriptor)::out) :-
+ det_unimplemented("functor_arity").
+
+:- pragma foreign_proc("C#",
+ functor_arity(FunctorDescriptor::in) = (Name::out), [], "
+ Name = (int)
+ FunctorDescriptor[(int)
+ du_functor_field_nums.du_functor_orig_arity];
+
+").
+
+:- func functor_arg_types(du_functor_descriptor) = arg_types.
+
+functor_arg_types(X::in) = (unsafe_cast(X)::out) :-
+ det_unimplemented("functor_arg_types").
+
+:- pragma foreign_proc("C#",
+ functor_arg_types(FunctorDescriptor::in) = (ArgTypes::out), [], "
+ ArgTypes = (object[])
+ FunctorDescriptor[(int)
+ du_functor_field_nums.du_functor_arg_types];
+
+").
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- func type_info_index(int, type_info) = type_info.
+
+ % This is an "unimplemented" definition in Mercury, which will be
+ % used by default.
+
+type_info_index(_::in, TypeInfo::in) = (TypeInfo::out) :-
+ det_unimplemented("type_info_index").
+
+:- pragma foreign_proc("C#",
+ type_info_index(X::in, TypeInfo::in) = (TypeInfoAtIndex::out), [], "
+ TypeInfoAtIndex = (object[]) TypeInfo[X];
+").
+
+update_type_info_index(_::in, _::in, _::in) :-
+ det_unimplemented("type_info_index").
+
+:- pred update_type_info_index(int::in, type_info::in, type_info::in) is det.
+:- pragma foreign_proc("C#",
+ update_type_info_index(X::in, OldTypeInfo::in, NewValue::in), [], "
+ OldTypeInfo[X] = NewValue;
+").
+
:- pred semidet_unimplemented(string::in) is semidet.
@@ -638,8 +1280,23 @@
:- pragma foreign_proc("C",
type_layout(TypeCtorInfo::in) = (TypeLayout::out), [], "
MR_TypeCtorInfo tci = (MR_TypeCtorInfo) TypeCtorInfo;
- TypeLayout = tci->type_layout;
+ TypeLayout = (MR_Word) &(tci->type_layout);
+").
+
+:- pragma foreign_proc("C",
+ unsafe_cast(VarIn::in) = (VarOut::out),
+ [will_not_call_mercury, thread_safe],
+"
+ VarOut = VarIn;
").
+:- pragma foreign_proc("C#",
+ unsafe_cast(VarIn::in) = (VarOut::out),
+ [will_not_call_mercury, thread_safe],
+"
+ VarOut = VarIn;
+").
+
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.240
diff -u -r1.240 std_util.m
--- library/std_util.m 24 Aug 2001 09:31:25 -0000 1.240
+++ library/std_util.m 20 Sep 2001 10:23:31 -0000
@@ -881,7 +881,7 @@
#ifdef MR_USE_TRAIL
/* XXX trailing not yet implemented for the MLDS back-end */
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for get_registers"");
#else
TrailPtr = 0
#endif
@@ -902,7 +902,7 @@
check_for_floundering(_TrailPtr::in), [will_not_call_mercury],
"
#ifdef MR_USE_TRAIL
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for check_for_floundering"");
#endif
").
@@ -921,7 +921,7 @@
discard_trail_ticket, [will_not_call_mercury],
"
#ifdef MR_USE_TRAIL
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for discard_trail_ticket"");
#endif
").
@@ -1414,16 +1414,18 @@
% We need to call the rtti_implementation module -- so that we get the
% dependencies right it's easiest to do it from Mercury.
-:- interface.
-:- use_module rtti_implementation.
+
+:- pragma export(call_rtti_compare_type_infos(out, in, in),
+ "ML_call_rtti_compare_type_infos").
+
:- pred call_rtti_compare_type_infos(comparison_result::out,
rtti_implementation__type_info::in, rtti_implementation__type_info::in) is det.
-:- implementation.
+
+:- use_module rtti_implementation.
call_rtti_compare_type_infos(Res, T1, T2) :-
rtti_implementation__compare_type_infos(Res, T1, T2).
-
:- pragma foreign_code("MC++", "
MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(std_util, type_desc, 0,
@@ -1432,7 +1434,7 @@
static int MR_compare_type_info(MR_Word t1, MR_Word t2) {
MR_Word res;
- mercury::std_util::mercury_code::call_rtti_compare_type_infos_3(
+ mercury::std_util::mercury_code::ML_call_rtti_compare_type_infos(
&res, t1, t2);
return System::Convert::ToInt32(res[0]);
}
@@ -1441,7 +1443,7 @@
__Compare____type_desc_0_0(
MR_Word_Ref result, MR_Word x, MR_Word y)
{
- mercury::std_util::mercury_code::call_rtti_compare_type_infos_3(
+ mercury::std_util::mercury_code::ML_call_rtti_compare_type_infos(
result, x, y);
}
@@ -1455,7 +1457,7 @@
special___Compare___type_desc_0_0(
MR_Word_Ref result, MR_Word x, MR_Word y)
{
- mercury::std_util::mercury_code::call_rtti_compare_type_infos_3(
+ mercury::std_util::mercury_code::ML_call_rtti_compare_type_infos(
result, x, y);
}
@@ -1892,12 +1894,13 @@
}
").
-:- pragma foreign_proc("MC++", type_ctor_and_args(_TypeDesc::in,
- _TypeCtorDesc::out, _ArgTypes::out), will_not_call_mercury, "
-{
- mercury::runtime::Errors::SORRY(""type_ctor_and_args"");
-}
-").
+
+type_ctor_and_args(TypeDesc::in, TypeCtorDesc::out, ArgTypes::out) :-
+ rtti_implementation__type_ctor_and_args(
+ rtti_implementation__unsafe_cast(TypeDesc),
+ TypeCtorDesc0, ArgTypes0),
+ TypeCtorDesc = rtti_implementation__unsafe_cast(TypeCtorDesc0),
+ ArgTypes = rtti_implementation__unsafe_cast(ArgTypes0).
/*
** This is the forwards mode of make_type/2:
@@ -2300,26 +2303,24 @@
make_type(_TypeCtorDesc::out, _ArgTypes::out) = (_TypeDesc::in),
will_not_call_mercury, "
{
- mercury.runtime.Errors.SORRY(""foreign code for this function"");
+ mercury.runtime.Errors.SORRY(""foreign code for make_type"");
// XXX this is required to keep the C# compiler quiet, but we should
// really fix the interface to semidet C#
succeeded = 1;
}
").
-:- pragma foreign_proc("MC++", type_ctor_name_and_arity(_TypeCtorDesc::in,
- _TypeCtorModuleName::out, _TypeCtorName::out,
- _TypeCtorArity::out),
- will_not_call_mercury, "
-{
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
-}
-").
+type_ctor_name_and_arity(TypeCtorDesc0::in, TypeCtorModuleName::out,
+ TypeCtorName::out, TypeCtorArity::out) :-
+ TypeCtorDesc = rtti_implementation__unsafe_cast(TypeCtorDesc0),
+ rtti_implementation__type_ctor_name_and_arity(TypeCtorDesc,
+ TypeCtorModuleName, TypeCtorName, TypeCtorArity).
+
:- pragma foreign_proc("MC++", num_functors(_TypeInfo::in) = (_Functors::out),
will_not_call_mercury, "
{
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for num_functors"");
}
").
@@ -2327,7 +2328,7 @@
_FunctorName::out, _Arity::out, _TypeInfoList::out),
will_not_call_mercury, "
{
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for get_functor"");
}
").
@@ -2335,7 +2336,7 @@
get_functor_ordinal(_TypeDesc::in, _FunctorNumber::in,
_Ordinal::out), will_not_call_mercury, "
{
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for get_functor_ordinal"");
}
").
@@ -2343,7 +2344,7 @@
construct(_TypeDesc::in, _FunctorNumber::in,
_ArgList::in) = (_Term::out), will_not_call_mercury, "
{
- mercury.runtime.Errors.SORRY(""foreign code for this function"");
+ mercury.runtime.Errors.SORRY(""foreign code for construct"");
_Term = null;
// XXX this is required to keep the C# compiler quiet, but we should
// really fix the interface to semidet C#
@@ -3310,7 +3311,7 @@
:- pragma foreign_proc("MC++", functor(_Term::in, _Functor::out, _Arity::out),
will_not_call_mercury, "
{
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for functor"");
}").
/*
@@ -3322,7 +3323,7 @@
arg(_Term::in, _ArgumentIndex::in) = (_Argument::out),
will_not_call_mercury, "
{
- mercury.runtime.Errors.SORRY(""foreign code for this function"");
+ mercury.runtime.Errors.SORRY(""foreign code for arg"");
// XXX this is required to keep the C# compiler quiet, but we should
// really fix the interface to semidet C#
succeeded = 1;
@@ -3332,7 +3333,7 @@
argument(_Term::in, _ArgumentIndex::in) = (_ArgumentUniv::out),
will_not_call_mercury, "
{
- mercury.runtime.Errors.SORRY(""foreign code for this function"");
+ mercury.runtime.Errors.SORRY(""foreign code for argument"");
// XXX this is required to keep the C# compiler quiet, but we should
// really fix the interface to semidet C#
succeeded = 1;
@@ -3407,20 +3408,16 @@
}
}").
-:- pragma foreign_proc("MC++",
- deconstruct(_Term::in, _Functor::out, _Arity::out,
- _Arguments::out),
- [will_not_call_mercury], "
-{
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
-}").
+deconstruct(Term::in, Functor::out, Arity::out, Arguments::out) :-
+ rtti_implementation__deconstruct(Term, Functor, Arity, Arguments).
:- pragma foreign_proc("MC++",
limited_deconstruct(_Term::in, _MaxArity::in, _Functor::out,
_Arity::out, _Arguments::out),
[will_not_call_mercury], "
{
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for limited_deconstruct"");
+ SUCCESS_INDICATOR = FALSE;
}").
get_functor_info(Univ, FunctorInfo) :-
@@ -3495,7 +3492,7 @@
get_notag_functor_info(_Univ::in, _ExpUniv::out),
will_not_call_mercury, "
{
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for get_notag_functor_info"");
}").
% Given a value of an arbitrary type, succeed if its type is defined
@@ -3541,7 +3538,7 @@
get_equiv_functor_info(_Univ::in, _ExpUniv::out),
will_not_call_mercury, "
{
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for get_equiv_functor_info"");
}").
% Given a value of an arbitrary type, succeed if it is an enum type,
@@ -3575,7 +3572,7 @@
get_enum_functor_info(_Univ::in, _Enum::out),
will_not_call_mercury, "
{
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for get_enum_functor_info"");
}").
% Given a value of an arbitrary type, succeed if it is a general du type
@@ -3677,7 +3674,7 @@
:- pragma foreign_proc("MC++", get_du_functor_info(_Univ::in, _Where::out,
_Ptag::out, _Sectag::out, _Args::out), will_not_call_mercury, "
{
- mercury::runtime::Errors::SORRY(""foreign code for this function"");
+ mercury::runtime::Errors::SORRY(""foreign code for get_du_functor_info"");
}").
%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list