%-----------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et wm=0 tw=0 % This following module aborts with the following when compiled with % rotd-2009-06-14: % % Uncaught Mercury exception: % Software Error: llds_out.m: Unexpected: stack var out of range % Stack dump not available in this grade. % % Compile with: % % mmc -C --grade asm_fast.gc.profdeep \ % -O4 --intermodule-optimization \ % --profile-optimized erlang_rtti_implementation.m :- module erlang_rtti_implementation. :- interface. :- import_module maybe. :- import_module list. %-----------------------------------------------------------------------------% :- type type_info. :- type type_ctor_info. :- type type_ctor_info_evaled. :- func get_functor_with_names(type_info, int) = maybe({string, int, list(type_info), list(string)}). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module univ. :- import_module char. :- import_module int. :- import_module require. :- import_module string. :- type type_info ---> type_info. :- type type_ctor_info ---> type_ctor_info. :- type type_ctor_info_evaled ---> type_ctor_info_evaled. :- type erlang_type_ctor_rep ---> etcr_du ; etcr_dummy ; etcr_list ; etcr_eqv ; etcr_tuple. get_functor_with_names(TypeInfo, NumFunctor) = Result :- TypeCtorInfo = TypeInfo ^ type_ctor_info_evaled, TypeCtorRep = TypeCtorInfo ^ type_ctor_rep, ( TypeCtorRep = etcr_du, FunctorReps = type_ctor_functors(TypeCtorInfo), ( matching_du_functor_number(FunctorReps, NumFunctor, FunctorRep) -> ArgInfos = FunctorRep ^ edu_arg_infos, MapArgInfosToTypesNames = (pred(ArgInfo::in, ArgTypeInfo::out, ArgName::out) is det :- MaybePTI = ArgInfo ^ du_arg_type, Info = yes({TypeInfo, no : pti_info(int)}), ArgTypeInfo = concrete_type_info(Info, MaybePTI), MaybeArgName = ArgInfo ^ du_arg_name, ( MaybeArgName = yes(ArgName0), ArgName = string.from_char_list(ArgName0) ; MaybeArgName = no, ArgName = "" ) ), list.map2(MapArgInfosToTypesNames, ArgInfos, ArgTypes, ArgNames), Name = string.from_char_list(FunctorRep ^ edu_name), Arity = FunctorRep ^ edu_orig_arity, Result = yes({Name, Arity, ArgTypes, ArgNames}) ; Result = no ) ; TypeCtorRep = etcr_dummy, Name = type_ctor_dummy_functor_name(TypeCtorInfo), Arity = 0, ArgTypes = [], ArgNames = [], Result = yes({Name, Arity, ArgTypes, ArgNames}) ; TypeCtorRep = etcr_tuple, error("") ; TypeCtorRep = etcr_list, ( NumFunctor = 0 -> Name = "[]", Arity = 0, ArgTypes = [], ArgNames = [], Result = yes({Name, Arity, ArgTypes, ArgNames}) ; Result = no ) ; TypeCtorRep = etcr_eqv, error("") ). :- pred matching_du_functor_number(list(erlang_du_functor)::in, int::in, erlang_du_functor::out) is semidet. matching_du_functor_number([F | Fs], FunctorNum, Functor) :- ( F ^ edu_lex = FunctorNum -> Functor = F ; matching_du_functor_number(Fs, FunctorNum, Functor) ). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- func type_ctor_info_evaled(type_info) = type_ctor_info_evaled. type_ctor_info_evaled(_) = type_ctor_info_evaled :- det_unimplemented("type_ctor_info_evaled"). :- func type_info_index(int, type_info) = type_info. type_info_index(I, TI) = TI ^ unsafe_type_info_index(I + 1). :- func unsafe_type_info_index(int, type_info) = type_info. unsafe_type_info_index(_, _) = type_info :- det_unimplemented("unsafe_type_info_index"). :- func type_ctor_rep(type_ctor_info_evaled) = erlang_type_ctor_rep. type_ctor_rep(_) = _ :- private_builtin.sorry("type_ctor_rep"). :- func type_ctor_functors(type_ctor_info_evaled) = list(erlang_du_functor). type_ctor_functors(_) = [] :- det_unimplemented("type_ctor_functors"). :- func type_ctor_dummy_functor_name(type_ctor_info_evaled) = string. type_ctor_dummy_functor_name(_) = "dummy value" :- det_unimplemented("type_ctor_dummy_functor_name"). :- func unsafe_cast(T) = U. unsafe_cast(T) = U :- private_builtin.unsafe_type_cast(T, U). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- pred det_unimplemented(string::in) is det. det_unimplemented(S) :- ( semidet_succeed -> error("" ++ "unimplemented: " ++ S) ; true ). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- import_module maybe. :- type erlang_atom ---> erlang_atom. :- type erlang_du_functor ---> erlang_du_functor( edu_name :: list(char), edu_orig_arity :: int, edu_ordinal :: int, edu_lex :: int, edu_rep :: erlang_atom, edu_arg_infos :: list(du_arg_info), edu_exist_info :: maybe(exist_info) ). :- type du_arg_info ---> du_arg_info( du_arg_name :: maybe(list(char)), du_arg_type :: maybe_pseudo_type_info ). :- type exist_info ---> exist_info( exist_num_plain_typeinfos :: int, exist_typeinfo_locns :: list(exist_typeinfo_locn) ). :- type exist_typeinfo_locn ---> plain_typeinfo(int) ; typeinfo_in_tci(int, int). :- type maybe_pseudo_type_info ---> pseudo(pseudo_type_info_thunk) ; plain(type_info_thunk). %-----------------------------------------------------------------------------% :- type ti_info(T) == maybe({type_info, pti_info(T)}). :- type pti_info(T) == maybe({erlang_du_functor, T}). :- func concrete_type_info(ti_info(T), maybe_pseudo_type_info) = type_info. concrete_type_info(Info, MaybePTI) = TypeInfo :- ( MaybePTI = pseudo(PseudoThunk), ( Info = yes({ParentTypeInfo, MaybeFunctorAndTerm}), TypeInfo = eval_pseudo_type_info( ParentTypeInfo, MaybeFunctorAndTerm, PseudoThunk) ; Info = no, error("type_info/2: missing parent type_info") ) ; MaybePTI = plain(_), TypeInfo = type_info ). :- func eval_pseudo_type_info(type_info, pti_info(T), pseudo_type_info_thunk) = type_info. eval_pseudo_type_info(ParentTypeInfo, MaybeFunctorAndTerm, Thunk) = TypeInfo :- EvalResult = eval_pseudo_type_info_thunk(Thunk), ( EvalResult = universal_type_info(N), TypeInfo = ParentTypeInfo ^ type_info_index(N) ; EvalResult = existential_type_info(N), ( MaybeFunctorAndTerm = yes(_), TypeInfo = type_info ; MaybeFunctorAndTerm = no, TypeInfo = unsafe_cast(N) ) ; EvalResult = pseudo_type_info(PseudoTypeInfo), Info = yes({ParentTypeInfo, MaybeFunctorAndTerm}), TypeInfo = eval_type_info(Info, unsafe_cast(PseudoTypeInfo)) ). :- func eval_type_info(ti_info(T), type_info) = type_info. eval_type_info(_I, TI) = TypeInfo :- TypeCtorInfo = TI ^ type_ctor_info_evaled, ArgTypeInfos = [], TypeInfo = create_type_info(TypeCtorInfo, ArgTypeInfos). :- func create_type_info(type_ctor_info_evaled, list(type_info)) = type_info. create_type_info(_, _) = type_info :- det_unimplemented("create_type_info/2"). :- type pseudo_type_info ---> pseudo_type_info. :- type pseudo_type_info_thunk ---> pseudo_type_info_thunk. :- type evaluated_pseudo_type_info_thunk ---> universal_type_info(int) ; existential_type_info(int) ; pseudo_type_info(pseudo_type_info). :- func eval_pseudo_type_info_thunk(pseudo_type_info_thunk) = evaluated_pseudo_type_info_thunk. eval_pseudo_type_info_thunk(X) = erlang_rtti_implementation.unsafe_cast(X) :- det_unimplemented("eval_pseudo_type_info/1"). :- type type_info_thunk ---> type_info_thunk. %-----------------------------------------------------------------------------%