%-----------------------------------------------------------------------------% % Copyright (C) 1995 University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% % file: polymorphism.m % main author: fjh % This module is a pass over the HLDS. % It does a syntactic transformation to implement polymorphism % using higher-order predicates, and also invokes `lambda__transform_lambda' % to handle lambda expressions by creating new predicates for them. % % Every polymorphic predicate is transformed % so that it takes one additional argument for every type variable in the % predicate's type declaration. The argument is a type_info structure, % which contains higher-order predicate variables for each of the builtin % polymorphic operations (currently unification, compare/3, index/2, % term_to_type/2 and type_to_term/2). % % The type_info structure is laid out as follows: % % word 0 % e.g. 0 for `int', 1 for `list(T)', 2 for `map(K, V)'. % word 1 <=/2 predicate for type> % word 2 % word 3 % word 4 % word 5 % word 6+ % % For example, we translate % % :- pred p(T1). % :- pred q(T2). % :- pred r(T3). % % p(X) :- q([X]), r(0). % % into % % :- pred p(type_info(T1), T1). % :- pred q(type_info(T2), T2). % :- pred r(type_info(T3), T3). % % p(X, TypeInfo) :- % q(type_info(1, list_unify, list_index, list_compare, % list_term_to_type, list_type_to_term, TypeInfo), [X]), % r(type_info(0, int_unify, int_index, int_compare, % int_term_to_type, int_type_to_term), 0). % % (except that both the input and output of the transformation are % actually in super-homogeneous form). %-----------------------------------------------------------------------------% :- module polymorphism. :- interface. :- import_module hlds_module. :- pred polymorphism__process_module(module_info, module_info). :- mode polymorphism__process_module(in, out) is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module hlds_pred, hlds_goal, hlds_data, llds, (lambda). :- import_module prog_data, type_util, mode_util, quantification. :- import_module code_util, unify_proc, special_pred, prog_util, make_hlds. :- import_module bool, int, string, list, set, map. :- import_module term, varset, std_util, require. %-----------------------------------------------------------------------------% % This whole section just traverses the module structure. % We do two passes, the first to fix up the procedure bodies, % (and in fact everything except the pred_info argtypes), % the second to fix up the pred_info argtypes. % The reason we need two passes is that the first pass looks at % the argtypes of the called predicates, and so we need to make % sure we don't muck them up before we've finished the first pass. polymorphism__process_module(ModuleInfo0, ModuleInfo) :- module_info_preds(ModuleInfo0, Preds0), map__keys(Preds0, PredIds0), polymorphism__process_preds(PredIds0, ModuleInfo0, ModuleInfo1), module_info_preds(ModuleInfo1, Preds1), map__keys(Preds1, PredIds1), polymorphism__fixup_preds(PredIds1, ModuleInfo1, ModuleInfo). :- pred polymorphism__process_preds(list(pred_id), module_info, module_info). :- mode polymorphism__process_preds(in, in, out) is det. polymorphism__process_preds([], ModuleInfo, ModuleInfo). polymorphism__process_preds([PredId | PredIds], ModuleInfo0, ModuleInfo) :- polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo1), polymorphism__process_preds(PredIds, ModuleInfo1, ModuleInfo). :- pred polymorphism__process_pred(pred_id, module_info, module_info). :- mode polymorphism__process_pred(in, in, out) is det. polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo) :- module_info_pred_info(ModuleInfo0, PredId, PredInfo), pred_info_procids(PredInfo, ProcIds), polymorphism__process_procs(PredId, ProcIds, ModuleInfo0, ModuleInfo). :- pred polymorphism__process_procs(pred_id, list(proc_id), module_info, module_info). :- mode polymorphism__process_procs(in, in, in, out) is det. polymorphism__process_procs(_PredId, [], ModuleInfo, ModuleInfo). polymorphism__process_procs(PredId, [ProcId | ProcIds], ModuleInfo0, ModuleInfo) :- module_info_preds(ModuleInfo0, PredTable0), map__lookup(PredTable0, PredId, PredInfo0), pred_info_procedures(PredInfo0, ProcTable0), map__lookup(ProcTable0, ProcId, ProcInfo0), polymorphism__process_proc(ProcInfo0, PredInfo0, ModuleInfo0, ProcInfo, PredInfo1, ModuleInfo1), pred_info_procedures(PredInfo1, ProcTable1), map__set(ProcTable1, ProcId, ProcInfo, ProcTable), pred_info_set_procedures(PredInfo1, ProcTable, PredInfo), module_info_preds(ModuleInfo1, PredTable1), map__set(PredTable1, PredId, PredInfo, PredTable), module_info_set_preds(ModuleInfo1, PredTable, ModuleInfo2), polymorphism__process_procs(PredId, ProcIds, ModuleInfo2, ModuleInfo). %---------------------------------------------------------------------------% :- pred polymorphism__fixup_preds(list(pred_id), module_info, module_info). :- mode polymorphism__fixup_preds(in, in, out) is det. polymorphism__fixup_preds([], ModuleInfo, ModuleInfo). polymorphism__fixup_preds([PredId | PredIds], ModuleInfo0, ModuleInfo) :- % % Recompute the arg types by finding the headvars and the var->type % mapping (from the first procedure for the predicate) and % applying the type mapping to the extra headvars to get the new % arg types. Note that we are careful to only apply the mapping % to the extra head vars, not to the originals, because otherwise % we would stuff up the arg types for unification predicates for % equivalence types. % module_info_preds(ModuleInfo0, PredTable0), map__lookup(PredTable0, PredId, PredInfo0), pred_info_procedures(PredInfo0, ProcTable0), pred_info_procids(PredInfo0, ProcIds), ( ProcIds = [ProcId|_] -> map__lookup(ProcTable0, ProcId, ProcInfo), proc_info_vartypes(ProcInfo, VarTypes), proc_info_headvars(ProcInfo, HeadVars), pred_info_arg_types(PredInfo0, TypeVarSet, ArgTypes0), list__length(ArgTypes0, NumOldArgs), list__length(HeadVars, NumNewArgs), NumExtraArgs is NumNewArgs - NumOldArgs, ( list__split_list(NumExtraArgs, HeadVars, ExtraHeadVars, _OldHeadVars) -> map__apply_to_list(ExtraHeadVars, VarTypes, ExtraArgTypes), list__append(ExtraArgTypes, ArgTypes0, ArgTypes) ; error("polymorphism.m: list__split_list failed") ), pred_info_set_arg_types(PredInfo0, TypeVarSet, ArgTypes, PredInfo), map__set(PredTable0, PredId, PredInfo, PredTable), module_info_set_preds(ModuleInfo0, PredTable, ModuleInfo1), polymorphism__fixup_preds(PredIds, ModuleInfo1, ModuleInfo) ; ModuleInfo = ModuleInfo0 ). %---------------------------------------------------------------------------% :- type poly_info ---> poly_info( varset, % from the proc_info map(var, type), % from the proc_info tvarset, % from the proc_info map(tvar, var), % specifies the type_info var % for each of the pred's type % parameters module_info ). :- pred polymorphism__process_proc(proc_info, pred_info, module_info, proc_info, pred_info, module_info). :- mode polymorphism__process_proc(in, in, in, out, out, out) is det. polymorphism__process_proc(ProcInfo0, PredInfo0, ModuleInfo0, ProcInfo, PredInfo, ModuleInfo) :- % grab the appropriate fields from the pred_info and proc_info pred_info_arg_types(PredInfo0, ArgTypeVarSet, ArgTypes), pred_info_typevarset(PredInfo0, TypeVarSet0), proc_info_headvars(ProcInfo0, HeadVars0), proc_info_variables(ProcInfo0, VarSet0), proc_info_vartypes(ProcInfo0, VarTypes0), proc_info_goal(ProcInfo0, Goal0), proc_info_argmodes(ProcInfo0, ArgModes0), % insert extra head variables to hold the address of the % equality predicate for each polymorphic type in the predicate's % type declaration term__vars_list(ArgTypes, HeadTypeVars0), list__remove_dups(HeadTypeVars0, HeadTypeVars), % remove duplicates polymorphism__make_head_vars(HeadTypeVars, ArgTypeVarSet, VarSet0, VarTypes0, ExtraHeadVars, VarSet1, VarTypes1), list__append(ExtraHeadVars, HeadVars0, HeadVars), list__length(ExtraHeadVars, NumExtraVars), list__duplicate(NumExtraVars, user_defined_mode(unqualified("in"), []), ExtraModes), list__append(ExtraModes, ArgModes0, ArgModes), % process any polymorphic calls inside the goal map__from_corresponding_lists(HeadTypeVars, ExtraHeadVars, TypeInfoMap), Info0 = poly_info(VarSet1, VarTypes1, TypeVarSet0, TypeInfoMap, ModuleInfo0), polymorphism__process_goal(Goal0, Goal1, Info0, Info1), polymorphism__fixup_quantification(Goal1, Goal, Info1, Info), Info = poly_info(VarSet, VarTypes, TypeVarSet, _, ModuleInfo), % set the new values of the fields in proc_info and pred_info proc_info_set_headvars(ProcInfo0, HeadVars, ProcInfo1), proc_info_set_goal(ProcInfo1, Goal, ProcInfo2), proc_info_set_varset(ProcInfo2, VarSet, ProcInfo3), proc_info_set_vartypes(ProcInfo3, VarTypes, ProcInfo4), proc_info_set_argmodes(ProcInfo4, ArgModes, ProcInfo), pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo). :- pred polymorphism__process_goal(hlds__goal, hlds__goal, poly_info, poly_info). :- mode polymorphism__process_goal(in, out, in, out) is det. polymorphism__process_goal(Goal0 - GoalInfo0, Goal) --> polymorphism__process_goal_2(Goal0, GoalInfo0, Goal). :- pred polymorphism__process_goal_2(hlds__goal_expr, hlds__goal_info, hlds__goal, poly_info, poly_info). :- mode polymorphism__process_goal_2(in, in, out, in, out) is det. % We don't need to add type-infos for higher-order calls, % since the type-infos are added when the closures are % constructed, not when they are called. (Or at least I % think we don't... -fjh.) polymorphism__process_goal_2( higher_order_call(A, B, C, D, E, F), GoalInfo, higher_order_call(A, B, C, D, E, F) - GoalInfo) --> []. polymorphism__process_goal_2( call(PredId0, ProcId0, ArgVars0, Builtin, Context, Name0, Follow), GoalInfo, Goal) --> % Check for a call to a special predicate like compare/3 % for which the type is known at compile-time. % Replace such calls with calls to the particular version % for that type. ( { Name0 = unqualified(PredName0) }, { list__length(ArgVars0, Arity) }, { special_pred_name_arity(SpecialPredId, PredName0, MangledPredName, Arity) }, =(poly_info(_, VarTypes, _, _TypeInfoMap, ModuleInfo)), { special_pred_get_type(MangledPredName, ArgVars0, MainVar) }, { map__lookup(VarTypes, MainVar, Type) }, { Type \= term__variable(_) }, % don't try this for type_to_term or term_to_type % if they're not implemented { special_pred_list(SpecialPredIds) }, { list__member(SpecialPredId, SpecialPredIds) } -> { classify_type(Type, ModuleInfo, TypeCategory) }, { polymorphism__get_special_proc(TypeCategory, SpecialPredId, ModuleInfo, SpecificPredName, PredId, ProcId) }, { Name = unqualified(SpecificPredName) } ; { PredId = PredId0 }, { ProcId = ProcId0 }, { Name = Name0 } ), polymorphism__process_call(PredId, ProcId, ArgVars0, ArgVars, ExtraVars, ExtraGoals), { goal_info_get_nonlocals(GoalInfo, NonLocals0) }, { set__insert_list(NonLocals0, ExtraVars, NonLocals) }, { goal_info_set_nonlocals(GoalInfo, NonLocals, CallGoalInfo) }, { Call = call(PredId, ProcId, ArgVars, Builtin, Context, Name, Follow) - CallGoalInfo }, { list__append(ExtraGoals, [Call], GoalList) }, { conj_list_to_goal(GoalList, GoalInfo, Goal) }. polymorphism__process_goal_2(unify(XVar, Y, Mode, Unification, Context), GoalInfo, Goal) --> ( { Unification = complicated_unify(UniMode, CanFail, Follow) }, { Y = var(YVar) } -> =(poly_info(_, VarTypes, _, TypeInfoMap, ModuleInfo)), { map__lookup(VarTypes, XVar, Type) }, ( { Type = term__variable(TypeVar) } -> % Convert polymorphic unifications into calls to % `unify/2', the general unification predicate, passing % the appropriate Type_info % =(TypeInfoVar, X, Y) % where TypeInfoVar is the type_info variable % associated with the type of the variables that % are being unified. { module_info_get_predicate_table(ModuleInfo, PredicateTable) }, { predicate_table_search_pred_m_n_a(PredicateTable, "mercury_builtin", "unify", 2, [CallPredId]) -> PredId = CallPredId ; error("polymorphism.m: can't find `mercury_builtin:unify/2'") }, % XXX Bug! - we should check that the mode is (in, in), % and report an error (e.g. "unification of % polymorphicly typed variables in partially % instantiated mode") if it isn't { ProcId = 0 }, { map__lookup(TypeInfoMap, TypeVar, TypeInfoVar) }, { SymName = unqualified("unify") }, { ArgVars = [TypeInfoVar, XVar, YVar] }, { code_util__is_builtin(ModuleInfo, PredId, ProcId, IsBuiltin) }, { CallContext = call_unify_context(XVar, Y, Context) }, { Goal = call(PredId, ProcId, ArgVars, IsBuiltin, yes(CallContext), SymName, Follow) - GoalInfo } ; { type_is_higher_order(Type, _, _) } -> { SymName = unqualified("builtin_unify_pred") }, { ArgVars = [XVar, YVar] }, { module_info_get_predicate_table(ModuleInfo, PredicateTable) }, { predicate_table_search_pred_m_n_a( PredicateTable, "mercury_builtin", "builtin_unify_pred", 2, [PredId0]) -> PredId = PredId0 ; error("can't locate mercury_builtin:builtin_unify_pred/2") }, { ProcId = 0 }, { hlds__is_builtin_make_builtin(no, no, IsBuiltin) }, { CallContext = call_unify_context(XVar, Y, Context) }, { Call = call(PredId, ProcId, ArgVars, IsBuiltin, yes(CallContext), SymName, Follow) }, polymorphism__process_goal_2(Call, GoalInfo, Goal) ; { type_to_type_id(Type, TypeId, _) } -> % Convert other complicated unifications into % calls to specific unification predicates, and then % recursively call polymorphism__process_goal_2 % to insert extra arguments if necessary. { module_info_get_special_pred_map(ModuleInfo, SpecialPredMap) }, { map__lookup(SpecialPredMap, unify - TypeId, PredId) }, { determinism_components(Det, CanFail, at_most_one) }, { unify_proc__lookup_mode_num(ModuleInfo, TypeId, UniMode, Det, ProcId) }, { SymName = unqualified("__Unify__") }, { ArgVars = [XVar, YVar] }, { hlds__is_builtin_make_builtin(no, no, IsBuiltin) }, { CallContext = call_unify_context(XVar, Y, Context) }, { Call = call(PredId, ProcId, ArgVars, IsBuiltin, yes(CallContext), SymName, Follow) }, polymorphism__process_goal_2(Call, GoalInfo, Goal) ; { error("polymorphism: type_to_type_id failed") } ) ; { Y = lambda_goal(PredOrFunc, Vars, Modes, Det, LambdaGoal0) } -> % for lambda expressions, we must recursively traverse the % lambda goal and then convert the lambda expression % into a new predicate { LambdaGoal0 = _ - GoalInfo0 }, { goal_info_get_nonlocals(GoalInfo0, OrigNonLocals) }, polymorphism__process_goal(LambdaGoal0, LambdaGoal1), polymorphism__fixup_quantification(LambdaGoal1, LambdaGoal), polymorphism__process_lambda(PredOrFunc, Vars, Modes, Det, OrigNonLocals, LambdaGoal, Unification, Y1, Unification1), { Goal = unify(XVar, Y1, Mode, Unification1, Context) - GoalInfo } ; % ordinary unifications are left unchanged, { Goal = unify(XVar, Y, Mode, Unification, Context) - GoalInfo } ). % the rest of the clauses just process goals recursively polymorphism__process_goal_2(conj(Goals0), GoalInfo, conj(Goals) - GoalInfo) --> polymorphism__process_goal_list(Goals0, Goals). polymorphism__process_goal_2(disj(Goals0, FV), GoalInfo, disj(Goals, FV) - GoalInfo) --> polymorphism__process_goal_list(Goals0, Goals). polymorphism__process_goal_2(not(Goal0), GoalInfo, not(Goal) - GoalInfo) --> polymorphism__process_goal(Goal0, Goal). polymorphism__process_goal_2(switch(Var, CanFail, Cases0, FV), GoalInfo, switch(Var, CanFail, Cases, FV) - GoalInfo) --> polymorphism__process_case_list(Cases0, Cases). polymorphism__process_goal_2(some(Vars, Goal0), GoalInfo, some(Vars, Goal) - GoalInfo) --> polymorphism__process_goal(Goal0, Goal). polymorphism__process_goal_2(if_then_else(Vars, A0, B0, C0, FV), GoalInfo, if_then_else(Vars, A, B, C, FV) - GoalInfo) --> polymorphism__process_goal(A0, A), polymorphism__process_goal(B0, B), polymorphism__process_goal(C0, C). polymorphism__process_goal_2(pragma_c_code(IsRecursive, C_Code, PredId, ProcId, ArgVars0, ArgNameMap0), GoalInfo, Goal) --> polymorphism__process_call(PredId, ProcId, ArgVars0, ArgVars, ExtraVars, ExtraGoals), % % update the non-locals % { goal_info_get_nonlocals(GoalInfo, NonLocals0) }, { set__insert_list(NonLocals0, ExtraVars, NonLocals) }, { goal_info_set_nonlocals(GoalInfo, NonLocals, CallGoalInfo) }, % % insert the type_info vars into the arg-name map, % so that the c_code can refer to the type_info variable % for type T as `TypeInfo_for_T'. % =(poly_info(_, _, _, _, ModuleInfo)), { module_info_pred_info(ModuleInfo, PredId, PredInfo) }, { pred_info_arg_types(PredInfo, PredTypeVarSet, PredArgTypes) }, { term__vars_list(PredArgTypes, PredTypeVars0) }, { list__remove_dups(PredTypeVars0, PredTypeVars) }, { polymorphism__c_code_add_typeinfos(ExtraVars, PredTypeVars, PredTypeVarSet, ArgNameMap0, ArgNameMap) }, % % plug it all back together % { Call = pragma_c_code(IsRecursive, C_Code, PredId, ProcId, ArgVars, ArgNameMap) - CallGoalInfo }, { list__append(ExtraGoals, [Call], GoalList) }, { conj_list_to_goal(GoalList, GoalInfo, Goal) }. :- pred polymorphism__c_code_add_typeinfos(list(var), list(tvar), tvarset, map(var, string), map(var, string)). :- mode polymorphism__c_code_add_typeinfos(in, in, in, in, out) is det. polymorphism__c_code_add_typeinfos([], [], _, ArgNameMap, ArgNameMap). polymorphism__c_code_add_typeinfos([Var|Vars], [TVar|TVars], TypeVarSet, ArgNameMap0, ArgNameMap) :- ( varset__search_name(TypeVarSet, TVar, TypeVarName) -> string__append("TypeInfo_for_", TypeVarName, C_VarName), map__set(ArgNameMap0, Var, C_VarName, ArgNameMap1) ; ArgNameMap1 = ArgNameMap0 ), polymorphism__c_code_add_typeinfos(Vars, TVars, TypeVarSet, ArgNameMap1, ArgNameMap). polymorphism__c_code_add_typeinfos([], [_|_], _, _, _) :- error("polymorphism__c_code_add_typeinfos: length mismatch"). polymorphism__c_code_add_typeinfos([_|_], [], _, _, _) :- error("polymorphism__c_code_add_typeinfos: length mismatch"). :- pred polymorphism__process_goal_list(list(hlds__goal), list(hlds__goal), poly_info, poly_info). :- mode polymorphism__process_goal_list(in, out, in, out) is det. polymorphism__process_goal_list([], []) --> []. polymorphism__process_goal_list([Goal0 | Goals0], [Goal | Goals]) --> polymorphism__process_goal(Goal0, Goal), polymorphism__process_goal_list(Goals0, Goals). :- pred polymorphism__process_case_list(list(case), list(case), poly_info, poly_info). :- mode polymorphism__process_case_list(in, out, in, out) is det. polymorphism__process_case_list([], []) --> []. polymorphism__process_case_list([Case0 | Cases0], [Case | Cases]) --> { Case0 = case(ConsId, Goal0) }, polymorphism__process_goal(Goal0, Goal), { Case = case(ConsId, Goal) }, polymorphism__process_case_list(Cases0, Cases). %-----------------------------------------------------------------------------% :- pred polymorphism__process_call(pred_id, proc_id, list(var), list(var), list(var), list(hlds__goal), poly_info, poly_info). :- mode polymorphism__process_call(in, in, in, out, out, out, in, out) is det. polymorphism__process_call(PredId, _ProcId, ArgVars0, ArgVars, ExtraVars, ExtraGoals, Info0, Info) :- Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet0, TypeInfoMap, ModuleInfo), module_info_pred_info(ModuleInfo, PredId, PredInfo), pred_info_arg_types(PredInfo, PredTypeVarSet, PredArgTypes0), % rename apart % (this merge might be a performance bottleneck?) varset__merge(TypeVarSet0, PredTypeVarSet, PredArgTypes0, TypeVarSet, PredArgTypes), term__vars_list(PredArgTypes, PredTypeVars0), ( PredTypeVars0 = [] -> % optimize for common case of non-polymorphic call ArgVars = ArgVars0, ExtraGoals = [], ExtraVars = [], Info = Info0 ; list__remove_dups(PredTypeVars0, PredTypeVars), map__apply_to_list(ArgVars0, VarTypes0, ActualArgTypes), map__keys(TypeInfoMap, HeadTypeVars), map__init(TypeSubst0), ( type_unify_list(ActualArgTypes, PredArgTypes, HeadTypeVars, TypeSubst0, TypeSubst1) -> TypeSubst = TypeSubst1 ; error("polymorphism__process_goal_2: type unification failed") ), term__var_list_to_term_list(PredTypeVars, PredTypes0), term__apply_rec_substitution_to_list(PredTypes0, TypeSubst, PredTypes), polymorphism__make_vars(PredTypes, ModuleInfo, TypeInfoMap, VarSet0, VarTypes0, ExtraVars, ExtraGoals, VarSet, VarTypes), list__append(ExtraVars, ArgVars0, ArgVars), Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap, ModuleInfo) ). :- pred polymorphism__fixup_quantification(hlds__goal, hlds__goal, poly_info, poly_info). :- mode polymorphism__fixup_quantification(in, out, in, out) is det. % % If the predicate we are processing is a polymorphic predicate, we % may need to fix up the quantification (non-local variables) % polymorphism__fixup_quantification(Goal0, Goal, Info0, Info) :- Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeVarMap, ModuleInfo), map__values(TypeVarMap, ExtraHeadVars), ( ExtraHeadVars = [] -> Goal = Goal0, VarTypes = VarTypes0, VarSet = VarSet0 ; Goal0 = _ - GoalInfo0, goal_info_get_nonlocals(GoalInfo0, NonLocals), set__list_to_set(ExtraHeadVars, NewOutsideVars), set__union(NewOutsideVars, NonLocals, OutsideVars), implicitly_quantify_goal(Goal0, VarSet0, VarTypes0, OutsideVars, Goal, VarSet, VarTypes, _Warnings) ), Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarMap, ModuleInfo). :- pred polymorphism__process_lambda(pred_or_func, list(var), list(mode), determinism, set(var), hlds__goal, unification, unify_rhs, unification, poly_info, poly_info). :- mode polymorphism__process_lambda(in, in, in, in, in, in, in, out, out, in, out) is det. polymorphism__process_lambda(PredOrFunc, Vars, Modes, Det, OrigNonLocals, LambdaGoal, Unification0, Functor, Unification, PolyInfo0, PolyInfo) :- PolyInfo0 = poly_info(VarSet, VarTypes, TVarSet, X, ModuleInfo0), lambda__transform_lambda(PredOrFunc, Vars, Modes, Det, OrigNonLocals, LambdaGoal, Unification0, VarSet, VarTypes, TVarSet, ModuleInfo0, Functor, Unification, ModuleInfo), PolyInfo = poly_info(VarSet, VarTypes, TVarSet, X, ModuleInfo). %---------------------------------------------------------------------------% % Given a list of types, create a list of variables to hold the type_info % for those types, and create a list of goals to initialize those type_info % variables to the appropriate type_info structures for the types. % Update the varset and vartypes accordingly. :- pred polymorphism__make_vars(list(type), module_info, map(tvar, var), varset, map(var, type), list(var), list(hlds__goal), varset, map(var, type)). :- mode polymorphism__make_vars(in, in, in, in, in, out, out, out, out) is det. polymorphism__make_vars([], _, _, VarSet, VarTypes, [], [], VarSet, VarTypes). polymorphism__make_vars([Type|Types], ModuleInfo, TypeInfoMap, VarSet0, VarTypes0, ExtraVars, ExtraGoals, VarSet, VarTypes) :- ( type_to_type_id(Type, _TypeId, TypeArgs) -> % This occurs for code where a predicate calls a polymorphic % predicate with a known value of the type variable. % For example, given % % :- pred p(T1). % :- pred q(T2). % :- pred r(T3). % p(X) :- q([X]), r(0). % % we know that in the call to q/1, T2 is bound to `list(T1)', % and in the call to r/1, T3 is bound to `int', and so % we translate it into % :- pred p(T1, pred(T1, T1)). % :- pred q(T2, pred(T2, T2)). % :- pred r(T3, pred(T3, T3)). % p(TypeInfo, X) :- % q( % type_info(1, % '__Unify__', % '__Index__', % '__Compare__', % '__Term_To_Type__', % '__Type_To_Term__', % TypeInfo % ), % [X] % ), % r( % type_info(0, % builtin_unify_int, % builtin_index_int, % builtin_compare_int, % builtin_term_to_type_int, % builtin_type_to_term_int % ), % 0 % ). % Create a unification `CountVar = ' varset__new_var(VarSet0, CountVar, VarSet1a), varset__name_var(VarSet1a, CountVar, "TypeArity", VarSet1), term__context_init(Context), IntType = term__functor(term__atom("int"), [], Context), map__set(VarTypes0, CountVar, IntType, VarTypes1), list__length(TypeArgs, NumTypeArgs), polymorphism__init_with_int_constant(CountVar, NumTypeArgs, CountGoal), % Create the unifications to initialize the special pred % variables for this type: % SpecialPred1 = __Unify__, % SpecialPred2 = __Index__, % SpecialPred3 = __Compare__, % SpecialPred4 = __Term_To_Type__, % SpecialPred5 = __Type_To_Term__. special_pred_list(SpecialPreds), polymorphism__get_special_proc_list(SpecialPreds, Type, ModuleInfo, VarSet1, VarTypes1, SpecialPredVars, SpecialPredGoals, VarSet2, VarTypes2), % Create the unifications to recursively initialize the % type_info for any argument types of a polymorphic type polymorphism__make_vars(TypeArgs, ModuleInfo, TypeInfoMap, VarSet2, VarTypes2, TypeInfoVars, TypeInfoGoals, VarSet3, VarTypes3), % Create a unification for the type_info variable for % this type: % TypeInfoVar = type_info(CountVar, % SpecialPredVars..., % TypeInfoVars...). list__append([CountVar | SpecialPredVars], TypeInfoVars, ArgVars), polymorphism__init_type_info_var(Type, ArgVars, VarSet3, VarTypes3, Var, TypeInfoGoal, VarSet4, VarTypes4), list__append([CountGoal | SpecialPredGoals], TypeInfoGoals, ExtraGoals0), list__append(ExtraGoals0, [TypeInfoGoal], ExtraGoals1) ; Type = term__variable(TypeVar1), map__search(TypeInfoMap, TypeVar1, TypeInfoVar) -> % This occurs for code where a predicate calls a polymorphic % predicate with a bound but unknown value of the type variable. % For example, in % % :- pred p(T1). % :- pred q(T2). % p(X) :- q(X). % % we know that `T2' is bound to `T1', and we translate it into % % :- pred p(T1, pred(T1, T1)). % :- pred q(T2, pred(T2, T2)). % p(TypeInfo, X) :- q(TypeInfo, X). Var = TypeInfoVar, ExtraGoals1 = [], VarSet4 = VarSet0, VarTypes4 = VarTypes0 ; % This occurs for code where a predicate calls a polymorphic % predicate with an unbound type variable, for example % % :- pred p. % :- pred q(list(T)). % p :- q([]). % % In this case T is unbound, so there cannot be any objects % of type T, and so q/1 cannot possibly use the unification % predicate for type T. We just pass a dummy value (0). % % :- pred p. % :- pred q(T, pred(T, T)). % p :- q(0, []). % % (This isn't really type-correct, but we're already past % the type-checker. Passing 0 should ensure that we get % a core dump if we ever attempt to call the unify pred.) % % XXX what about io__read_anything/3? % e.g. % foo --> io__read_anything(_). % ? % introduce a new variable, and % create a construction unification which initializes the % variable to zero polymorphism__new_type_info_var(Type, VarSet0, VarTypes0, Var, VarSet4, VarTypes4), polymorphism__init_with_int_constant(Var, 0, Goal), ExtraGoals1 = [Goal] ), ExtraVars = [Var | ExtraVars1], list__append(ExtraGoals1, ExtraGoals2, ExtraGoals), polymorphism__make_vars(Types, ModuleInfo, TypeInfoMap, VarSet4, VarTypes4, ExtraVars1, ExtraGoals2, VarSet, VarTypes). % Create a construction unification `Var = ' % where Var is a freshly introduced variable and Num is an % integer constant. :- pred polymorphism__init_with_int_constant(var, int, hlds__goal). :- mode polymorphism__init_with_int_constant(in, in, out) is det. polymorphism__init_with_int_constant(CountVar, Num, CountUnifyGoal) :- CountConsId = int_const(Num), CountUnification = construct(CountVar, CountConsId, [], []), CountTerm = functor(term__integer(Num), []), CountInst = bound(unique, [functor(int_const(Num), [])]), CountUnifyMode = (free -> CountInst) - (CountInst -> CountInst), CountUnifyContext = unify_context(explicit, []), % XXX the UnifyContext is wrong CountUnify = unify(CountVar, CountTerm, CountUnifyMode, CountUnification, CountUnifyContext), % create a goal_info for the unification goal_info_init(CountGoalInfo0), set__singleton_set(CountNonLocals, CountVar), goal_info_set_nonlocals(CountGoalInfo0, CountNonLocals, CountGoalInfo1), map__init(CountInstMapping0), map__set(CountInstMapping0, CountVar, CountInst, CountInstMapping), goal_info_set_instmap_delta(CountGoalInfo1, reachable(CountInstMapping), CountGoalInfo2), goal_info_set_determinism(CountGoalInfo2, det, CountGoalInfo), CountUnifyGoal = CountUnify - CountGoalInfo. :- pred polymorphism__get_special_proc_list(list(special_pred_id), type, module_info, varset, map(var, type), list(var), list(hlds__goal), varset, map(var, type)). :- mode polymorphism__get_special_proc_list(in, in, in, in, in, out, out, out, out) is det. polymorphism__get_special_proc_list([], _Type, _ModuleInfo, VarSet, VarTypes, [], [], VarSet, VarTypes). polymorphism__get_special_proc_list([Id | Ids], Type, ModuleInfo, VarSet0, VarTypes0, [Var | Vars], [Goal | Goals], VarSet, VarTypes) :- % introduce a fresh variable of the appropriate higher-order pred type special_pred_info(Id, Type, PredName, TypeArgs, _Modes, _Det), varset__new_var(VarSet0, Var, VarSet1a), string__append("Var__", PredName, VarName), varset__name_var(VarSet1a, Var, VarName, VarSet1), term__context_init(Context), PredType = term__functor(term__atom("pred"), TypeArgs, Context), map__set(VarTypes0, Var, PredType, VarTypes1), % get the ConsId for the address of the appropriate pred % for the operation specified by Id applied to Type. classify_type(Type, ModuleInfo, TypeCategory), polymorphism__get_special_proc(TypeCategory, Id, ModuleInfo, PredName2, PredId, ProcId), ConsId = address_const(PredId, ProcId), % create a construction unification which unifies the fresh % variable with the address constant obtained above Unification = construct(Var, ConsId, [], []), Term = functor(term__atom(PredName2), []), Inst = bound(unique, [functor(cons(PredName2, 0), [])]), UnifyMode = (free -> Inst) - (Inst -> Inst), UnifyContext = unify_context(explicit, []), % XXX the UnifyContext is wrong Unify = unify(Var, Term, UnifyMode, Unification, UnifyContext), % create a goal_info for the unification goal_info_init(GoalInfo0), set__singleton_set(NonLocals, Var), goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo1), map__init(InstMapping0), map__set(InstMapping0, Var, Inst, InstMapping), goal_info_set_instmap_delta(GoalInfo1, reachable(InstMapping), GoalInfo2), goal_info_set_determinism(GoalInfo2, det, GoalInfo), Goal = Unify - GoalInfo, polymorphism__get_special_proc_list(Ids, Type, ModuleInfo, VarSet1, VarTypes1, Vars, Goals, VarSet, VarTypes). :- pred polymorphism__get_special_proc(builtin_type, special_pred_id, module_info, string, pred_id, proc_id). :- mode polymorphism__get_special_proc(in, in, in, out, out, out) is det. polymorphism__get_special_proc(TypeCategory, SpecialPredId, ModuleInfo, PredName, PredId, ProcId) :- ( TypeCategory = user_type(Type) -> module_info_get_special_pred_map(ModuleInfo, SpecialPredMap), ( type_to_type_id(Type, TypeId, _TypeArgs) -> map__lookup(SpecialPredMap, SpecialPredId - TypeId, PredId) ; error( "polymorphism__get_special_proc: type_to_type_id failed") ), predicate_name(ModuleInfo, PredId, PredName) ; polymorphism__get_category_name(TypeCategory, CategoryName), special_pred_name_arity(SpecialPredId, SpecialName, _, Arity), string__append_list( ["builtin_", SpecialName, "_", CategoryName], PredName), polymorphism__get_builtin_pred_id(PredName, Arity, ModuleInfo, PredId) ), special_pred_mode_num(SpecialPredId, ProcId). :- pred polymorphism__get_category_name(builtin_type, string). :- mode polymorphism__get_category_name(in, out) is det. polymorphism__get_category_name(int_type, "int"). polymorphism__get_category_name(char_type, "int"). polymorphism__get_category_name(enum_type, "int"). polymorphism__get_category_name(float_type, "float"). polymorphism__get_category_name(str_type, "string"). polymorphism__get_category_name(pred_type, "pred"). polymorphism__get_category_name(polymorphic_type, _) :- error("polymorphism__get_category_name: polymorphic type"). polymorphism__get_category_name(user_type(_), _) :- error("polymorphism__get_category_name: user_type"). % find the builtin predicate with the specified name :- pred polymorphism__get_builtin_pred_id(string, int, module_info, pred_id). :- mode polymorphism__get_builtin_pred_id(in, in, in, out) is det. polymorphism__get_builtin_pred_id(Name, Arity, ModuleInfo, PredId) :- module_info_get_predicate_table(ModuleInfo, PredicateTable), ( predicate_table_search_pred_m_n_a(PredicateTable, "mercury_builtin", Name, Arity, [PredId1]) -> PredId = PredId1 ; error("polymorphism__get_pred_id: pred_id lookup failed") ). % Create a unification for the type_info variable for % this type: % TypeInfoVar = type_info(CountVar, % SpecialPredVars..., % TypeInfoVars...). :- pred polymorphism__init_type_info_var( type, list(var), varset, map(var, type), var, hlds__goal, varset, map(var, type)). :- mode polymorphism__init_type_info_var(in, in, in, in, out, out, out, out) is det. polymorphism__init_type_info_var(Type, ArgVars, VarSet0, VarTypes0, TypeInfoVar, TypeInfoGoal, VarSet, VarTypes) :- ConsId = cons("type_info", 1), TypeInfoTerm = functor(term__atom("type_info"), ArgVars), % introduce a new variable polymorphism__new_type_info_var(Type, VarSet0, VarTypes0, TypeInfoVar, VarSet, VarTypes), % create the construction unification to initialize it UniMode = (free - ground(shared, no) -> ground(shared, no) - ground(shared, no)), list__length(ArgVars, NumArgVars), list__duplicate(NumArgVars, UniMode, UniModes), Unification = construct(TypeInfoVar, ConsId, ArgVars, UniModes), UnifyMode = (free -> ground(shared, no)) - (ground(shared, no) -> ground(shared, no)), UnifyContext = unify_context(explicit, []), % XXX the UnifyContext is wrong Unify = unify(TypeInfoVar, TypeInfoTerm, UnifyMode, Unification, UnifyContext), % create a goal_info for the unification goal_info_init(GoalInfo0), set__list_to_set([TypeInfoVar | ArgVars], NonLocals), goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo1), map__init(InstMapping0), list__duplicate(NumArgVars, ground(shared, no), ArgInsts), % note that we could perhaps be more accurate than % `ground(shared)', but it shouldn't make any % difference. InstConsId = cons("type_info", NumArgVars), map__set(InstMapping0, TypeInfoVar, bound(unique, [functor(InstConsId, ArgInsts)]), InstMapping), goal_info_set_instmap_delta(GoalInfo1, reachable(InstMapping), GoalInfo2), goal_info_set_determinism(GoalInfo2, det, GoalInfo), TypeInfoGoal = Unify - GoalInfo. :- pred polymorphism__make_head_vars(list(tvar), tvarset, varset, map(var, type), list(var), varset, map(var, type)). :- mode polymorphism__make_head_vars(in, in, in, in, out, out, out) is det. polymorphism__make_head_vars([], _, VarSet, VarTypes, [], VarSet, VarTypes). polymorphism__make_head_vars([TypeVar|TypeVars], TypeVarSet, VarSet0, VarTypes0, TypeInfoVars, VarSet, VarTypes) :- Type = term__variable(TypeVar), polymorphism__new_type_info_var(Type, VarSet0, VarTypes0, Var, VarSet1, VarTypes1), ( varset__search_name(TypeVarSet, TypeVar, TypeVarName) -> string__append("TypeInfo_for_", TypeVarName, VarName), varset__name_var(VarSet1, Var, VarName, VarSet2) ; VarSet2 = VarSet1 ), TypeInfoVars = [Var | TypeInfoVars1], polymorphism__make_head_vars(TypeVars, TypeVarSet, VarSet2, VarTypes1, TypeInfoVars1, VarSet, VarTypes). :- pred polymorphism__new_type_info_var(type, varset, map(var, type), var, varset, map(var, type)). :- mode polymorphism__new_type_info_var(in, in, in, out, out, out) is det. polymorphism__new_type_info_var(Type, VarSet0, VarTypes0, Var, VarSet, VarTypes) :- % introduce new variable varset__new_var(VarSet0, Var, VarSet1), varset__name_var(VarSet1, Var, "TypeInfo", VarSet), term__context_init(Context), UnifyPredType = term__functor(term__atom("type_info"), [Type], Context), map__set(VarTypes0, Var, UnifyPredType, VarTypes). :- pred polymorphism__get_module_info(module_info, poly_info, poly_info). :- mode polymorphism__get_module_info(out, in, out) is det. polymorphism__get_module_info(ModuleInfo, PolyInfo, PolyInfo) :- PolyInfo = poly_info(_, _, _, _, ModuleInfo). :- pred polymorphism__set_module_info(module_info, poly_info, poly_info). :- mode polymorphism__set_module_info(in, in, out) is det. polymorphism__set_module_info(ModuleInfo, PolyInfo0, PolyInfo) :- PolyInfo0 = poly_info(A, B, C, D, _), PolyInfo = poly_info(A, B, C, D, ModuleInfo). %---------------------------------------------------------------------------% %---------------------------------------------------------------------------%