diff --git a/compiler/code_info.m b/compiler/code_info.m index 5ec2f4e15..257088d69 100644 --- a/compiler/code_info.m +++ b/compiler/code_info.m @@ -1041,20 +1041,12 @@ code_info__cons_id_to_tag(_Var, float_const(X), float_constant(X)) --> []. code_info__cons_id_to_tag(_Var, string_const(X), string_constant(X)) --> []. code_info__cons_id_to_tag(Var, cons(Name, Arity), Tag) --> % - % Use the variable to determine the type + % Use the variable to determine the type_id % code_info__get_proc_info(ProcInfo), { proc_info_vartypes(ProcInfo, VarTypes) }, { map__lookup(VarTypes, Var, Type) }, - % - % Given the type, determine the type_id - % - { Type = term__functor(TypeName, TypeArgs, _Context) -> - list__length(TypeArgs, TypeArity), - make_type_id(TypeName, TypeArity, TypeId) - ; - error("unification with polymorphically typed variable?") - }, + { type_to_type_id(Type, TypeId, _) }, % % Given the type_id, lookup up the constructor tag % table for that type diff --git a/compiler/hlds.m b/compiler/hlds.m index 2d6cb33a9..8fef70fae 100644 --- a/compiler/hlds.m +++ b/compiler/hlds.m @@ -1242,7 +1242,8 @@ proc_info_set_body(ProcInfo0, VarSet, VarTypes, HeadVars, Goal, ProcInfo) :- ProcInfo0 = procedure(DeclaredDet, _, _, _, ArgModes, _, Context, CallInfo, InferredDet, ArgInfo, Liveness, Follow), ProcInfo = procedure(DeclaredDet, VarSet, VarTypes, HeadVars, ArgModes, - Goal, Context, CallInfo, InferredDet, ArgInfo, Liveness, Follow). + Goal, Context, CallInfo, InferredDet, ArgInfo, Liveness, + Follow). proc_info_set_inferred_determinism(ProcInfo0, Category, ProcInfo) :- ProcInfo0 = procedure(A, B, C, D, E, F, G, H, _, J, K, L), @@ -1264,10 +1265,10 @@ proc_info_set_follow_vars(ProcInfo0, L, ProcInfo) :- ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, _), ProcInfo = procedure(A, B, C, D, E, F, G, H, I, J, K, L). - proc_info_get_initial_instmap(ProcInfo, ModuleInfo, reachable(InstMapping)) :- proc_info_headvars(ProcInfo, HeadVars), proc_info_argmodes(ProcInfo, ArgModes), + % XXX propagate type info! mode_list_get_initial_insts(ArgModes, ModuleInfo, InitialInsts), map__from_corresponding_lists(HeadVars, InitialInsts, InstMapping). diff --git a/compiler/mercury_to_mercury.m b/compiler/mercury_to_mercury.m index 0774fd143..f8ea98397 100644 --- a/compiler/mercury_to_mercury.m +++ b/compiler/mercury_to_mercury.m @@ -263,6 +263,18 @@ mercury_output_inst_name(ground_inst(InstName), VarSet) --> io__write_string("$ground("), mercury_output_inst_name(InstName, VarSet), io__write_string(")"). +mercury_output_inst_name(typed_ground(Type), _VarSet) --> + io__write_string("$typed_ground("), + { varset__init(TypeVarSet) }, + mercury_output_term(Type, TypeVarSet), + io__write_string(")"). +mercury_output_inst_name(typed_inst(Type, InstName), VarSet) --> + io__write_string("$typed_inst("), + { varset__init(TypeVarSet) }, + mercury_output_term(Type, TypeVarSet), + io__write_string(", "), + mercury_output_inst_name(InstName, VarSet), + io__write_string(")"). :- pred mercury_output_bound_insts(list(bound_inst), varset, io__state, io__state). diff --git a/compiler/mode_info.m b/compiler/mode_info.m index 58121d264..51c3fdffc 100644 --- a/compiler/mode_info.m +++ b/compiler/mode_info.m @@ -141,6 +141,9 @@ :- pred mode_info_get_var_types(mode_info, map(var,type)). :- mode mode_info_get_var_types(mode_info_ui, out) is det. +:- pred mode_info_get_types_of_vars(mode_info, list(var), list(type)). +:- mode mode_info_get_types_of_vars(mode_info_ui, in, out) is det. + :- pred mode_info_lock_vars(set(var), mode_info, mode_info). :- mode mode_info_lock_vars(in, mode_info_di, mode_info_uo) is det. @@ -453,6 +456,10 @@ mode_info_get_var_types(ModeInfo, VarTypes) :- map__lookup(Procs, ProcId, ProcInfo), proc_info_vartypes(ProcInfo, VarTypes). +mode_info_get_types_of_vars(ModeInfo, Vars, TypesOfVars) :- + mode_info_get_var_types(ModeInfo, VarTypes), + map__apply_to_list(Vars, VarTypes, TypesOfVars). + %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% diff --git a/compiler/mode_util.m b/compiler/mode_util.m index 79291b890..d8908fa98 100644 --- a/compiler/mode_util.m +++ b/compiler/mode_util.m @@ -86,11 +86,26 @@ :- pred instmapping_lookup_var(instmapping, var, inst). :- mode instmapping_lookup_var(in, in, out) is det. + % Given corresponding lists of types and modes, produce a new + % list of modes which includes the information provided by the + % corresponding types. + +:- pred propagate_type_info_mode_list(list(type), module_info, list(mode), + list(mode)). +:- mode propagate_type_info_mode_list(in, in, in, out) is det. + + % Given a type and an inst, produce a new inst which includes + % the information provided by the type. + +:- pred propagate_type_info_inst(type, module_info, inst, inst). +:- mode propagate_type_info_inst(in, in, in, out) is det. + %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module require, map, set, term, std_util. +:- import_module prog_util, type_util. mode_list_get_final_insts([], _ModuleInfo, []). mode_list_get_final_insts([Mode | Modes], ModuleInfo, [Inst | Insts]) :- @@ -248,14 +263,16 @@ inst_list_is_free([Inst | Insts], ModuleInfo) :- inst_is_free(ModuleInfo, Inst), inst_list_is_free(Insts, ModuleInfo). -inst_lookup(ModuleInfo, InstName, Inst) :- - module_info_insts(ModuleInfo, InstTable), - inst_lookup_2(InstName, InstTable, Inst). +%-----------------------------------------------------------------------------% -:- pred inst_lookup_2(inst_name, inst_table, inst). +inst_lookup(ModuleInfo, InstName, Inst) :- + inst_lookup_2(InstName, ModuleInfo, Inst). + +:- pred inst_lookup_2(inst_name, module_info, inst). :- mode inst_lookup_2(in, in, out) is det. -inst_lookup_2(unify_inst(Live, A, B), InstTable, Inst) :- +inst_lookup_2(unify_inst(Live, A, B), ModuleInfo, Inst) :- + module_info_insts(ModuleInfo, InstTable), inst_table_get_unify_insts(InstTable, UnifyInstTable), map__lookup(UnifyInstTable, unify_inst_pair(Live, A, B), MaybeInst), ( MaybeInst = known(Inst0) -> @@ -263,7 +280,8 @@ inst_lookup_2(unify_inst(Live, A, B), InstTable, Inst) :- ; Inst = defined_inst(unify_inst(Live, A, B)) ). -inst_lookup_2(merge_inst(A, B), InstTable, Inst) :- +inst_lookup_2(merge_inst(A, B), ModuleInfo, Inst) :- + module_info_insts(ModuleInfo, InstTable), inst_table_get_merge_insts(InstTable, MergeInstTable), map__lookup(MergeInstTable, A - B, MaybeInst), ( MaybeInst = known(Inst0) -> @@ -271,7 +289,8 @@ inst_lookup_2(merge_inst(A, B), InstTable, Inst) :- ; Inst = defined_inst(merge_inst(A, B)) ). -inst_lookup_2(ground_inst(A), InstTable, Inst) :- +inst_lookup_2(ground_inst(A), ModuleInfo, Inst) :- + module_info_insts(ModuleInfo, InstTable), inst_table_get_ground_insts(InstTable, GroundInstTable), map__lookup(GroundInstTable, A, MaybeInst), ( MaybeInst = known(Inst0) -> @@ -279,7 +298,8 @@ inst_lookup_2(ground_inst(A), InstTable, Inst) :- ; Inst = defined_inst(ground_inst(A)) ). -inst_lookup_2(user_inst(Name, Args), InstTable, Inst) :- +inst_lookup_2(user_inst(Name, Args), ModuleInfo, Inst) :- + module_info_insts(ModuleInfo, InstTable), inst_table_get_user_insts(InstTable, UserInstTable), list__length(Args, Arity), ( map__search(UserInstTable, Name - Arity, InstDefn) -> @@ -288,6 +308,211 @@ inst_lookup_2(user_inst(Name, Args), InstTable, Inst) :- ; Inst = abstract_inst(Name, Args) ). +inst_lookup_2(typed_ground(Type), ModuleInfo, Inst) :- + propagate_type_info_inst(Type, ModuleInfo, ground, Inst). +inst_lookup_2(typed_inst(Type, InstName), ModuleInfo, Inst) :- + inst_lookup_2(InstName, ModuleInfo, Inst0), + propagate_type_info_inst(Type, ModuleInfo, Inst0, Inst). + +%-----------------------------------------------------------------------------% + + % Given corresponding lists of types and modes, produce a new + % list of modes which includes the information provided by the + % corresponding types. + +propagate_type_info_mode_list([], _, [], []). +propagate_type_info_mode_list([Type | Types], ModuleInfo, [Mode0 | Modes0], + [Mode | Modes]) :- + propagate_type_info_mode(Type, ModuleInfo, Mode0, Mode), + propagate_type_info_mode_list(Types, ModuleInfo, Modes0, Modes). + + % Given a type and a mode, produce a new mode which includes + % the information provided by the type. + +:- pred propagate_type_info_mode(type, module_info, mode, mode). +:- mode propagate_type_info_mode(in, in, in, out) is det. + +propagate_type_info_mode(Type, ModuleInfo, Mode0, Mode) :- + mode_get_insts(ModuleInfo, Mode0, InitialInst0, FinalInst0), + ex_propagate_type_info_inst(Type, ModuleInfo, InitialInst0, + InitialInst), + ex_propagate_type_info_inst(Type, ModuleInfo, FinalInst0, FinalInst), + Mode = (InitialInst -> FinalInst). + + % Given a type and an inst, produce a new inst which includes + % the information provided by the type. + +propagate_type_info_inst(Type, ModuleInfo, Inst0, Inst) :- + ( Type = term__variable(_) -> + % A type variable doesn't provide any extra information + Inst = Inst0 + ; + module_info_types(ModuleInfo, TypeTable), + type_to_type_id(Type, TypeId, TypeArgs), + ( + map__search(TypeTable, TypeId, TypeDefn), + TypeDefn = hlds__type_defn(_, TypeParams, TypeBody, + _, _), + TypeBody = du_type(Constructors0, _, _) + -> + substitute_type_args(TypeParams, TypeArgs, + Constructors0, Constructors), + propagate_ctor_info(Inst0, Type, Constructors, + ModuleInfo, Inst) + ; + Inst = Inst0 + ) + ). + + % Given a type and an inst, produce a new inst which includes + % the information provided by the type. + +:- pred ex_propagate_type_info_inst(type, module_info, inst, inst). +:- mode ex_propagate_type_info_inst(in, in, in, out) is det. + +ex_propagate_type_info_inst(Type, ModuleInfo, Inst0, Inst) :- + ( Type = term__variable(_) -> + % A type variable doesn't provide any extra information + Inst = Inst0 + ; + module_info_types(ModuleInfo, TypeTable), + type_to_type_id(Type, TypeId, TypeArgs), + ( + map__search(TypeTable, TypeId, TypeDefn), + TypeDefn = hlds__type_defn(_, TypeParams, TypeBody, + _, _), + TypeBody = du_type(Constructors0, _, _) + -> + substitute_type_args(TypeParams, TypeArgs, + Constructors0, Constructors), + ex_propagate_ctor_info(Inst0, Type, Constructors, + ModuleInfo, Inst) + ; + Inst = Inst0 + ) + ). + +%-----------------------------------------------------------------------------% + + % Substitute the actual values of the type parameters + % in list of constructors, for a particular instance of + % a polymorphic type. + +:- pred substitute_type_args(list(type_param), list(type), + list(constructor), list(constructor)). +:- mode substitute_type_args(in, in, in, out) is det. + +substitute_type_args(TypeParams0, TypeArgs, Constructors0, Constructors) :- + ( TypeParams0 = [] -> + Constructors = Constructors0 + ; + term__term_list_to_var_list(TypeParams0, TypeParams), + substitute_type_args_2(Constructors0, TypeParams, TypeArgs, + Constructors) + ). + +:- pred substitute_type_args_2(list(constructor), list(var), list(type), + list(constructor)). +:- mode substitute_type_args_2(in, in, in, out) is det. + +substitute_type_args_2([], _TypeParams, _TypeArgs, []). +substitute_type_args_2([Name - Args0 | Ctors0], TypeParams, TypeArgs, + [Name - Args | Ctors]) :- + term__substitute_corresponding_list(TypeParams, TypeArgs, Args0, Args), + substitute_type_args_2(Ctors0, TypeParams, TypeArgs, Ctors). + +%-----------------------------------------------------------------------------% + +:- pred propagate_ctor_info(inst, type, list(constructor), module_info, inst). +:- mode propagate_ctor_info(in, in, in, in, out) is det. + +% propagate_ctor_info(free, Type, _, _, free(Type)). % temporarily disabled +propagate_ctor_info(free, _Type, _, _, free). % XXX temporary hack + +propagate_ctor_info(free(_), _, _, _, _) :- + error("propagate_ctor_info: type info already present"). +propagate_ctor_info(bound(BoundInsts0), _Type, Constructors, ModuleInfo, + Inst) :- + propagate_ctor_info_2(BoundInsts0, Constructors, ModuleInfo, + BoundInsts), + ( BoundInsts = [] -> + Inst = not_reached + ; + % XXX do we need to sort the BoundInsts? + Inst = bound(BoundInsts) + ). +propagate_ctor_info(ground, _Type, Constructors, ModuleInfo, Inst) :- + constructors_to_bound_insts(Constructors, ModuleInfo, BoundInsts0), + list__sort(BoundInsts0, BoundInsts), + Inst = bound(BoundInsts). +propagate_ctor_info(not_reached, _Type, _Constructors, _ModuleInfo, + not_reached). +propagate_ctor_info(inst_var(_), _, _, _, _) :- + error("propagate_ctor_info: unbound inst var"). +propagate_ctor_info(abstract_inst(Name, Args), _, _, _, + abstract_inst(Name, Args)). % XXX loses info +propagate_ctor_info(defined_inst(InstName), Type, Ctors, ModuleInfo, Inst) :- + inst_lookup(ModuleInfo, InstName, Inst0), + propagate_ctor_info(Inst0, Type, Ctors, ModuleInfo, Inst). + +:- pred ex_propagate_ctor_info(inst, type, list(constructor), module_info, inst). +:- mode ex_propagate_ctor_info(in, in, in, in, out) is det. + +% ex_propagate_ctor_info(free, Type, _, _, free(Type)). % temporarily disabled +ex_propagate_ctor_info(free, _Type, _, _, free). % XXX temporary hack + +ex_propagate_ctor_info(free(_), _, _, _, _) :- + error("ex_propagate_ctor_info: type info already present"). +ex_propagate_ctor_info(bound(BoundInsts0), _Type, Constructors, ModuleInfo, + Inst) :- + propagate_ctor_info_2(BoundInsts0, Constructors, ModuleInfo, + BoundInsts), + ( BoundInsts = [] -> + Inst = not_reached + ; + % XXX do we need to sort the BoundInsts? + Inst = bound(BoundInsts) + ). +ex_propagate_ctor_info(ground, Type, _, _, Inst) :- + Inst = defined_inst(typed_ground(Type)). +ex_propagate_ctor_info(not_reached, _Type, _Constructors, _ModuleInfo, + not_reached). +ex_propagate_ctor_info(inst_var(_), _, _, _, _) :- + error("propagate_ctor_info: unbound inst var"). +ex_propagate_ctor_info(abstract_inst(Name, Args), _, _, _, + abstract_inst(Name, Args)). % XXX loses info +ex_propagate_ctor_info(defined_inst(InstName), Type, _, _, + defined_inst(typed_inst(Type, InstName))). + +:- pred constructors_to_bound_insts(list(constructor), module_info, + list(bound_inst)). +:- mode constructors_to_bound_insts(in, in, out) is det. + +constructors_to_bound_insts([], _, []). +constructors_to_bound_insts([Ctor | Ctors], ModuleInfo, + [BoundInst | BoundInsts]) :- + Ctor = Name0 - Args, + type_list_to_inst_list(Args, Insts), + unqualify_name(Name0, Name), + BoundInst = functor(term__atom(Name), Insts), + constructors_to_bound_insts(Ctors, ModuleInfo, BoundInsts). + +:- pred type_list_to_inst_list(list(type), list(inst)). +:- mode type_list_to_inst_list(in, out) is det. + +type_list_to_inst_list([], []). +type_list_to_inst_list([Type | Types], [Inst | Insts]) :- + Inst = defined_inst(typed_ground(Type)), + type_list_to_inst_list(Types, Insts). + +:- pred propagate_ctor_info_2(list(bound_inst), list(constructor), + module_info, list(bound_inst)). +:- mode propagate_ctor_info_2(in, in, in, out) is det. + +propagate_ctor_info_2(BoundInsts0, _Constructors, _ModuleInfo, BoundInsts) :- + BoundInsts = BoundInsts0. % XXX Stub only!! + +%-----------------------------------------------------------------------------% :- pred inst_lookup_subst_args(hlds__inst_body, list(inst_param), sym_name, list(inst), inst). @@ -298,6 +523,7 @@ inst_lookup_subst_args(eqv_inst(Inst0), Params, _Name, Args, Inst) :- inst_lookup_subst_args(abstract_inst, _Params, Name, Args, abstract_inst(Name, Args)). +%-----------------------------------------------------------------------------% % mode_get_insts returns the initial instantiatedness and % the final instantiatedness for a given mode. diff --git a/compiler/prog_io.m b/compiler/prog_io.m index 3302e83a5..67da694b8 100644 --- a/compiler/prog_io.m +++ b/compiler/prog_io.m @@ -176,11 +176,11 @@ :- type inst_param == term. :- type (inst) ---> free + ; free(type) ; bound(list(bound_inst)) % The list must be sorted ; ground ; not_reached - ; inst_var(var) ; defined_inst(inst_name) % An abstract inst is a defined inst which @@ -193,7 +193,9 @@ :- type inst_name ---> user_inst(sym_name, list(inst)) ; merge_inst(inst, inst) ; unify_inst(is_live, inst, inst) - ; ground_inst(inst_name). + ; ground_inst(inst_name) + ; typed_ground(type) + ; typed_inst(type, inst_name). :- type is_live ---> live ; dead. diff --git a/compiler/type_util.m b/compiler/type_util.m index cb2c4efc7..a60536281 100644 --- a/compiler/type_util.m +++ b/compiler/type_util.m @@ -8,8 +8,6 @@ % It is used by various stages of the compilation after type-checking, % include the mode checker and the code generator. -% XXX TODO: implement type_is_enumeration. - %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -41,6 +39,11 @@ %-----------------------------------------------------------------------------% + % Given a non-variable type, return it's type-id and argument types. + +:- pred type_to_type_id(type, type_id, list(type)). +:- mode type_to_type_id(in, out, out) is det. + % Given a constant and an arity, return a type_id. :- pred make_type_id(const, int, type_id). @@ -87,17 +90,17 @@ classify_type(VarType, ModuleInfo, Type) :- :- mode type_is_enumeration(in, in) is semidet. type_is_enumeration(Type, ModuleInfo) :- - type_to_type_id(Type, TypeId), + Type = term__functor(_, _, _), + type_to_type_id(Type, TypeId, _), module_info_types(ModuleInfo, TypeDefnTable), map__lookup(TypeDefnTable, TypeId, TypeDefn), TypeDefn = hlds__type_defn(_, _, TypeBody, _, _), TypeBody = du_type(_, _, IsEnum), IsEnum = yes. -:- pred type_to_type_id(type, type_id). -:- mode type_to_type_id(in, out) is det. - -type_to_type_id(term__functor(Name, Args, _), TypeId) :- +type_to_type_id(term__variable(_), _, _) :- + error("cannot make type_id for a type variable"). +type_to_type_id(term__functor(Name, Args, _), TypeId, Args) :- list__length(Args, Arity), make_type_id(Name, Arity, TypeId). diff --git a/library/list.m b/library/list.m index f8b054384..3369f7f26 100644 --- a/library/list.m +++ b/library/list.m @@ -65,7 +65,7 @@ ****/ :- mode list__same_length(in, output_list_skel) is det. :- mode list__same_length(output_list_skel, in) is det. -:- mode list__same_length(in, in) is det. +:- mode list__same_length(in, in) is semidet. % list__split_list(Len, List, Start, End): % splits `List' into a prefix `Start' of length `Len', diff --git a/library/map.m b/library/map.m index 5874795bf..0e951f0b4 100644 --- a/library/map.m +++ b/library/map.m @@ -94,7 +94,6 @@ % For map__merge(MapA, MapB, Map), MapA and MapB must % not both contain the same key. - :- pred map__merge(map(K, V), map(K, V), map(K, V)). :- mode map__merge(in, in, out) is det. @@ -102,10 +101,12 @@ % contain the same key, then Map will map that key to % the value from MapB. In otherwords, MapB takes precedence % over MapA. - :- pred map__overlay(map(K,V), map(K,V), map(K,V)). :- mode map__overlay(in, in, out) is det. +:- pred map__apply_to_list(list(K), map(K, V), list(V)). +:- mode map__apply_to_list(in, in, out) is det. + :- pred map__optimize(map(K, V), map(K, V)). :- mode map__optimize(in, out) is det. @@ -231,5 +232,12 @@ map__overlay_2([K - V | AssocList], Map0, Map) :- map__set(Map0, K, V, Map1), map__overlay_2(AssocList, Map1, Map). +%-----------------------------------------------------------------------------% + +map__apply_to_list([], _, []). +map__apply_to_list([K | Ks], Map, [V | Vs]) :- + map__lookup(Map, K, V), + map__apply_to_list(Ks, Map, Vs). + %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%