diff --git a/NEWS b/NEWS index 7156199..56a00cd 100644 --- a/NEWS +++ b/NEWS @@ -430,6 +430,9 @@ Changes to the Mercury standard library: - take_while/2 - drop_while/3 - drop_while/2 + - one_or_more_to_list/1 + - list_to_one_or_more/2 + - list_to_one_or_more_det/2 * The takewhile/4 predicate has been deprecated in the list module, take_while/4 can be used instead. diff --git a/compiler/add_foreign_enum.m b/compiler/add_foreign_enum.m index 6341315..e816157f 100644 --- a/compiler/add_foreign_enum.m +++ b/compiler/add_foreign_enum.m @@ -29,13 +29,19 @@ :- import_module hlds.hlds_module. :- import_module libs. :- import_module libs.globals. +:- import_module mdbcomp. +:- import_module mdbcomp.sym_name. :- import_module parse_tree. :- import_module parse_tree.error_util. :- import_module parse_tree.prog_data. +:- import_module assoc_list. +:- import_module bimap. +:- import_module cord. :- import_module list. :- import_module map. :- import_module maybe. +:- import_module set_tree234. %---------------------------------------------------------------------------% @@ -75,25 +81,37 @@ %---------------------------------------------------------------------------% + % build_ctor_name_to_foreign_name_map_loop(TypeModuleName, ValidCtorNames, + % Overrides, !OverrideMap, !SeenCtorNames, !.SeenForeignNames, + % !BadQualCtorSymNames, !InvalidCtorSymNames, + % !RepeatedCtorNames, !RepeatedForeignNames): + % + % Exported to decide_type_repn.m. + % +:- pred build_ctor_name_to_foreign_name_map_loop(module_name::in, + set_tree234(string)::in, assoc_list(sym_name, string)::in, + bimap(string, string)::in, bimap(string, string)::out, + set_tree234(string)::in, set_tree234(string)::out, set_tree234(string)::in, + cord(sym_name)::in, cord(sym_name)::out, + cord(sym_name)::in, cord(sym_name)::out, + cord(string)::in, cord(string)::out, + cord(string)::in, cord(string)::out) is det. + +%---------------------------------------------------------------------------% + :- implementation. :- import_module backend_libs. :- import_module backend_libs.c_util. :- import_module hlds.make_hlds_error. :- import_module hlds.status. -:- import_module mdbcomp. -:- import_module mdbcomp.sym_name. :- import_module parse_tree.mercury_to_mercury. :- import_module parse_tree.prog_data_foreign. :- import_module parse_tree.prog_item. -:- import_module assoc_list. -:- import_module bimap. :- import_module bool. -:- import_module cord. :- import_module pair. :- import_module require. -:- import_module set_tree234. :- import_module string. %---------------------------------------------------------------------------% @@ -113,7 +131,8 @@ add_pragma_foreign_enum(ModuleInfo, ItemForeignExportEnum, report_if_pragma_is_wrongly_in_interface(ItemMercuryStatus, ItemPragmaInfo, Specs0, Specs1), item_mercury_status_to_type_status(ItemMercuryStatus, PragmaStatus), - FEInfo = pragma_info_foreign_enum(Lang, TypeCtor, MercuryForeignTagPairs), + FEInfo = pragma_info_foreign_enum(Lang, TypeCtor, + OoMMercuryForeignTagPairs), TypeCtor = type_ctor(TypeSymName, TypeArity), TypeSNA = sym_name_arity(TypeSymName, TypeArity), ContextPieces = [words("In"), pragma_decl("foreign_enum"), @@ -184,9 +203,11 @@ add_pragma_foreign_enum(ModuleInfo, ItemForeignExportEnum, _IsForeignType), expect(unify(MaybeRepn, no), $pred, "MaybeRepn != no"), + MercuryForeignTagPairs = + one_or_more_to_list(OoMMercuryForeignTagPairs), build_mercury_foreign_map(TypeModuleName, TypeSymName, TypeArity, for_foreign_enum, - Context, ContextPieces, Ctors, + Context, ContextPieces, one_or_more_to_list(Ctors), MercuryForeignTagPairs, MercuryForeignTagBimap, !Specs), MercuryForeignTagNames = bimap.to_assoc_list(MercuryForeignTagBimap), @@ -329,8 +350,8 @@ add_pragma_foreign_export_enum(ItemForeignExportEnum, !ModuleInfo, build_mercury_foreign_map(TypeModuleName, TypeSymName, TypeArity, for_foreign_export_enum, - Context, ContextPieces, Ctors, Overrides, OverrideBimap, - !Specs), + Context, ContextPieces, one_or_more_to_list(Ctors), + Overrides, OverrideBimap, !Specs), OverrideMap = bimap.forward_map(OverrideBimap), Attributes = @@ -616,16 +637,6 @@ find_nonenum_ctors_build_valid_ctor_names([Ctor | Ctors], find_nonenum_ctors_build_valid_ctor_names(Ctors, !ValidNamesSet, !NonEnumSNAs). -:- pred build_ctor_name_to_foreign_name_map_loop(module_name::in, - set_tree234(string)::in, - assoc_list(sym_name, string)::in, - bimap(string, string)::in, bimap(string, string)::out, - set_tree234(string)::in, set_tree234(string)::out, set_tree234(string)::in, - cord(sym_name)::in, cord(sym_name)::out, - cord(sym_name)::in, cord(sym_name)::out, - cord(string)::in, cord(string)::out, - cord(string)::in, cord(string)::out) is det. - build_ctor_name_to_foreign_name_map_loop(_, _, [], !OverrideMap, !SeenCtorNames, _SeenForeignNames, !BadQualCtorSymNames, !InvalidCtorSymNames, diff --git a/compiler/add_special_pred.m b/compiler/add_special_pred.m index 181bc51..4189cf3 100644 --- a/compiler/add_special_pred.m +++ b/compiler/add_special_pred.m @@ -516,7 +516,8 @@ collect_type_defn_for_tuple(TypeCtor, Type, TVarSet, TypeBody, Context) :- du_type_kind_general, DirectArgCtors), MaybeCanonical = canon, IsForeign = no, - TypeBody = hlds_du_type([Ctor], MaybeCanonical, yes(Repn), IsForeign), + TypeBody = hlds_du_type(one_or_more(Ctor, []), MaybeCanonical, + yes(Repn), IsForeign), construct_type(TypeCtor, TupleArgTypes, Type), term.context_init(Context). diff --git a/compiler/add_type.m b/compiler/add_type.m index 5df5913..45fd166 100644 --- a/compiler/add_type.m +++ b/compiler/add_type.m @@ -624,7 +624,7 @@ check_for_dummy_type_with_unify_compare(TypeStatus, TypeCtor, DetailsDu, % to have user-defined equality or comparison. DetailsDu = type_details_du(Ctors, MaybeCanonical, _MaybeDirectArg), - Ctors = [Ctor], + Ctors = one_or_more(Ctor, []), Ctor ^ cons_args = [], MaybeCanonical = noncanon(_), % Only report errors for types defined in this module. @@ -937,7 +937,7 @@ add_du_ctors_check_foreign_type_for_cur_backend(TypeCtor, TypeDefn, get_type_defn_status(TypeDefn, Status), get_type_defn_ctors_need_qualifier(TypeDefn, NeedQual), ( - Body = hlds_du_type(ConsList, _MaybeUserEqCmp, _MaybeRepn, + Body = hlds_du_type(OoMCtors, _MaybeUserEqCmp, _MaybeRepn, _MaybeForeign), module_info_get_cons_table(!.ModuleInfo, CtorMap0), module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo), @@ -949,9 +949,15 @@ add_du_ctors_check_foreign_type_for_cur_backend(TypeCtor, TypeDefn, ; TypeCtorSymName = qualified(TypeCtorModuleName, _) ), - add_type_defn_ctors(ConsList, TypeCtor, TypeCtorModuleName, TVarSet, - TypeParams, KindMap, NeedQual, PQInfo, Status, - CtorFieldMap0, CtorFieldMap, CtorMap0, CtorMap, [], CtorAddSpecs), + OoMCtors = one_or_more(HeadCtor, TailCtors), + add_type_defn_ctor(HeadCtor, TypeCtor, TypeCtorModuleName, + TVarSet, TypeParams, KindMap, NeedQual, PQInfo, Status, + CtorFieldMap0, CtorFieldMap1, CtorMap0, CtorMap1, + [], CtorAddSpecs1), + add_type_defn_ctors(TailCtors, TypeCtor, TypeCtorModuleName, + TVarSet, TypeParams, KindMap, NeedQual, PQInfo, Status, + CtorFieldMap1, CtorFieldMap, CtorMap1, CtorMap, + CtorAddSpecs1, CtorAddSpecs), module_info_set_cons_table(CtorMap, !ModuleInfo), module_info_set_ctor_field_table(CtorFieldMap, !ModuleInfo), diff --git a/compiler/canonicalize_interface.m b/compiler/canonicalize_interface.m index cb5f563..890b531 100644 --- a/compiler/canonicalize_interface.m +++ b/compiler/canonicalize_interface.m @@ -464,6 +464,7 @@ classify_items([Item | Items], !TypeDefnMap, !InstDefnMap, !ModeDefnMap, ; Item = item_typeclass(_) ; Item = item_instance(_) ; Item = item_foreign_import_module(_) + ; Item = item_type_repn(_) ), set.insert(Item, !SortableItems) ; @@ -473,10 +474,6 @@ classify_items([Item | Items], !TypeDefnMap, !InstDefnMap, !ModeDefnMap, ; Item = item_mutable(_) ), !:NonReorderableItemsCord = cord.snoc(!.NonReorderableItemsCord, Item) - ; - Item = item_type_repn(_), - % We do not generate such items yet. - unexpected($pred, "item_type_repn") ), classify_items(Items, !TypeDefnMap, !InstDefnMap, !ModeDefnMap, !PredRelatedMap, !SortableItems, !NonReorderableItemsCord). diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m index 5d6ee2a..8d69e5f 100644 --- a/compiler/check_typeclass.m +++ b/compiler/check_typeclass.m @@ -1735,7 +1735,7 @@ check_ctor_constraints(ModuleInfo, TypeCtor - TypeDefn, !Specs) :- ( Body = hlds_du_type(Ctors, _, _, _), list.foldl(check_ctor_type_ambiguities(ModuleInfo, TypeCtor, TypeDefn), - Ctors, !Specs) + one_or_more_to_list(Ctors), !Specs) ; ( Body = hlds_eqv_type(_) ; Body = hlds_foreign_type(_) diff --git a/compiler/comp_unit_interface.m b/compiler/comp_unit_interface.m index 7a8d470..0b041b7 100644 --- a/compiler/comp_unit_interface.m +++ b/compiler/comp_unit_interface.m @@ -154,7 +154,9 @@ :- implementation. +:- import_module libs.options. :- import_module parse_tree.check_raw_comp_unit. +:- import_module parse_tree.decide_type_repn. :- import_module parse_tree.file_kind. :- import_module parse_tree.item_util. :- import_module parse_tree.module_qual. @@ -181,7 +183,10 @@ generate_short_interface_int3(Globals, RawCompUnit, ParseTreeInt, !:Specs) :- !:Specs = [], get_short_interface_int3_from_item_blocks(RawItemBlocks, cord.init, IntInclsCord, cord.init, IntAvailsCord0, - cord.init, IntItemsCord, do_not_need_avails, NeedAvails, !Specs), + cord.init, IntItemsCord0, + cord.init, IntTypeDefnsCord, cord.init, ImpTypeDefnsCord, + map.init, ForeignEnumTypeCtors, do_not_need_avails, NeedAvails, + !Specs), IntIncls = cord.list(IntInclsCord), ( NeedAvails = do_not_need_avails, @@ -190,7 +195,17 @@ generate_short_interface_int3(Globals, RawCompUnit, ParseTreeInt, !:Specs) :- NeedAvails = do_need_avails, IntAvails = cord.list(IntAvailsCord0) ), - IntItems = cord.list(IntItemsCord), + IntItems0 = cord.list(IntItemsCord0), + globals.lookup_string_option(Globals, experiment, Experiment), + ( if Experiment = "type_repn_int3" then + IntTypeDefns = cord.list(IntTypeDefnsCord), + ImpTypeDefns = cord.list(ImpTypeDefnsCord), + decide_repns_for_simple_types(ModuleName, IntTypeDefns, ImpTypeDefns, + ForeignEnumTypeCtors, TypeRepnItems), + IntItems = IntItems0 ++ TypeRepnItems + else + IntItems = IntItems0 + ), MaybeVersionNumbers = no, ParseTreeInt0 = parse_tree_int(ModuleName, ifk_int3, ModuleNameContext, MaybeVersionNumbers, IntIncls, [], IntAvails, [], IntItems, []), @@ -204,36 +219,49 @@ generate_short_interface_int3(Globals, RawCompUnit, ParseTreeInt, !:Specs) :- :- pred get_short_interface_int3_from_item_blocks(list(raw_item_block)::in, cord(item_include)::in, cord(item_include)::out, cord(item_avail)::in, cord(item_avail)::out, - cord(item)::in, cord(item)::out, need_avails::in, need_avails::out, + cord(item)::in, cord(item)::out, + cord(item_type_defn_info)::in, cord(item_type_defn_info)::out, + cord(item_type_defn_info)::in, cord(item_type_defn_info)::out, + foreign_enum_map::in, foreign_enum_map::out, + need_avails::in, need_avails::out, list(error_spec)::in, list(error_spec)::out) is det. get_short_interface_int3_from_item_blocks([], - !IntIncls, !IntAvails, !IntItems, !NeedAvails, !Specs). + !IntIncls, !IntAvails, !IntItems, !IntTypeDefns, !ImpTypeDefns, + !ForeignEnumTypeCtors, !NeedAvails, !Specs). get_short_interface_int3_from_item_blocks([RawItemBlock | RawItemBlocks], - !IntIncls, !IntAvails, !IntItems, !NeedAvails, !Specs) :- + !IntIncls, !IntAvails, !IntItems, !IntTypeDefns, !ImpTypeDefns, + !ForeignEnumTypeCtors, !NeedAvails, !Specs) :- RawItemBlock = item_block(_, Section, Incls, Avails, Items), ( Section = ms_interface, !:IntIncls = !.IntIncls ++ cord.from_list(Incls), !:IntAvails = !.IntAvails ++ cord.from_list(Avails), - get_short_interface_int3_from_items(Items, !IntItems, !NeedAvails, - !Specs) + get_short_interface_int3_from_items(Items, !IntItems, !IntTypeDefns, + !ForeignEnumTypeCtors, !NeedAvails, !Specs) ; - Section = ms_implementation + Section = ms_implementation, + gather_imp_type_defns(Items, !ImpTypeDefns, !ForeignEnumTypeCtors) ), get_short_interface_int3_from_item_blocks(RawItemBlocks, - !IntIncls, !IntAvails, !IntItems, !NeedAvails, !Specs). + !IntIncls, !IntAvails, !IntItems, !IntTypeDefns, !ImpTypeDefns, + !ForeignEnumTypeCtors, !NeedAvails, !Specs). :- pred get_short_interface_int3_from_items(list(item)::in, - cord(item)::in, cord(item)::out, need_avails::in, need_avails::out, + cord(item)::in, cord(item)::out, + cord(item_type_defn_info)::in, cord(item_type_defn_info)::out, + foreign_enum_map::in, foreign_enum_map::out, + need_avails::in, need_avails::out, list(error_spec)::in, list(error_spec)::out) is det. -get_short_interface_int3_from_items([], !IntItems, !NeedAvails, - !Specs). -get_short_interface_int3_from_items([Item | Items], !IntItems, !NeedAvails, - !Specs) :- +get_short_interface_int3_from_items([], !IntItems, !IntTypeDefns, + !ForeignEnumTypeCtors, !NeedAvails, !Specs). +get_short_interface_int3_from_items([Item | Items], !IntItems, !IntTypeDefns, + !ForeignEnumTypeCtors, !NeedAvails, !Specs) :- ( Item = item_type_defn(ItemTypeDefnInfo), + !:IntTypeDefns = cord.snoc(!.IntTypeDefns, ItemTypeDefnInfo), + % XXX TYPE_REPN do this in decide_type_repn.m? make_type_defn_abstract_type_for_int3(ItemTypeDefnInfo, AbstractOrForeignItemTypeDefnInfo), AbstractOrForeignItem = @@ -274,7 +302,8 @@ get_short_interface_int3_from_items([Item | Items], !IntItems, !NeedAvails, !:Specs = [Spec | !.Specs] ; AllowedInInterface = yes - ) + ), + maybe_record_foreign_enum(Pragma, !ForeignEnumTypeCtors) ; ( Item = item_foreign_import_module(_) ; Item = item_mutable(_) @@ -286,8 +315,8 @@ get_short_interface_int3_from_items([Item | Items], !IntItems, !NeedAvails, ; Item = item_type_repn(_) ) ), - get_short_interface_int3_from_items(Items, !IntItems, !NeedAvails, - !Specs). + get_short_interface_int3_from_items(Items, !IntItems, !IntTypeDefns, + !ForeignEnumTypeCtors, !NeedAvails, !Specs). :- pred make_type_defn_abstract_type_for_int3(item_type_defn_info::in, item_type_defn_info::out) is det. @@ -352,6 +381,58 @@ make_type_defn_abstract_type_for_int3(ItemTypeDefn, ) ). +:- pred gather_imp_type_defns(list(item)::in, + cord(item_type_defn_info)::in, cord(item_type_defn_info)::out, + foreign_enum_map::in, foreign_enum_map::out) is det. + +gather_imp_type_defns([], !ImpTypeDefns, !ForeignEnumTypeCtors). +gather_imp_type_defns([Item | Items], !ImpTypeDefns, !ForeignEnumTypeCtors) :- + ( + Item = item_type_defn(ItemTypeDefnInfo), + !:ImpTypeDefns = cord.snoc(!.ImpTypeDefns, ItemTypeDefnInfo) + ; + Item = item_pragma(ItemPragma), + ItemPragma = item_pragma_info(Pragma, _, _, _), + maybe_record_foreign_enum(Pragma, !ForeignEnumTypeCtors) + ; + ( Item = item_typeclass(_) + ; Item = item_instance(_) + ; Item = item_inst_defn(_) + ; Item = item_mode_defn(_) + ; Item = item_clause(_) + ; Item = item_foreign_import_module(_) + ; Item = item_mutable(_) + ; Item = item_pred_decl(_) + ; Item = item_mode_decl(_) + ; Item = item_promise(_) + ; Item = item_initialise(_) + ; Item = item_finalise(_) + ; Item = item_type_repn(_) + ) + ), + gather_imp_type_defns(Items, !ImpTypeDefns, !ForeignEnumTypeCtors). + +:- pred maybe_record_foreign_enum(pragma_type::in, + foreign_enum_map::in, foreign_enum_map::out) is det. + +maybe_record_foreign_enum(Pragma, !ForeignEnumTypeCtors) :- + ( if Pragma = pragma_foreign_enum(PragmaInfoForeignEnum) then + PragmaInfoForeignEnum = + pragma_info_foreign_enum(Lang, TypeCtor, OoMValues), + TypeCtor = type_ctor(TypeSymName, TypeArity), + TypeName = unqualify_name(TypeSymName), + UnqualTypeCtor = unqual_type_ctor(TypeName, TypeArity), + ( if map.search(!.ForeignEnumTypeCtors, UnqualTypeCtor, LVs0) then + map.det_update(UnqualTypeCtor, [Lang - OoMValues | LVs0], + !ForeignEnumTypeCtors) + else + map.det_insert(UnqualTypeCtor, [Lang - OoMValues], + !ForeignEnumTypeCtors) + ) + else + true + ). + %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% @@ -1379,7 +1460,7 @@ accumulate_abs_imp_exported_type_lhs_2(IntTypesMap, BothTypesMap, ) ; ImpTypeDefn = parse_tree_du_type(DetailsDu), - DetailsDu = type_details_du(Ctors, MaybeEqCmp, MaybeDirectArgCtors), + DetailsDu = type_details_du(OoMCtors, MaybeEqCmp, MaybeDirectArgCtors), ( if map.search(IntTypesMap, TypeCtor, _), du_type_is_enum(DetailsDu, _NumBits) @@ -1394,7 +1475,7 @@ accumulate_abs_imp_exported_type_lhs_2(IntTypesMap, BothTypesMap, % !DummyTypeCtors, since we won't know enough about the contents % of the other module. constructor_list_represents_dummy_argument_type(BothTypesMap, - Ctors, MaybeEqCmp, MaybeDirectArgCtors) + OoMCtors, MaybeEqCmp, MaybeDirectArgCtors) then set.insert(TypeCtor, !DummyTypeCtors) else @@ -1458,7 +1539,7 @@ accumulate_abs_eqv_type_rhs_2(ImpTypesMap, ImpItemTypeDefnInfo, !AbsExpEqvRhsTypeCtors, set.init, _, !ModulesNeededByTypeDefns) ; ImpTypeDefn = parse_tree_du_type(DetailsDu), - DetailsDu = type_details_du(Ctors, _, _), + DetailsDu = type_details_du(OoMCtors, _, _), % There must exist a foreign type alternative to this type. % XXX ITEM_LIST I (zs) would like to see a proof argument for that, % since I don't think it is true. Unfortunately, we cannot check it @@ -1467,7 +1548,8 @@ accumulate_abs_eqv_type_rhs_2(ImpTypesMap, ImpItemTypeDefnInfo, % As the du type will be exported, we require all the type_ctors % inside all the argument types of all the data constructors, and the % modules that define them. - ctors_to_user_type_ctor_set(Ctors, set.init, RhsTypeCtors), + ctors_to_user_type_ctor_set(one_or_more_to_list(OoMCtors), + set.init, RhsTypeCtors), set.union(RhsTypeCtors, !DuArgTypeCtors), set.fold(accumulate_modules_used_by_type_ctor, RhsTypeCtors, !ModulesNeededByTypeDefns) @@ -1556,20 +1638,21 @@ ctor_args_to_user_type_ctor_set([Arg | Args], !TypeCtors) :- % NOTE: changes here may require changes to `type_util.check_dummy_type'. % :- pred constructor_list_represents_dummy_argument_type(type_defn_map::in, - list(constructor)::in, maybe_canonical::in, + one_or_more(constructor)::in, maybe_canonical::in, maybe(list(sym_name_and_arity))::in) is semidet. constructor_list_represents_dummy_argument_type(TypeDefnMap, - Ctors, MaybeCanonical, MaybeDirectArgCtors) :- + OoMCtors, MaybeCanonical, MaybeDirectArgCtors) :- constructor_list_represents_dummy_argument_type_2(TypeDefnMap, - Ctors, MaybeCanonical, MaybeDirectArgCtors, []). + OoMCtors, MaybeCanonical, MaybeDirectArgCtors, []). :- pred constructor_list_represents_dummy_argument_type_2(type_defn_map::in, - list(constructor)::in, maybe_canonical::in, + one_or_more(constructor)::in, maybe_canonical::in, maybe(list(sym_name_and_arity))::in, list(mer_type)::in) is semidet. -constructor_list_represents_dummy_argument_type_2(TypeDefnMap, [Ctor], +constructor_list_represents_dummy_argument_type_2(TypeDefnMap, OoMCtors, canon, no, CoveredTypes) :- + OoMCtors = one_or_more(Ctor, []), Ctor = ctor(_Ordinal, MaybeExistConstraints, _Name, CtorArgs, _Arity, _Context), MaybeExistConstraints = no_exist_constraints, @@ -1604,10 +1687,10 @@ ctor_arg_is_dummy_type(TypeDefnMap, Type, CoveredTypes0) = IsDummyType :- list.member(ItemTypeDefnInfo, ItemTypeDefnInfos), TypeDefn = ItemTypeDefnInfo ^ td_ctor_defn, TypeDefn = parse_tree_du_type(DetailsDu), - DetailsDu = type_details_du(Ctors, MaybeEqCmp, + DetailsDu = type_details_du(OoMCtors, MaybeEqCmp, MaybeDirectArgCtors), constructor_list_represents_dummy_argument_type_2( - TypeDefnMap, Ctors, MaybeEqCmp, MaybeDirectArgCtors, + TypeDefnMap, OoMCtors, MaybeEqCmp, MaybeDirectArgCtors, [Type | CoveredTypes0]) ) then @@ -1707,11 +1790,11 @@ make_imp_type_abstract(BothTypesMap, !ImpItemTypeDefnInfos) :- ImpItemTypeDefnInfo0 = item_type_defn_info(_, _, TypeDefn0, _, _, _), ( TypeDefn0 = parse_tree_du_type(DetailsDu0), - DetailsDu0 = type_details_du(Ctors, MaybeEqCmp, + DetailsDu0 = type_details_du(OoMCtors, MaybeEqCmp, MaybeDirectArgCtors), ( if constructor_list_represents_dummy_argument_type(BothTypesMap, - Ctors, MaybeEqCmp, MaybeDirectArgCtors) + OoMCtors, MaybeEqCmp, MaybeDirectArgCtors) then % Leave dummy types alone. true diff --git a/compiler/decide_type_repn.m b/compiler/decide_type_repn.m index e69de29..e8137dc 100644 --- a/compiler/decide_type_repn.m +++ b/compiler/decide_type_repn.m @@ -0,0 +1,606 @@ +%---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% +% Copyright (C) 2019 The 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: decide_type_repn.m. +% Main author: zs. +% +% The task of this module is decide the representation of each type +% and to generate type_representation items recording those decisions +% for inclusion in automatically generated interface files. +% +% We decide the representation of simple types (direct dummy types, +% enum types, and notag types) when generating .int3 files. +% The intention is that we will decide the representation of +% all other types when generating .int/.int2 files. +% +% The task of this module differs from that of the (current) du_type_layout.m +% not just in that it does its work earlier, on the parse tree instead of +% on the HLDS, but also in that the information it puts into interface files +% must be grade-independent. +% +%---------------------------------------------------------------------------% + +:- module parse_tree.decide_type_repn. +:- interface. + +:- import_module libs. +:- import_module libs.globals. +:- import_module mdbcomp. +:- import_module mdbcomp.sym_name. +:- import_module parse_tree.prog_data. +:- import_module parse_tree.prog_item. + +:- import_module assoc_list. +:- import_module list. +:- import_module map. +:- import_module pair. + +:- type unqual_type_ctor + ---> unqual_type_ctor(string, arity). + + % Maps each type constructor in the module that has at least one + % foreign_enum pragma for it to a list, each member of which says + % "for this language, the functors of the type are implemented + % by this string in that foreign language". + % +:- type foreign_enum_map == + map(unqual_type_ctor, + assoc_list(foreign_language, one_or_more(pair(sym_name, string)))). + + % decide_repns_for_simple_types(Globals, + % IntTypeDefns, ImpTypeDefns, ForeignEnumTypeCtors, TypeRepnItems): + % + % Given the type definitions in the two sections of a module, + % + % - figure out which type definitions define exported simple types, + % - decide their representations, and + % - generate items recording those decisions. + % +:- pred decide_repns_for_simple_types(module_name::in, + list(item_type_defn_info)::in, list(item_type_defn_info)::in, + foreign_enum_map::in, list(item)::out) is det. + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +:- implementation. + +:- import_module hlds. +:- import_module hlds.add_foreign_enum. % XXX TYPE_REPN undesirable dependency + +:- import_module bimap. +:- import_module cord. +:- import_module maybe. +:- import_module require. +:- import_module set. +:- import_module set_tree234. +:- import_module term. +:- import_module varset. + +%---------------------------------------------------------------------------% + +decide_repns_for_simple_types(ModuleName, IntTypeDefns, ImpTypeDefns, + ForeignEnumTypeCtors, Items) :- + list.foldl3( + decide_repn_if_simple_du_type(ModuleName, ForeignEnumTypeCtors, + si_imp), + ImpTypeDefns, map.init, ImpTypeRepnMap0, map.init, ImpWordAlignedMap, + [], ImpForeignTypeDefns), + list.foldl(record_foreign_type, + ImpForeignTypeDefns, ImpTypeRepnMap0, ImpTypeRepnMap), + list.foldl3( + decide_repn_if_simple_du_type(ModuleName, ForeignEnumTypeCtors, + si_int(ImpTypeRepnMap, ImpWordAlignedMap)), + IntTypeDefns, map.init, TypeRepnMap0, map.init, WordAlignedMap, + [], IntForeignTypeDefns), + list.foldl(record_foreign_type, + IntForeignTypeDefns, TypeRepnMap0, TypeRepnMap), + map.foldl(make_type_repn_item(ModuleName), TypeRepnMap, + cord.init, ItemsCord0), + map.foldl(maybe_make_word_aligned_item(ModuleName), WordAlignedMap, + ItemsCord0, ItemsCord), + Items = cord.list(ItemsCord). + +%---------------------% + +:- pred make_type_repn_item(module_name::in, + unqual_type_ctor::in, du_or_foreign_repn::in, + cord(item)::in, cord(item)::out) is det. + +make_type_repn_item(ModuleName, UnqualTypeCtor, Repn, !Items) :- + UnqualTypeCtor = unqual_type_ctor(TypeName, Arity), + TypeCtorSymName = qualified(ModuleName, TypeName), + varset.init(TVarSet0), + varset.new_vars(Arity, TypeParams, TVarSet0, TVarSet), + ( + Repn = dofr_du(DuRepn), + TypeRepn = tcrepn_du(DuRepn) + ; + Repn = dofr_maybe_foreign(OoMLangRepns, MaybeDuRepn0), + ( + MaybeDuRepn0 = no, + MaybeDuRepn = no + ; + MaybeDuRepn0 = yes(DuRepn0), + ( + DuRepn0 = dur_enum(EnumRepn0), + OoMLangRepns = one_or_more(HeadLangRepn, TailLangsRepns), + gather_used_foreign_languages(HeadLangRepn, + set.init, UsedLangs1), + list.foldl(gather_used_foreign_languages, TailLangsRepns, + UsedLangs1, UsedLangs), + EnumRepn0 = enum_repn(EnumFunctors, ForeignEnums0), + list.filter(is_non_overridden_foreign_enum(UsedLangs), + ForeignEnums0, ForeignEnums), + EnumRepn = enum_repn(EnumFunctors, ForeignEnums), + DuRepn = dur_enum(EnumRepn), + MaybeDuRepn = yes(DuRepn) + ; + ( DuRepn0 = dur_notag(_) + ; DuRepn0 = dur_direct_dummy(_) + ; DuRepn0 = dur_gen(_) + ), + MaybeDuRepn = MaybeDuRepn0 + ) + ), + TypeRepn = tcrepn_maybe_foreign(OoMLangRepns, MaybeDuRepn) + ), + TypeRepnInfo = item_type_repn_info(TypeCtorSymName, TypeParams, + TypeRepn, TVarSet, term.context_init, -1), + Item = item_type_repn(TypeRepnInfo), + !:Items = cord.snoc(!.Items, Item). + +:- pred gather_used_foreign_languages( + pair(foreign_language, foreign_type_repn)::in, + set(foreign_language)::in, set(foreign_language)::out) is det. + +gather_used_foreign_languages(Lang - _Repn, !UsedLangs) :- + set.insert(Lang, !UsedLangs). + +:- pred is_non_overridden_foreign_enum(set(foreign_language)::in, + pair(foreign_language, one_or_more(string))::in) is semidet. + +is_non_overridden_foreign_enum(OverriddenLangs, Lang - _ForeignEnums) :- + not set.contains(OverriddenLangs, Lang). + +%---------------------% + +:- pred maybe_make_word_aligned_item(module_name::in, + unqual_type_ctor::in, maybe_word_aligned::in, + cord(item)::in, cord(item)::out) is det. + +maybe_make_word_aligned_item(ModuleName, UnqualTypeCtor, WordAligned, + !Items) :- + ( + WordAligned = not_word_aligned + ; + WordAligned = word_aligned, + UnqualTypeCtor = unqual_type_ctor(TypeName, Arity), + TypeCtorSymName = qualified(ModuleName, TypeName), + varset.init(TVarSet0), + varset.new_vars(Arity, TypeParams, TVarSet0, TVarSet), + TypeRepnInfo = item_type_repn_info(TypeCtorSymName, TypeParams, + tcrepn_is_word_aligned_ptr, TVarSet, term.context_init, -1), + Item = item_type_repn(TypeRepnInfo), + !:Items = cord.snoc(!.Items, Item) + ). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +:- type du_or_foreign_repn + ---> dofr_du( + du_repn + ) + ; dofr_maybe_foreign( + one_or_more(pair(foreign_language, foreign_type_repn)), + maybe(du_repn) + ). + +:- type type_repn_map == map(unqual_type_ctor, du_or_foreign_repn). + +:- type maybe_word_aligned + ---> not_word_aligned + ; word_aligned. + +:- type word_aligned_map == map(unqual_type_ctor, maybe_word_aligned). + +:- type section_info + ---> si_imp + ; si_int(type_repn_map, word_aligned_map). + +:- pred decide_repn_if_simple_du_type(module_name::in, foreign_enum_map::in, + section_info::in, item_type_defn_info::in, + type_repn_map::in, type_repn_map::out, + word_aligned_map::in, word_aligned_map::out, + list(item_type_defn_info)::in, list(item_type_defn_info)::out) is det. + +decide_repn_if_simple_du_type(ModuleName, ForeignEnumTypeCtors, + SectionInfo, TypeDefnInfo, !TypeRepnMap, !WordAlignedMap, + !DeferredForeignTypeDefns) :- + TypeDefnInfo = item_type_defn_info(TypeCtorSymName, TypeParams, + TypeDefn, _TVarSet, _Context, _SeqNum), + ( + TypeCtorSymName = unqualified(_), + unexpected($pred, "unqualified TypeCtorSymName") + ; + TypeCtorSymName = qualified(_TypeCtorModuleName, TypeCtorName) + % _TypeCtorModuleName need not be the same as ModuleName. + % For correctness, it is enough that it *matches* ModuleName, + % in the sense of partial_sym_name_matches_full. + % And if it does not match ModuleName, then the module has + % a compile-time error, and therefore the .int3 file + % we are contributing to here will have to be rebuilt + % after that error is fixed. + ), + list.length(TypeParams, TypeCtorArity), + UnqualTypeCtor = unqual_type_ctor(TypeCtorName, TypeCtorArity), + ( + TypeDefn = parse_tree_du_type(DuDetails), + % XXX TYPE_REPN We should delete the "where direct_arg is" clause + % from the Mercury language before we switch over to using this + % module for anything but testing purposes. If we do not, we will + % have to handle _MaybeDirectArgs here. + DuDetails = type_details_du(OoMCtors, MaybeCanonical, + _MaybeDirectArgs), + OoMCtors = one_or_more(HeadCtor, TailCtors), + ( + TailCtors = [], + % The type has exactly one data constructor. + SingleCtor = HeadCtor, + SingleCtor = ctor(_Ordinal, MaybeExistConstraints, + SingleCtorSymName, Args, Arity, _SingleCtorContext), + ( if + ctor_is_constant(SingleCtor, SingleCtorName) + then + DirectDummyRepn = direct_dummy_repn(SingleCtorName), + DuRepn = dur_direct_dummy(DirectDummyRepn), + add_du_repn_to_type_map(UnqualTypeCtor, DuRepn, !TypeRepnMap), + WordAligned = not_word_aligned + else if + MaybeExistConstraints = no_exist_constraints, + Args = [_], + Arity = 1, + MaybeCanonical = canon + then + NotagRepn = notag_repn(unqualify_name(SingleCtorSymName)), + DuRepn = dur_notag(NotagRepn), + add_du_repn_to_type_map(UnqualTypeCtor, DuRepn, !TypeRepnMap), + WordAligned = not_word_aligned + else + % NOTE We currently do not apply the direct arg optimization + % to polymorphic argument types. + % We could let the argument's type to have a set of type params + % that is a subset of the type params of the containing type, + % but that would require the runtime system to be able + % to handle variables in the argument type, during unification + % and comparison (mercury_unify_compare_body.h), + % during deconstruction (mercury_ml_expand_body.h), + % during deep copying (mercury_deep_copy_body.h), and maybe + % during some other operations. + ( if TypeCtorArity = 0 then + WordAligned = word_aligned + else + WordAligned = not_word_aligned + ) + ) + ; + TailCtors = [_ | _], + % The type has at least two data constructors. + ( if + ctor_is_constant(HeadCtor, HeadName), + ctors_are_all_constants(TailCtors, TailNames) + then + ( if + map.search(ForeignEnumTypeCtors, UnqualTypeCtor, + ForeignTypeCtorEntry) + then + Names = [HeadName | TailNames], + set_tree234.list_to_set(Names, NamesSet), + list.foldl( + build_foreign_langs_name_map(ModuleName, + Names, NamesSet), + ForeignTypeCtorEntry, map.init, ForeignLangsNamesMap), + map.to_assoc_list(ForeignLangsNamesMap, ForeignLangsNames) + else + ForeignLangsNames = [] + ), + OoMNames = one_or_more(HeadName, TailNames), + EnumRepn = enum_repn(OoMNames, ForeignLangsNames), + DuRepn = dur_enum(EnumRepn), + add_du_repn_to_type_map(UnqualTypeCtor, DuRepn, !TypeRepnMap) + else + true + ), + WordAligned = not_word_aligned + ), + record_type_word_alignment(UnqualTypeCtor, WordAligned, + !WordAlignedMap) + ; + TypeDefn = parse_tree_foreign_type(_ForeignType), + !:DeferredForeignTypeDefns = + [TypeDefnInfo | !.DeferredForeignTypeDefns] + ; + TypeDefn = parse_tree_abstract_type(_), + ( + SectionInfo = si_imp + ; + SectionInfo = si_int(ImpTypeRepnMap, ImpWordAlignedMap), + ( if map.search(ImpTypeRepnMap, UnqualTypeCtor, ImpRepn) then + ( if map.search(!.TypeRepnMap, UnqualTypeCtor, _) then + % We have already found a definition of this type + % in the interface that let us decide its representation, + % so the type is defined at least twice. Keep the + % representation we derived from the (first) definition + % in the interface. + true + else + map.det_insert(UnqualTypeCtor, ImpRepn, !TypeRepnMap) + ) + else + % Either the type is not defined in the implementation section, + % or if there such a definition, it is not simple enough + % to decide its representation in this pass. + % + % If there is a representation for this type in the interface + % section either, we want to keep that. + % If there is no representation for this type in the interface + % section either, we want to keep that absence as well. + true + ), + ( if map.search(ImpWordAlignedMap, UnqualTypeCtor, ImpWA) then + record_type_word_alignment(UnqualTypeCtor, ImpWA, + !WordAlignedMap) + else + true + ) + ) + ; + ( TypeDefn = parse_tree_eqv_type(_) + ; TypeDefn = parse_tree_solver_type(_) + ) + ). + +%---------------------% + +:- pred build_foreign_langs_name_map(module_name::in, + list(string)::in, set_tree234(string)::in, + pair(foreign_language, one_or_more(pair(sym_name, string)))::in, + map(foreign_language, one_or_more(string))::in, + map(foreign_language, one_or_more(string))::out) is det. + +build_foreign_langs_name_map(ModuleName, CtorNames, CtorNamesSet, + Lang - OoMCtorSymNamesForeignNames, !ForeignLangsNamesMap) :- + ( if map.search(!.ForeignLangsNamesMap, Lang, _) then + % This is a foreign_enum for a type_ctor/foreign_language combination + % that we have seen before. This is an error, and the programmer + % will have to fix it before we can build a meaningful .int3 file. + % To avoid confusing readers of the .int3 file we are building *now*, + % we ignore such duplicates. + true + else + CtorSymNamesForeignNames = + one_or_more_to_list(OoMCtorSymNamesForeignNames), + SeenCtorNamesSet0 = set_tree234.init, + SeenForeignNamesSet0 = set_tree234.init, + BadQualCtorSymNamesCord0 = cord.init, + InvalidCtorSymNamesCord0 = cord.init, + RepeatedCtorNamesCord0 = cord.init, + RepeatedForeignNamesCord0 = cord.init, + build_ctor_name_to_foreign_name_map_loop(ModuleName, CtorNamesSet, + CtorSymNamesForeignNames, bimap.init, MercuryForeignBimap, + SeenCtorNamesSet0, SeenCtorNamesSet, SeenForeignNamesSet0, + BadQualCtorSymNamesCord0, BadQualCtorSymNamesCord, + InvalidCtorSymNamesCord0, InvalidCtorSymNamesCord, + RepeatedCtorNamesCord0, RepeatedCtorNamesCord, + RepeatedForeignNamesCord0, RepeatedForeignNamesCord), + ( if + cord.is_empty(BadQualCtorSymNamesCord), + cord.is_empty(InvalidCtorSymNamesCord), + cord.is_empty(RepeatedCtorNamesCord), + cord.is_empty(RepeatedForeignNamesCord), + + set_tree234.difference(CtorNamesSet, SeenCtorNamesSet, + UnseenCtorNamesSet), + set_tree234.is_non_empty(UnseenCtorNamesSet), + + list.map(bimap.forward_search(MercuryForeignBimap), + CtorNames, ForeignNames), + list_to_one_or_more(ForeignNames, OoMForeignNames) + then + map.det_insert(Lang, OoMForeignNames, !ForeignLangsNamesMap) + else + % The foreign_enum pragma has at least one error. + % Don't include it in the .int3 file we are building. + true + ) + ). + +%---------------------% + +:- pred add_du_repn_to_type_map(unqual_type_ctor::in, du_repn::in, + type_repn_map::in, type_repn_map::out) is det. + +add_du_repn_to_type_map(UnqualTypeCtor, DuRepn, !TypeRepnMap) :- + ( if map.search(!.TypeRepnMap, UnqualTypeCtor, OldTypeRepn) then + ( + OldTypeRepn = dofr_du(_) + % UnqualTypeCtor has more than one du definition in this module. + % This is an error, and it will be detected and reported when + % the module is compiled to target code. It does not matter + % which du definition we put into the .int3 file, so we choose + % the one we found first. + ; + OldTypeRepn = + dofr_maybe_foreign(OldForeignLangRepns, OldMaybeDuRepn), + ( + OldMaybeDuRepn = no, + NewTypeRepn = + dofr_maybe_foreign(OldForeignLangRepns, yes(DuRepn)), + map.det_update(UnqualTypeCtor, NewTypeRepn, !TypeRepnMap) + ; + OldMaybeDuRepn = yes(_) + % This also means that that UnqualTypeCtor has more + % than one definition in this module. + ) + ) + else + NewTypeRepn = dofr_du(DuRepn), + map.det_insert(UnqualTypeCtor, NewTypeRepn, !TypeRepnMap) + ). + +%---------------------% + + % A type constructor *should* only have one Mercury definition + % in a module. However, in practice it may have two or more. + % This is an error the programmer will have to fix. We expect that + % in the vast majority of the cases, the fix will be choosing + % one of these definitions. In the hope (though not the expectation) + % of minimizing the amount of recompilation that has to be done + % after the fix, we record a type constructor as having guaranteed- + % to-be-aligned values only if *all* the definitions provide + % this guarantee. + % +:- pred record_type_word_alignment(unqual_type_ctor::in, + maybe_word_aligned::in, + word_aligned_map::in, word_aligned_map::out) is det. + +record_type_word_alignment(UnqualTypeCtor, WordAligned, !WordAlignedMap) :- + ( if map.search(!.WordAlignedMap, UnqualTypeCtor, OldWordAligned) then + ( + WordAligned = word_aligned, + % Whether OldWordAligned is word_aligned or not_word_aligned, + % we want to keep its value. + true + ; + WordAligned = not_word_aligned, + % Whether want to record that a type is word aligned + % only if *all* its definitions are word aligned. + ( + OldWordAligned = word_aligned, + map.det_update(UnqualTypeCtor, WordAligned, !WordAlignedMap) + ; + OldWordAligned = not_word_aligned + % No update needed; the map already has the right value. + ) + ) + else + map.det_insert(UnqualTypeCtor, WordAligned, !WordAlignedMap) + ). + +%---------------------% + +:- pred record_foreign_type(item_type_defn_info::in, + type_repn_map::in, type_repn_map::out) is det. + +record_foreign_type(ForeignTypeDefnInfo, !TypeRepnMap) :- + ForeignTypeDefnInfo = item_type_defn_info(TypeCtorSymName, TypeParams, + ForeignTypeDefn, _TVarSet, _Context, _SeqNum), + TypeCtorName = unqualify_name(TypeCtorSymName), + UnqualTypeCtor = unqual_type_ctor(TypeCtorName, list.length(TypeParams)), + ( + ForeignTypeDefn = parse_tree_foreign_type(ForeignDetails), + ForeignDetails = + type_details_foreign(LangType, _MaybeCanonical, Assertions), + ( LangType = c(c_type(TypeName)), Lang = lang_c + ; LangType = java(java_type(TypeName)), Lang = lang_java + ; LangType = csharp(csharp_type(TypeName)), Lang = lang_csharp + ; LangType = erlang(erlang_type), Lang = lang_erlang, TypeName = "" + ), + Repn = foreign_type_repn(TypeName, Assertions), + LangRepn = Lang - Repn, + ( if map.search(!.TypeRepnMap, UnqualTypeCtor, OldTypeRepn) then + ( + OldTypeRepn = dofr_du(DuRepn), + NewForeignLangRepns = one_or_more(LangRepn, []), + NewTypeRepn = + dofr_maybe_foreign(NewForeignLangRepns, yes(DuRepn)) + ; + OldTypeRepn = + dofr_maybe_foreign(OldForeignLangRepns, MaybeDuRepn), + list.foldl(gather_used_foreign_languages, + one_or_more_to_list(OldForeignLangRepns), + set.init, OldLangs), + ( if set.contains(OldLangs, Lang) then + % This is the second (or third, or ...) definition + % of this type constructor in this language. + % This is an error, so the .int3 file we are now + % generating will have to be rebuilt after the + % programmer fixes the error. To avoid confusing + % the readers of the .int3 file we are generating + % now, we ignore any duplicate definitions. + NewTypeRepn = OldTypeRepn + else + NewForeignLangRepns = + one_or_more_cons(LangRepn, OldForeignLangRepns), + NewTypeRepn = + dofr_maybe_foreign(NewForeignLangRepns, MaybeDuRepn) + ) + ), + map.det_update(UnqualTypeCtor, NewTypeRepn, !TypeRepnMap) + else + OoMLangRepns = one_or_more(LangRepn, []), + NewTypeRepn = dofr_maybe_foreign(OoMLangRepns, no), + map.det_insert(UnqualTypeCtor, NewTypeRepn, !TypeRepnMap) + ) + ; + ( ForeignTypeDefn = parse_tree_du_type(_) + ; ForeignTypeDefn = parse_tree_abstract_type(_) + ; ForeignTypeDefn = parse_tree_eqv_type(_) + ; ForeignTypeDefn = parse_tree_solver_type(_) + ), + unexpected($pred, "ForeignTypeDefnInfo not foreign") + ). + +%---------------------------------------------------------------------------% +% +% Auxiliary functions and predicates. +% + +:- pred ctors_are_all_constants(list(constructor)::in, list(string)::out) + is semidet. + +ctors_are_all_constants([], []). +ctors_are_all_constants([Ctor | Ctors], [Name | Names]) :- + ctor_is_constant(Ctor, Name), + ctors_are_all_constants(Ctors, Names). + +:- pred ctor_is_constant(constructor::in, string::out) is semidet. + +ctor_is_constant(Ctor, Name) :- + Ctor = ctor(_Ordinal, MaybeExistConstraints, SymName, Args, Arity, + _Context), + MaybeExistConstraints = no_exist_constraints, + Args = [], + Arity = 0, + Name = unqualify_name(SymName). + +:- pred separate_out_constants(list(constructor)::in, + list(constructor)::out, list(constructor)::out) is det. + +separate_out_constants([], [], []). +separate_out_constants([Ctor | Ctors], Constants, Functors) :- + separate_out_constants(Ctors, ConstantsTail, FunctorsTail), + Args = Ctor ^ cons_args, + % XXX TYPE_REPN Consider changing the representation of constructors + % to encode the invariant (no arguments -> no_exist_constraints) + % in the data structure. + ( if + Args = [], + Ctor ^ cons_maybe_exist = no_exist_constraints + then + Constants = [Ctor | ConstantsTail], + Functors = FunctorsTail + else + Constants = ConstantsTail, + Functors = [Ctor | FunctorsTail] + ). + +%---------------------------------------------------------------------------% +:- end_module parse_tree.decide_type_repn. +%---------------------------------------------------------------------------% diff --git a/compiler/det_report.m b/compiler/det_report.m index aedb1ca..94679fd 100644 --- a/compiler/det_report.m +++ b/compiler/det_report.m @@ -1634,7 +1634,8 @@ find_missing_cons_ids(DetInfo, MaybeLimit, InstMap0, SwitchContexts, TypeBody = hlds_du_type(TypeConstructors, _, _, _) then SortedTypeConsIds = - constructor_cons_ids(VarTypeCtor, TypeConstructors), + constructor_cons_ids(VarTypeCtor, + one_or_more_to_list(TypeConstructors)), set_tree234.sorted_list_to_set(SortedTypeConsIds, TypeConsIdsSet), set_tree234.intersect(TypeConsIdsSet, BoundConsIdsSet, @@ -1647,7 +1648,8 @@ find_missing_cons_ids(DetInfo, MaybeLimit, InstMap0, SwitchContexts, hlds_data.get_type_defn_body(TypeDefn, TypeBody), TypeBody = hlds_du_type(TypeConstructors, _, _, _), SortedTypeConsIds = - constructor_cons_ids(VarTypeCtor, TypeConstructors), + constructor_cons_ids(VarTypeCtor, + one_or_more_to_list(TypeConstructors)), set_tree234.sorted_list_to_set(SortedTypeConsIds, TypeConsIdsSet), PossibleConsIdsSet = TypeConsIdsSet ) diff --git a/compiler/du_type_layout.m b/compiler/du_type_layout.m index 80083c6..9d43ab5 100644 --- a/compiler/du_type_layout.m +++ b/compiler/du_type_layout.m @@ -70,7 +70,7 @@ % should be done by unsafe-casting both to int, and comparing the ints. % If we cannot, then we should generate the usual code deconstructing % both X and Y, and comparing the arguments (one by one or all together, -% depending on well we can pack the heap cell's contents). +% depending on how well we can pack the heap cell's contents). % % Deciding type representations after semantic analysis would therefore % require us to generate the unify and compare (and maybe index) predicates @@ -513,10 +513,10 @@ decide_if_simple_du_type(ModuleInfo, Params, TypeCtorToForeignEnumMap, TypeCtorTypeDefn0 = TypeCtor - TypeDefn0, get_type_defn_body(TypeDefn0, Body0), ( - Body0 = hlds_du_type(Ctors, MaybeCanonical, MaybeRepn0, + Body0 = hlds_du_type(OoMCtors, MaybeCanonical, MaybeRepn0, MaybeForeign), + OoMCtors = one_or_more(HeadCtor, TailCtors), expect(unify(MaybeRepn0, no), $pred, "MaybeRepn0 != no"), - expect_not(unify(Ctors, []), $pred, "Ctors != []"), ( if map.search(TypeCtorToForeignEnumMap, TypeCtor, TCFE), TCFE = type_ctor_foreign_enums(_LangContextMap, @@ -524,17 +524,18 @@ decide_if_simple_du_type(ModuleInfo, Params, TypeCtorToForeignEnumMap, MaybeForeignEnumTagMap = yes(ForeignEnumTagMap) then decide_simple_type_foreign_enum(ModuleInfo, Params, - TypeCtor, TypeDefn0, Body0, Ctors, ForeignEnumTagMap, + TypeCtor, TypeDefn0, Body0, OoMCtors, ForeignEnumTagMap, TypeCtorTypeDefn, !Specs) else if - ctors_are_all_constants(Ctors) + ctors_are_all_constants([HeadCtor | TailCtors]) then decide_simple_type_dummy_or_mercury_enum(ModuleInfo, Params, - TypeCtor, TypeDefn0, Body0, Ctors, TypeCtorTypeDefn, + TypeCtor, TypeDefn0, Body0, OoMCtors, TypeCtorTypeDefn, !ComponentTypeMap, !Specs) else if - Ctors = [SingleCtor] + TailCtors = [] then + SingleCtor = HeadCtor, ( if SingleCtor = ctor(_Ordinal, no_exist_constraints, SingleCtorSymName, [SingleArg], 1, SingleCtorContext), @@ -581,12 +582,12 @@ decide_if_simple_du_type(ModuleInfo, Params, TypeCtorToForeignEnumMap, :- pred decide_simple_type_foreign_enum(module_info::in, decide_du_params::in, type_ctor::in, hlds_type_defn::in, hlds_type_body::in(hlds_du_type), - list(constructor)::in, {cons_id_to_tag_map, foreign_language}::in, + one_or_more(constructor)::in, {cons_id_to_tag_map, foreign_language}::in, pair(type_ctor, hlds_type_defn)::out, list(error_spec)::in, list(error_spec)::out) is det. decide_simple_type_foreign_enum(_ModuleInfo, Params, TypeCtor, TypeDefn0, - Body0, Ctors, ForeignEnums, TypeCtorTypeDefn, !Specs) :- + Body0, OoMCtors, ForeignEnums, TypeCtorTypeDefn, !Specs) :- % XXX TYPE_REPN Should MaybeForeign = yes(...) be allowed? ForeignEnums = {ForeignEnumTagMap, Lang}, DuKind = du_type_kind_foreign_enum(Lang), @@ -603,6 +604,7 @@ decide_simple_type_foreign_enum(_ModuleInfo, Params, TypeCtor, TypeDefn0, else true ), + Ctors = one_or_more_to_list(OoMCtors), ( if ctors_are_all_constants(Ctors) then true else @@ -654,20 +656,18 @@ add_dummy_repn_to_ctor_arg(ConsArg) = ConsArgRepn :- :- pred decide_simple_type_dummy_or_mercury_enum(module_info::in, decide_du_params::in, type_ctor::in, hlds_type_defn::in, - hlds_type_body::in(hlds_du_type), list(constructor)::in, + hlds_type_body::in(hlds_du_type), one_or_more(constructor)::in, pair(type_ctor, hlds_type_defn)::out, component_type_map::in, component_type_map::out, list(error_spec)::in, list(error_spec)::out) is det. decide_simple_type_dummy_or_mercury_enum(_ModuleInfo, Params, - TypeCtor, TypeDefn0, Body0, Ctors, TypeCtorTypeDefn, + TypeCtor, TypeDefn0, Body0, OoMCtors, TypeCtorTypeDefn, !ComponentTypeMap, !Specs) :- + OoMCtors = one_or_more(HeadCtor, TailCtors), ( - Ctors = [], - % A type with no constructors is an abstract type, not a du type. - unexpected($pred, "no constant constructors") - ; - Ctors = [SingleCtor], + TailCtors = [], + SingleCtor = HeadCtor, DuTypeKind = du_type_kind_direct_dummy, SingleCtor = ctor(Ordinal, _MaybeExistConstraints, SingleCtorSymName, _Args, _SingleCtorArity, SingleCtorContext), @@ -678,10 +678,10 @@ decide_simple_type_dummy_or_mercury_enum(_ModuleInfo, Params, insert_ctor_repn_into_map(SingleCtorRepn, map.init, CtorRepnMap), ComponentKind = packable(packable_dummy) ; - Ctors = [_, _ | _], + TailCtors = [_ | _], DuTypeKind = du_type_kind_mercury_enum, - assign_tags_to_enum_constants(Ctors, CtorRepns, 0, NextTag, - map.init, CtorRepnMap), + assign_tags_to_enum_constants([HeadCtor | TailCtors], CtorRepns, + 0, NextTag, map.init, CtorRepnMap), int.log2(NextTag, NumBits), ComponentKind = packable(packable_n_bits(NumBits, fill_enum)) ), @@ -905,7 +905,8 @@ decide_if_complex_du_type(ModuleInfo, Params, ComponentTypeMap, TypeCtorTypeDefn0 = TypeCtor - TypeDefn0, get_type_defn_body(TypeDefn0, Body0), ( - Body0 = hlds_du_type(Ctors, _MaybeCanonical, MaybeRepn0, _MaybeForeign), + Body0 = hlds_du_type(Ctors, _MaybeCanonical, MaybeRepn0, + _MaybeForeign), ( MaybeRepn0 = yes(_), % We have already decided this type's representation @@ -914,7 +915,7 @@ decide_if_complex_du_type(ModuleInfo, Params, ComponentTypeMap, ; MaybeRepn0 = no, decide_complex_du_type(ModuleInfo, Params, ComponentTypeMap, - TypeCtor, TypeDefn0, Ctors, Repn, !Specs), + TypeCtor, TypeDefn0, one_or_more_to_list(Ctors), Repn, !Specs), Body = Body0 ^ du_type_repn := yes(Repn), set_type_defn_body(Body, TypeDefn0, TypeDefn), TypeCtorTypeDefn = TypeCtor - TypeDefn diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m index 03f4b6f..f06dd33 100644 --- a/compiler/equiv_type.m +++ b/compiler/equiv_type.m @@ -83,7 +83,8 @@ is det. :- pred replace_in_ctors(type_eqv_map::in, - list(constructor)::in, list(constructor)::out, tvarset::in, tvarset::out, + one_or_more(constructor)::in, one_or_more(constructor)::out, + tvarset::in, tvarset::out, eqv_expanded_info::in, eqv_expanded_info::out) is det. :- type eqv_type_body @@ -844,11 +845,11 @@ replace_in_type_defn(MaybeRecord, TypeEqvMap, InstEqvMap, TypeCtor, TypeDefn = parse_tree_eqv_type(DetailsEqv) ; TypeDefn0 = parse_tree_du_type(DetailsDu0), - DetailsDu0 = type_details_du(TypeBody0, EqPred, DirectArgFunctors), - replace_in_ctors_location(MaybeRecord, TypeEqvMap, TypeBody0, TypeBody, + DetailsDu0 = type_details_du(Ctors0, EqPred, DirectArgFunctors), + replace_in_ctors_location(MaybeRecord, TypeEqvMap, Ctors0, Ctors, !VarSet, !EquivTypeInfo, !UsedModules), ContainsCirc = no, - DetailsDu = type_details_du(TypeBody, EqPred, DirectArgFunctors), + DetailsDu = type_details_du(Ctors, EqPred, DirectArgFunctors), TypeDefn = parse_tree_du_type(DetailsDu) ; TypeDefn0 = parse_tree_solver_type(DetailsSolver0), @@ -1021,14 +1022,20 @@ replace_in_ctors(TypeEqvMap, !Ctors, !VarSet, !EquivTypeInfo) :- !Ctors, !VarSet, !EquivTypeInfo, used_modules_init, _). :- pred replace_in_ctors_location(maybe_record_sym_name_use::in, - type_eqv_map::in, list(constructor)::in, list(constructor)::out, + type_eqv_map::in, + one_or_more(constructor)::in, one_or_more(constructor)::out, tvarset::in, tvarset::out, eqv_expanded_info::in, eqv_expanded_info::out, used_modules::in, used_modules::out) is det. -replace_in_ctors_location(MaybeRecord, TypeEqvMap, !Ctors, !VarSet, +replace_in_ctors_location(MaybeRecord, TypeEqvMap, Ctors0, Ctors, !VarSet, !EquivTypeInfo, !UsedModules) :- - list.map_foldl3(replace_in_ctor(MaybeRecord, TypeEqvMap), !Ctors, !VarSet, - !EquivTypeInfo, !UsedModules). + Ctors0 = one_or_more(HeadCtor0, TailCtors0), + replace_in_ctor(MaybeRecord, TypeEqvMap, HeadCtor0, HeadCtor, + !VarSet, !EquivTypeInfo, !UsedModules), + list.map_foldl3(replace_in_ctor(MaybeRecord, TypeEqvMap), + TailCtors0, TailCtors, + !VarSet, !EquivTypeInfo, !UsedModules), + Ctors = one_or_more(HeadCtor, TailCtors). :- pred replace_in_ctor(maybe_record_sym_name_use::in, type_eqv_map::in, constructor::in, constructor::out, tvarset::in, tvarset::out, diff --git a/compiler/get_dependencies.m b/compiler/get_dependencies.m index 344a2eb..cbcc18e 100644 --- a/compiler/get_dependencies.m +++ b/compiler/get_dependencies.m @@ -584,11 +584,8 @@ get_implicits_foreigns_fact_tables_acc([Item | Items], ; Item = item_mode_decl(_) ; Item = item_typeclass(_) ; Item = item_foreign_import_module(_) + ; Item = item_type_repn(_) ) - ; - Item = item_type_repn(_), - % These should not be generated yet. - unexpected($pred, "item_type_repn") ), get_implicits_foreigns_fact_tables_acc(Items, !ImplicitImportNeeds, !Contents). @@ -720,11 +717,8 @@ gather_implicit_import_needs_in_items([Item | Items], !ImplicitImportNeeds) :- ; Item = item_initialise(_) ; Item = item_finalise(_) ; Item = item_foreign_import_module(_) + ; Item = item_type_repn(_) ) - ; - Item = item_type_repn(_), - % XXX TYPE_REPN Implement this. - unexpected($pred, "item_type_repn nyi") ), gather_implicit_import_needs_in_items(Items, !ImplicitImportNeeds). diff --git a/compiler/hlds_data.m b/compiler/hlds_data.m index db8b307..01962c7 100644 --- a/compiler/hlds_data.m +++ b/compiler/hlds_data.m @@ -745,7 +745,7 @@ map_foldl_over_type_ctor_defns_2(Pred, _Name, !TypeCtorTable, !Acc) :- :- type hlds_type_body ---> hlds_du_type( % The ctors for this type. - du_type_ctors :: list(constructor), + du_type_ctors :: one_or_more(constructor), % Does this type have user-defined equality and comparison % predicates? diff --git a/compiler/hlds_out_module.m b/compiler/hlds_out_module.m index 2a170ab..b4f54f4 100644 --- a/compiler/hlds_out_module.m +++ b/compiler/hlds_out_module.m @@ -370,7 +370,8 @@ write_type_body(Info, _TypeCtor, TypeBody, Indent, TVarSet, !IO) :- MercInfo = Info ^ hoi_mercury_to_mercury, ( MaybeRepn = no, - write_constructors(TVarSet, Indent, Ctors, !IO), + Ctors = one_or_more(HeadCtor, TailCtors), + write_constructors(TVarSet, Indent, HeadCtor, TailCtors, !IO), MaybeDirectArgCtors = no, mercury_output_where_attributes(MercInfo, TVarSet, MaybeSolverTypeDetails, MaybeUserEqComp, MaybeDirectArgCtors, @@ -491,18 +492,12 @@ accumulate_ctor_repns(one_or_more(HeadCR, TailCRs), !AccCRs) :- !:AccCRs = [HeadCR | TailCRs] ++ !.AccCRs. :- pred write_constructors(tvarset::in, int::in, - list(constructor)::in, io::di, io::uo) is det. + constructor::in, list(constructor)::in, io::di, io::uo) is det. -write_constructors(TVarSet, Indent, Ctors, !IO) :- - ( - Ctors = [], - unexpected($pred, "empty constructor list") - ; - Ctors = [HeadCtor | TailCtors], - ArrowOrSemi0 = "---> ", - write_constructors_loop(TVarSet, Indent, ArrowOrSemi0, - HeadCtor, TailCtors, !IO) - ). +write_constructors(TVarSet, Indent, HeadCtor, TailCtors, !IO) :- + ArrowOrSemi0 = "---> ", + write_constructors_loop(TVarSet, Indent, ArrowOrSemi0, + HeadCtor, TailCtors, !IO). :- pred write_constructor_repns(tvarset::in, int::in, list(constructor_repn)::in, io::di, io::uo) is det. diff --git a/compiler/inst_check.m b/compiler/inst_check.m index 168beda..3fb67a1 100644 --- a/compiler/inst_check.m +++ b/compiler/inst_check.m @@ -185,7 +185,8 @@ get_du_functors_for_type_def(TypeDefn, Functors) :- get_type_defn_body(TypeDefn, TypeDefnBody), ( TypeDefnBody = hlds_du_type(Constructors, _, _, _), - list.map(constructor_to_functor_name_and_arity, Constructors, Functors) + list.map(constructor_to_functor_name_and_arity, + one_or_more_to_list(Constructors), Functors) ; ( TypeDefnBody = hlds_eqv_type(_) ; TypeDefnBody = hlds_foreign_type(_) @@ -491,7 +492,8 @@ check_for_type_bound_insts(ForTypeKind, [BoundInst | BoundInsts], ForTypeKind = ftk_user(TypeCtor, TypeDefn), get_type_defn_body(TypeDefn, TypeDefnBody), ( - TypeDefnBody = hlds_du_type(Constructors, _, _, _), + TypeDefnBody = hlds_du_type(OoMConstructors, _, _, _), + Constructors = one_or_more_to_list(OoMConstructors), ( ConsSymName = unqualified(ConsName), find_ctors_with_given_name(ConsName, Constructors, @@ -1192,7 +1194,9 @@ diagnose_mismatches_from_type(BoundInsts, TypeDefnOrBuiltin, TypeCtorAndDefn = type_ctor_and_defn(_TypeCtor, TypeDefn), get_type_defn_body(TypeDefn, TypeDefnBody), ( - TypeDefnBody = hlds_du_type(Constructors, _, _, _) + TypeDefnBody = hlds_du_type(Constructors, _, _, _), + find_mismatches_from_user(one_or_more_to_list(Constructors), 1, + BoundInsts, 0, NumMismatches, cord.init, MismatchPiecesCord) ; ( TypeDefnBody = hlds_eqv_type(_) ; TypeDefnBody = hlds_foreign_type(_) @@ -1200,9 +1204,7 @@ diagnose_mismatches_from_type(BoundInsts, TypeDefnOrBuiltin, ; TypeDefnBody = hlds_abstract_type(_) ), unexpected($pred, "non-du TypeDefnBody") - ), - find_mismatches_from_user(Constructors, 1, BoundInsts, - 0, NumMismatches, cord.init, MismatchPiecesCord) + ) ; TypeDefnOrBuiltin = type_builtin(BuiltinType), find_mismatches_from_builtin(BuiltinType, 1, BoundInsts, diff --git a/compiler/intermod.m b/compiler/intermod.m index 2a978d0..c13f37d 100644 --- a/compiler/intermod.m +++ b/compiler/intermod.m @@ -1660,14 +1660,24 @@ intermod_write_type(OutInfo, TypeCtor - TypeDefn, !IO) :- list.foldl(gather_foreign_enum_value_pair, CtorRepns, [], RevForeignEnumVals), list.reverse(RevForeignEnumVals, ForeignEnumVals), - FEInfo = pragma_info_foreign_enum(Lang, TypeCtor, ForeignEnumVals), - ForeignPragma = pragma_foreign_enum(FEInfo), - % The pragma's origin isn't printed, so what origin we pass here - % doesn't matter. - ForeignItemPragma = item_pragma_info(ForeignPragma, item_origin_user, - Context, -1), - ForeignItem = item_pragma(ForeignItemPragma), - mercury_output_item(MercInfo, ForeignItem, !IO) + ( + ForeignEnumVals = [] + % This can only happen if the type has no function symbols. + % which should have been detected and reported by now. + ; + ForeignEnumVals = [HeadForeignEnumVal | TailForeignEnumVals], + OoMForeignEnumVals = + one_or_more(HeadForeignEnumVal, TailForeignEnumVals), + FEInfo = pragma_info_foreign_enum(Lang, TypeCtor, + OoMForeignEnumVals), + ForeignPragma = pragma_foreign_enum(FEInfo), + % The pragma's origin isn't printed, so what origin we pass here + % doesn't matter. + ForeignItemPragma = item_pragma_info(ForeignPragma, + item_origin_user, Context, -1), + ForeignItem = item_pragma(ForeignItemPragma), + mercury_output_item(MercInfo, ForeignItem, !IO) + ) else true ). diff --git a/compiler/mmakefiles.m b/compiler/mmakefiles.m index f34da4a..ac6ba92 100644 --- a/compiler/mmakefiles.m +++ b/compiler/mmakefiles.m @@ -511,10 +511,6 @@ write_mmake_entry(OutStream, _WriteComments, MmakeEntry, !IO) :- write_block_comment_line(OutStream, Comment, !IO) :- io.format(OutStream, "# %s\n", [s(Comment)], !IO). -:- func one_or_more_to_list(one_or_more(T)) = list(T). - -one_or_more_to_list(one_or_more(Head, Tail)) = [Head | Tail]. - :- pred maybe_write_group_names(io.text_output_stream::in, string::in, list(mmake_file_name_group)::in, io::di, io::uo) is det. diff --git a/compiler/mode_util.m b/compiler/mode_util.m index 318289f..a83f249 100644 --- a/compiler/mode_util.m +++ b/compiler/mode_util.m @@ -1106,7 +1106,7 @@ propagate_ctor_info_into_bound_inst(ModuleInfo, Type, Inst0, Inst) :- search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn), hlds_data.get_type_defn_tparams(TypeDefn, TypeParams), hlds_data.get_type_defn_body(TypeDefn, TypeBody), - Constructors = TypeBody ^ du_type_ctors + OoMConstructors = TypeBody ^ du_type_ctors then ( if InstResults0 = inst_test_results(_, _, _, _, _, PropagatedResult0), @@ -1120,6 +1120,7 @@ propagate_ctor_info_into_bound_inst(ModuleInfo, Type, Inst0, Inst) :- ConstructNewInst = no else map.from_corresponding_lists(TypeParams, TypeArgs, ArgSubst), + Constructors = one_or_more_to_list(OoMConstructors), propagate_ctor_info_into_bound_functors(ModuleInfo, ArgSubst, TypeCtor, TypeModule, Constructors, BoundInsts0, BoundInsts1), list.sort(BoundInsts1, BoundInsts), diff --git a/compiler/module_qual.qualify_items.m b/compiler/module_qual.qualify_items.m index 088b9bb..8f480b2 100644 --- a/compiler/module_qual.qualify_items.m +++ b/compiler/module_qual.qualify_items.m @@ -326,6 +326,7 @@ module_qualify_item(InInt, Item0, Item, !Info, !Specs) :- ( RepInfo0 = tcrepn_is_direct_dummy ; RepInfo0 = tcrepn_is_notag ; RepInfo0 = tcrepn_fits_in_n_bits(_, _) + ; RepInfo0 = tcrepn_is_word_aligned_ptr ; RepInfo0 = tcrepn_has_direct_arg_functors(_) ; RepInfo0 = tcrepn_maybe_foreign(_, _) ; RepInfo0 = tcrepn_du(_) @@ -339,25 +340,6 @@ module_qualify_item(InInt, Item0, Item, !Info, !Specs) :- qualify_type(InInt, ErrorContext, EqvType0, EqvType, !Info, !Specs), RepInfo = tcrepn_is_eqv_to(EqvType) - ; - RepInfo0 = tcrepn_is_word_aligned_ptr(WAP0), - ( - WAP0 = wap_foreign_type_assertion, - WAP = WAP0 - ; - WAP0 = wap_mercury_type(WAPTypeSNA0), - list.length(ArgTVars, TypeCtorArity), - TypeCtor = type_ctor(TypeCtorSymName, TypeCtorArity), - ErrorContext = mqec_type_repn(Context, TypeCtor), - WAPTypeSNA0 = sym_name_arity(SymName0, Arity), - TypeCtorId0 = mq_id(SymName0, Arity), - mq_info_get_types(!.Info, Types), - find_unique_match(InInt, ErrorContext, Types, type_id, - TypeCtorId0, SymName, !Info, !Specs), - WAPTypeSNA = sym_name_arity(SymName, Arity), - WAP = wap_mercury_type(WAPTypeSNA) - ), - RepInfo = tcrepn_is_word_aligned_ptr(WAP) ), ItemTypeRepnInfo = item_type_repn_info(TypeCtorSymName, ArgTVars, RepInfo, TVarSet, Context, SeqNum), @@ -386,16 +368,21 @@ qualify_type_defn(InInt, Context, TypeCtor, TypeDefn0, TypeDefn, !Info, !Specs) :- ( TypeDefn0 = parse_tree_du_type(DetailsDu0), - DetailsDu0 = type_details_du(Ctors0, MaybeUserEqComp0, + DetailsDu0 = type_details_du(OoMCtors0, MaybeUserEqComp0, MaybeDirectArgCtors0), - qualify_constructors(InInt, TypeCtor, Ctors0, Ctors, !Info, !Specs), + OoMCtors0 = one_or_more(HeadCtor0, TailCtors0), + qualify_constructor(InInt, TypeCtor, HeadCtor0, HeadCtor, + !Info, !Specs), + qualify_constructors(InInt, TypeCtor, TailCtors0, TailCtors, + !Info, !Specs), + OoMCtors = one_or_more(HeadCtor, TailCtors), % User-defined equality pred names will be converted into predicate % calls and then module-qualified after type analysis (during mode % analysis). That way, they get full type overloading resolution, etc. % Thus we don't module-qualify them here. MaybeUserEqComp = MaybeUserEqComp0, MaybeDirectArgCtors = MaybeDirectArgCtors0, - DetailsDu = type_details_du(Ctors, MaybeUserEqComp, + DetailsDu = type_details_du(OoMCtors, MaybeUserEqComp, MaybeDirectArgCtors), TypeDefn = parse_tree_du_type(DetailsDu) ; diff --git a/compiler/notes/compiler_design.html b/compiler/notes/compiler_design.html index b8d4fd1..173a9c2 100644 --- a/compiler/notes/compiler_design.html +++ b/compiler/notes/compiler_design.html @@ -459,6 +459,10 @@ such as pretty-printing. that belong in its .int file from those that don't.
+ decide_type_repn.m generates type_representation items + that we put into interface files. + +
modules.m figures out what interface files to read, and also does a bunch of other semi-related things. diff --git a/compiler/parse_pragma.m b/compiler/parse_pragma.m index 20cc789..da648a1 100644 --- a/compiler/parse_pragma.m +++ b/compiler/parse_pragma.m @@ -20,11 +20,14 @@ :- import_module libs.globals. :- import_module mdbcomp. :- import_module mdbcomp.sym_name. +:- import_module parse_tree.error_util. :- import_module parse_tree.maybe_error. :- import_module parse_tree.parse_types. :- import_module parse_tree.prog_data. +:- import_module cord. :- import_module list. +:- import_module set. :- import_module term. :- import_module varset. @@ -36,6 +39,11 @@ :- pred parse_pragma(module_name::in, varset::in, list(term)::in, prog_context::in, int::in, maybe1(item_or_marker)::out) is det. +:- pred parse_foreign_type_assertions(cord(format_component)::in, + varset::in, term::in, + set(foreign_type_assertion)::in, set(foreign_type_assertion)::out, + list(error_spec)::in, list(error_spec)::out) is det. + % Parse a term that represents a foreign language. % :- pred term_to_foreign_language(term::in, foreign_language::out) is semidet. @@ -48,7 +56,6 @@ :- import_module libs.compiler_util. :- import_module libs.rat. :- import_module mdbcomp.prim_data. -:- import_module parse_tree.error_util. :- import_module parse_tree.parse_inst_mode_name. :- import_module parse_tree.parse_sym_name. :- import_module parse_tree.parse_tree_out_term. @@ -65,11 +72,9 @@ :- import_module assoc_list. :- import_module bool. -:- import_module cord. :- import_module int. :- import_module maybe. :- import_module pair. -:- import_module set. :- import_module string. :- import_module unit. @@ -439,11 +444,6 @@ parse_pragma_foreign_type(ModuleName, VarSet, ErrorTerm, PragmaTerms, MaybeIOM = error1([Spec]) ). -:- pred parse_foreign_type_assertions(cord(format_component)::in, - varset::in, term::in, - set(foreign_type_assertion)::in, set(foreign_type_assertion)::out, - list(error_spec)::in, list(error_spec)::out) is det. - parse_foreign_type_assertions(ContextPieces, VarSet, Term, !Assertions, !Specs) :- ( if Term = term.functor(term.atom("[]"), [], _) then @@ -599,14 +599,17 @@ maybe_parse_export_enum_overrides(VarSet, yes(OverridesTerm), term::in, maybe1(pair(sym_name, string))::out) is semidet. parse_sym_name_string_pair(VarSet, ContextPieces, PairTerm, MaybePair) :- - PairTerm = functor(Functor, Args, _), + PairTerm = functor(Functor, ArgTerms, _), Functor = term.atom("-"), - Args = [SymNameTerm, StringTerm], + ArgTerms = [SymNameTerm, StringTerm], StringTerm = functor(term.string(String), _, _), parse_sym_name_and_args(VarSet, ContextPieces, SymNameTerm, MaybeSymNameResult), ( - MaybeSymNameResult = ok2(SymName, []), + MaybeSymNameResult = ok2(SymName, SymNameArgs), + SymNameArgs = [], + % XXX Instead of quietly failing, we should generate + % a specific error message if SymNameArgs is not []. MaybePair = ok1(SymName - String) ; MaybeSymNameResult = error2(Specs), @@ -723,7 +726,6 @@ parse_export_enum_attr(VarSet, Term, MaybeAttribute) :- parse_pragma_foreign_enum(VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM) :- ( if PragmaTerms = [LangTerm, MercuryTypeTerm, ValuesTerm] then - LangContextPieces = cord.from_list([ words("In first argument of"), pragma_decl("foreign_enum"), words("declaration:") @@ -747,11 +749,11 @@ parse_pragma_foreign_enum(VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, % (e.g. it should reject the empty string). convert_maybe_list("mapping elements", yes(VarSet), ValuesTerm, parse_sym_name_string_pair(VarSet, PairContextPieces), - UnrecognizedPieces, MaybeValues0), + UnrecognizedPieces, MaybeValues), ( - MaybeValues0 = ok1(Values0), + MaybeValues = ok1(Values), ( - Values0 = [], + Values = [], NoValuesPieces = [ words("Error: expected a non-empty list"), words("mapping constructors to foreign values in"), @@ -761,22 +763,23 @@ parse_pragma_foreign_enum(VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, phase_term_to_parse_tree, [simple_msg(get_term_context(ValuesTerm), [always(NoValuesPieces)])]), - MaybeValues = error1([NoValuesSpec]) + MaybeOoMValues = error1([NoValuesSpec]) ; - Values0 = [_ | _], - MaybeValues = MaybeValues0 + Values = [HeadValue | TailValues], + MaybeOoMValues = ok1(one_or_more(HeadValue, TailValues)) ) ; - MaybeValues0 = error1(_), - MaybeValues = MaybeValues0 + MaybeValues = error1(ValuesSpecs), + MaybeOoMValues = error1(ValuesSpecs) ), ( if MaybeForeignLang = ok1(ForeignLang), MaybeTypeCtor = ok1(TypeCtor), - MaybeValues = ok1(Values) + MaybeOoMValues = ok1(OoMValues) then - FEInfo = pragma_info_foreign_enum(ForeignLang, TypeCtor, Values), + FEInfo = + pragma_info_foreign_enum(ForeignLang, TypeCtor, OoMValues), Pragma = pragma_foreign_enum(FEInfo), ItemPragma = item_pragma_info(Pragma, item_origin_user, Context, SeqNum), @@ -785,7 +788,7 @@ parse_pragma_foreign_enum(VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, else Specs = get_any_errors1(MaybeForeignLang) ++ get_any_errors1(MaybeTypeCtor) ++ - get_any_errors1(MaybeValues), + get_any_errors1(MaybeOoMValues), MaybeIOM = error1(Specs) ) else diff --git a/compiler/parse_tree.m b/compiler/parse_tree.m index 3df6e6d..d42c50f 100644 --- a/compiler/parse_tree.m +++ b/compiler/parse_tree.m @@ -83,6 +83,9 @@ :- include_module prog_type_subst. :- include_module prog_util. +% Type representation. +:- include_module decide_type_repn. + % Transformations that act on the parse tree, % and stuff relating to the module system. :- include_module canonicalize_interface. diff --git a/compiler/parse_tree_out.m b/compiler/parse_tree_out.m index ae23ae1..d79eaf7 100644 --- a/compiler/parse_tree_out.m +++ b/compiler/parse_tree_out.m @@ -663,10 +663,11 @@ mercury_output_item_type_defn(Info, ItemTypeDefn, !IO) :- io.write_string(".\n", !IO) ; TypeDefn = parse_tree_du_type(DetailsDu), - DetailsDu = type_details_du(Ctors, MaybeCanonical, MaybeDirectArgs), + DetailsDu = type_details_du(OoMCtors, MaybeCanonical, MaybeDirectArgs), mercury_output_begin_type_decl(non_solver_type, !IO), mercury_output_term(TypeVarSet, print_name_only, TypeTerm, !IO), - mercury_output_ctors(TypeVarSet, yes, Ctors, !IO), + OoMCtors = one_or_more(HeadCtor, TailCtors), + mercury_output_ctors(TypeVarSet, yes, HeadCtor, TailCtors, !IO), mercury_output_where_attributes(Info, TypeVarSet, no, MaybeCanonical, MaybeDirectArgs, !IO), io.write_string(".\n", !IO) @@ -879,11 +880,10 @@ mercury_output_where_abstract_enum_type(NumBits, !IO) :- % Predicates needed to output discriminated union types. % -:- pred mercury_output_ctors(tvarset::in, bool::in, list(constructor)::in, - io::di, io::uo) is det. +:- pred mercury_output_ctors(tvarset::in, bool::in, + constructor::in, list(constructor)::in, io::di, io::uo) is det. -mercury_output_ctors(_, _, [], !IO). -mercury_output_ctors(VarSet, First, [Ctor | Ctors], !IO) :- +mercury_output_ctors(VarSet, First, HeadCtor, TailCtors, !IO) :- ( First = yes, io.write_string("\n ---> ", !IO) @@ -891,8 +891,13 @@ mercury_output_ctors(VarSet, First, [Ctor | Ctors], !IO) :- First = no, io.write_string("\n ; ", !IO) ), - mercury_output_ctor(VarSet, Ctor, !IO), - mercury_output_ctors(VarSet, no, Ctors, !IO). + mercury_output_ctor(VarSet, HeadCtor, !IO), + ( + TailCtors = [] + ; + TailCtors = [HeadTailCtor | TailTailCtors], + mercury_output_ctors(VarSet, no, HeadTailCtor, TailTailCtors, !IO) + ). mercury_output_ctor(TypeVarSet, Ctor, !IO) :- Ctor = ctor(_Ordinal, MaybeExistConstraints, SymName, Args, Arity, _Ctxt), @@ -1508,10 +1513,16 @@ mercury_output_item_type_repn(_Info, ItemTypeRepn, !IO) :- TVarSet, _Context, _SeqNum), io.write_string(":- type_representation(", !IO), mercury_output_sym_name(TypeCtorSymName, !IO), - io.write_string(", [", !IO), - io.write_list(ArgTVars, ", ", - mercury_output_var(TVarSet, print_num_only), !IO), - io.write_string("], ", !IO), + ( + ArgTVars = [], + io.write_string(", ", !IO) + ; + ArgTVars = [_ | _], + io.write_string("(", !IO), + io.write_list(ArgTVars, ", ", + mercury_output_var(TVarSet, print_num_only), !IO), + io.write_string("), ", !IO) + ), ( RepnInfo = tcrepn_is_direct_dummy, io.write_string("is_direct_dummy", !IO) @@ -1532,18 +1543,8 @@ mercury_output_item_type_repn(_Info, ItemTypeRepn, !IO) :- mercury_output_type(TVarSet, print_num_only, EqvType, !IO), io.write_string(")", !IO) ; - RepnInfo = tcrepn_is_word_aligned_ptr(WAP), - io.write_string("is_word_aligned_ptr(", !IO), - ( - WAP = wap_foreign_type_assertion, - io.write_string("foreign_type_assertion", !IO) - ; - WAP = wap_mercury_type(SymNameAndArity), - io.write_string("mercury_type(", !IO), - write_sym_name_and_arity(SymNameAndArity, !IO), - io.write_string(")", !IO) - ), - io.write_string(")", !IO) + RepnInfo = tcrepn_is_word_aligned_ptr, + io.write_string("is_word_aligned_ptr", !IO) ; RepnInfo = tcrepn_has_direct_arg_functors(SymNameAndArities), io.write_string("has_direct_arg_functors([", !IO), @@ -1569,7 +1570,8 @@ mercury_output_item_type_repn(_Info, ItemTypeRepn, !IO) :- io.write_string("du_repn(", !IO), mercury_output_du_type_repn(DuRepn, !IO), io.write_string(")", !IO) - ) + ), + io.write_string(")", !IO) ), io.write_string(").\n", !IO). @@ -1683,12 +1685,26 @@ mercury_output_foreign_langs_enums(LangEnums, LangsEnums, !IO) :- mercury_output_foreign_langs_types(LangTypeRepn, LangsTypeRepns, !IO) :- LangTypeRepn = Lang - TypeRepn, - TypeRepn = foreign_type_repn(ForeignTypeName), - % XXX Document the requirements on foreign type names - % that make the absence of quoting ok here and elsewhere. - % XXX Do we actually accept foreign type names for Erlang? - simple_foreign_language_string(Lang, LangStr), - io.format("%s(%s)", [s(LangStr), s(ForeignTypeName)], !IO), + TypeRepn = foreign_type_repn(ForeignTypeName, ForeignTypeAssertions), + ForeignTypeAssertions = foreign_type_assertions(Assertions), + set.to_sorted_list(Assertions, AssertionsList), + ( + ( Lang = lang_c, LangStr = "c" + ; Lang = lang_csharp, LangStr = "csharp" + ; Lang = lang_java, LangStr = "java" + ), + io.format("%s(\"%s\", [", [s(LangStr), s(ForeignTypeName)], !IO), + io.write_list(AssertionsList, ", ", + mercury_output_foreign_type_assertion, !IO), + io.write_string("])", !IO) + ; + Lang = lang_erlang, + LangStr = "erlang", + io.format("%s([", [s(LangStr)], !IO), + io.write_list(AssertionsList, ", ", + mercury_output_foreign_type_assertion, !IO), + io.write_string("])", !IO) + ), ( LangsTypeRepns = [] ; diff --git a/compiler/parse_tree_out_pragma.m b/compiler/parse_tree_out_pragma.m index 4191295..b5e2a94 100644 --- a/compiler/parse_tree_out_pragma.m +++ b/compiler/parse_tree_out_pragma.m @@ -837,7 +837,7 @@ mercury_format_pragma_foreign_export_enum_attributes(Attributes, !U) :- U::di, U::uo) is det <= output(U). mercury_format_pragma_foreign_enum(FEInfo, !U) :- - FEInfo = pragma_info_foreign_enum(Lang, TypeCtor, Values), + FEInfo = pragma_info_foreign_enum(Lang, TypeCtor, OoMValues), add_string(":- pragma foreign_enum(", !U), mercury_format_foreign_language_string(Lang, !U), add_string(", ", !U), @@ -846,6 +846,7 @@ mercury_format_pragma_foreign_enum(FEInfo, !U) :- add_string("/", !U), add_int(TypeArity, !U), add_string(", ", !U), + Values = one_or_more_to_list(OoMValues), mercury_format_sym_name_string_assoc_list(Values, !U), add_string(").\n", !U). diff --git a/compiler/parse_type_defn.m b/compiler/parse_type_defn.m index 575c4a3..16f19a5 100644 --- a/compiler/parse_type_defn.m +++ b/compiler/parse_type_defn.m @@ -203,7 +203,7 @@ parse_du_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Context, SeqNum, ( ErrorSpecs = [], varset.coerce(VarSet, TypeVarSet), - DetailsDu = type_details_du(Ctors, MaybeCanonical, + DetailsDu = type_details_du(OneOrMoreCtors, MaybeCanonical, MaybeDirectArgIs), TypeDefn = parse_tree_du_type(DetailsDu), ItemTypeDefn = item_type_defn_info(Name, Params, TypeDefn, diff --git a/compiler/parse_type_repn.m b/compiler/parse_type_repn.m index 502a62b..28bfd05 100644 --- a/compiler/parse_type_repn.m +++ b/compiler/parse_type_repn.m @@ -40,6 +40,7 @@ :- import_module libs. :- import_module libs.globals. % for foreign_language :- import_module parse_tree.error_util. +:- import_module parse_tree.parse_pragma. :- import_module parse_tree.parse_sym_name. :- import_module parse_tree.parse_tree_out_term. :- import_module parse_tree.parse_type_defn. @@ -54,6 +55,7 @@ :- import_module maybe. :- import_module pair. :- import_module require. +:- import_module set. :- import_module uint. %---------------------------------------------------------------------------% @@ -79,12 +81,12 @@ parse_type_repn_item(_ModuleName, VarSet, ArgTerms, Context, SeqNum, then ( AtomStr = "is_direct_dummy", - parse_type_repn_direct_dummy(AtomStr, RepnArgs, - RepnContext, MaybeRepn) + parse_no_arg_type_repn(AtomStr, RepnArgs, RepnContext, + tcrepn_is_direct_dummy, MaybeRepn) ; AtomStr = "is_notag", - parse_type_repn_notag(AtomStr, RepnArgs, - RepnContext, MaybeRepn) + parse_no_arg_type_repn(AtomStr, RepnArgs, RepnContext, + tcrepn_is_notag, MaybeRepn) ; AtomStr = "is_equivalent_to", parse_type_repn_equivalent_to(VarSet, AtomStr, RepnArgs, @@ -95,8 +97,8 @@ parse_type_repn_item(_ModuleName, VarSet, ArgTerms, Context, SeqNum, RepnContext, MaybeRepn) ; AtomStr = "is_word_aligned_ptr", - parse_type_repn_is_word_aligned_ptr(AtomStr, RepnArgs, - RepnContext, MaybeRepn) + parse_no_arg_type_repn(AtomStr, RepnArgs, RepnContext, + tcrepn_is_word_aligned_ptr, MaybeRepn) ; AtomStr = "has_direct_arg_functors", parse_type_repn_has_direct_arg_functors(AtomStr, RepnArgs, @@ -176,31 +178,15 @@ parse_type_repn_item(_ModuleName, VarSet, ArgTerms, Context, SeqNum, %-----------------------------------------------------------------------------e -:- pred parse_type_repn_direct_dummy(string::in, list(term)::in, - term.context::in, maybe1(type_ctor_repn_info)::out) is det. - -parse_type_repn_direct_dummy(RepnStr, RepnArgs, RepnContext, MaybeRepn) :- - ( - RepnArgs = [], - MaybeRepn = ok1(tcrepn_is_direct_dummy) - ; - RepnArgs = [_ | _], - Pieces = [words("Error:"), quote(RepnStr), - words("should not have any arguments."), nl], - Spec = error_spec(severity_error, phase_term_to_parse_tree, - [simple_msg(RepnContext, [always(Pieces)])]), - MaybeRepn = error1([Spec]) - ). - -%-----------------------------------------------------------------------------e - -:- pred parse_type_repn_notag(string::in, list(term)::in, term.context::in, +:- pred parse_no_arg_type_repn(string::in, list(term)::in, + term.context::in, type_ctor_repn_info::in, maybe1(type_ctor_repn_info)::out) is det. -parse_type_repn_notag(RepnStr, RepnArgs, RepnContext, MaybeRepn) :- +parse_no_arg_type_repn(RepnStr, RepnArgs, RepnContext, + NoArgRepn, MaybeRepn) :- ( RepnArgs = [], - MaybeRepn = ok1(tcrepn_is_notag) + MaybeRepn = ok1(NoArgRepn) ; RepnArgs = [_ | _], Pieces = [words("Error:"), quote(RepnStr), @@ -297,64 +283,6 @@ parse_type_repn_fits_in_n_bits(RepnStr, RepnArgs, RepnContext, MaybeRepn) :- %-----------------------------------------------------------------------------e -:- pred parse_type_repn_is_word_aligned_ptr(string::in, list(term)::in, - term.context::in, maybe1(type_ctor_repn_info)::out) is det. - -parse_type_repn_is_word_aligned_ptr(RepnStr, RepnArgs, RepnContext, - MaybeRepn) :- - ( - RepnArgs = [RepnArg], - ( if - RepnArg = term.functor(term.atom(AtomStr), AtomArgs, _), - AtomStr = "foreign_type_assertion", - AtomArgs = [] - then - Repn = tcrepn_is_word_aligned_ptr(wap_foreign_type_assertion), - MaybeRepn = ok1(Repn) - else if - RepnArg = term.functor(term.atom(AtomStr), AtomArgs, _), - AtomStr = "mercury_type", - AtomArgs = [AtomArg] - then - ( if parse_name_and_arity_unqualified(AtomArg, SymName, Arity) then - WAP = wap_mercury_type(sym_name_arity(SymName, Arity)), - Repn = tcrepn_is_word_aligned_ptr(WAP), - MaybeRepn = ok1(Repn) - else - Pieces = [words("Error: the argument of"), - quote("mercury_type"), words("should have the form"), - quote("type_name/arity"), suffix("."), nl], - Spec = error_spec(severity_error, phase_term_to_parse_tree, - [simple_msg(get_term_context(AtomArg), [always(Pieces)])]), - MaybeRepn = error1([Spec]) - ) - else - Pieces = [words("Error: the argument of"), quote(RepnStr), - words("should be either"), - quote("foreign_type_assertion"), suffix(","), - words("or have the form"), - quote("mercury_type(type_name/type_arity)"), suffix("."), nl], - Spec = error_spec(severity_error, phase_term_to_parse_tree, - [simple_msg(RepnContext, [always(Pieces)])]), - MaybeRepn = error1([Spec]) - ) - ; - ( RepnArgs = [] - ; RepnArgs = [_, _ | _] - ), - Pieces = [words("Error:"), quote(RepnStr), - words("should have exactly one argument,"), - words("which should be either"), - quote("foreign_type_assertion"), suffix(","), - words("or have the form"), - quote("mercury_type(type_name / type_arity)"), suffix("."), nl], - Spec = error_spec(severity_error, phase_term_to_parse_tree, - [simple_msg(RepnContext, [always(Pieces)])]), - MaybeRepn = error1([Spec]) - ). - -%-----------------------------------------------------------------------------e - :- pred parse_type_repn_has_direct_arg_functors(string::in, list(term)::in, term.context::in, maybe1(type_ctor_repn_info)::out) is det. @@ -1744,7 +1672,7 @@ parse_type_repn_maybe_foreign_type(VarSet, RepnStr, RepnArgs, RepnContext, list_term_to_term_list(RepnArg1, ForeignTerms), ForeignTerms = [_ | _] then - parse_foreign_language_types(RepnStr, 1, ForeignTerms, + parse_foreign_language_types(VarSet, RepnStr, 1, ForeignTerms, ForeignPairs, ForeignSpecs) else ForeignPairs = [], @@ -1797,29 +1725,73 @@ parse_type_repn_maybe_foreign_type(VarSet, RepnStr, RepnArgs, RepnContext, MaybeRepn = error1([Spec]) ). -:- pred parse_foreign_language_types(string::in, int::in, list(term)::in, - list(pair(foreign_language, foreign_type_repn))::out, +:- pred parse_foreign_language_types(varset::in, string::in, int::in, + list(term)::in, assoc_list(foreign_language, foreign_type_repn)::out, list(error_spec)::out) is det. -parse_foreign_language_types(_, _, [], [], []). -parse_foreign_language_types(RepnStr, Nth, [Term | Terms], +parse_foreign_language_types(_, _, _, [], [], []). +parse_foreign_language_types(VarSet, RepnStr, Nth, [Term | Terms], !:ForeignPairs, !:Specs) :- - parse_foreign_language_types(RepnStr, Nth + 1, Terms, + parse_foreign_language_types(VarSet, RepnStr, Nth + 1, Terms, !:ForeignPairs, !:Specs), ( if - Term = term.functor(term.atom(TermStr), [ArgTerm], _), - simple_foreign_language_string(Lang, TermStr), - ArgTerm = term.functor(term.atom(TypeName), [], _) + Term = term.functor(term.atom(FunctorStr), ArgTerms, _), + ( + ( FunctorStr = "c", Lang = lang_c + ; FunctorStr = "csharp", Lang = lang_csharp + ; FunctorStr = "java", Lang = lang_java + ), + ArgTerms = [TypeNameTerm, AssertionTerm] + ; + FunctorStr = "erlang", + Lang = lang_erlang, + ArgTerms = [AssertionTerm], + TypeNameTerm = term.functor(term.string(""), [], term.context_init) + ) then - !:ForeignPairs = [Lang - foreign_type_repn(TypeName) | !.ForeignPairs] + ( if TypeNameTerm = term.functor(term.string(TypeName0), [], _) then + MaybeTypeName = ok1(TypeName0) + else + TypeNameTermStr = describe_error_term(VarSet, TypeNameTerm), + TypeNamePieces = [words("Error: the type name in the"), + nth_fixed(Nth), words("element of the list"), + words("in the first argument of"), quote(RepnStr), + words("is"), quote(TypeNameTermStr), suffix(","), + words("which is not a valid type name."), nl], + TypeNameSpec = error_spec(severity_error, phase_term_to_parse_tree, + [simple_msg(get_term_context(TypeNameTerm), + [always(TypeNamePieces)])]), + MaybeTypeName = error1([TypeNameSpec]) + ), + AssertionContextPieces = cord.from_list([ + words("In third argument of the"), nth_fixed(Nth), + words("element of the list in the first argument of"), + quote(RepnStr), suffix(":")]), + parse_foreign_type_assertions(AssertionContextPieces, VarSet, + AssertionTerm, set.init, AssertionSet, + [], AssertionSpecs), + ( if + MaybeTypeName = ok1(TypeName), + AssertionSpecs = [] + then + Assertions = foreign_type_assertions(AssertionSet), + Repn = foreign_type_repn(TypeName, Assertions), + !:ForeignPairs = [Lang - Repn | !.ForeignPairs] + else + !:Specs = get_any_errors1(MaybeTypeName) ++ AssertionSpecs + ++ !.Specs + ) else + TermStr = describe_error_term(VarSet, Term), Pieces = [words("Error: the"), nth_fixed(Nth), words("element"), words("of the list in the first argument of"), quote(RepnStr), - words("is not of the required form, which is one of"), - quote("c(c_type_name)"), suffix(","), - quote("csharp(csharp_type_name)"), suffix(","), - quote("java(java_type_name)"), words("or"), - quote("erlang(erlang_type_name)"), suffix("."), nl], + words("is"), quote(TermStr), suffix("."), + words("This is not in one of the required forms, which are"), + quote("c(c_type_name, assertionslist)"), suffix(","), + quote("csharp(csharp_type_name, assertionslist)"), suffix(","), + quote("java(java_type_name, assertionslist)"), words("and"), + quote("erlang(assertionslist)"), + suffix("."), nl], Spec = error_spec(severity_error, phase_term_to_parse_tree, [simple_msg(get_term_context(Term), [always(Pieces)])]), !:Specs = [Spec | !.Specs] @@ -1831,12 +1803,12 @@ parse_foreign_language_types(RepnStr, Nth, [Term | Terms], parse_maybe_du_repn(VarSet, RepnStr, Term, MaybeMaybeDuRepn) :- ( if Term = term.functor(term.atom(TermStr), [], _), - TermStr = "no" + TermStr = "no_du_repn" then MaybeMaybeDuRepn = ok1(no) else if Term = term.functor(term.atom(TermStr), [ArgTerm], TermContext), - TermStr = "yes" + TermStr = "du_repn" then parse_type_repn_du(VarSet, indirect_in_maybe_foreign_type, ArgTerm, TermContext, MaybeDuRepn), @@ -1850,8 +1822,8 @@ parse_maybe_du_repn(VarSet, RepnStr, Term, MaybeMaybeDuRepn) :- else Pieces = [words("Error: the second argument of"), quote(RepnStr), words("should be either"), - words("a"), quote("no"), words("with no arguments,"), - words("or a"), quote("yes"), words("with one argument."), nl], + quote("no_du_repn"), words("with no arguments,"), + words("or"), quote("du_repn"), words("with one argument."), nl], Spec = error_spec(severity_error, phase_term_to_parse_tree, [simple_msg(get_term_context(Term), [always(Pieces)])]), MaybeMaybeDuRepn = error1([Spec]) diff --git a/compiler/prog_data.m b/compiler/prog_data.m index 646aa66..547f098 100644 --- a/compiler/prog_data.m +++ b/compiler/prog_data.m @@ -278,7 +278,7 @@ cons_id_is_const_struct(ConsId, ConstNum) :- ---> type_details_du( % The list of data constructors (function symbols) defined % by the type constructor. - du_ctors :: list(constructor), + du_ctors :: one_or_more(constructor), % Does the type constructor definition specify % a unification and/or comparison predicate for its instances? diff --git a/compiler/prog_item.m b/compiler/prog_item.m index 12400f8..9b2dd1f 100644 --- a/compiler/prog_item.m +++ b/compiler/prog_item.m @@ -915,7 +915,7 @@ mer_type ) ; tcrepn_fits_in_n_bits(int, fill_kind) - ; tcrepn_is_word_aligned_ptr(wap_kind) + ; tcrepn_is_word_aligned_ptr ; tcrepn_has_direct_arg_functors(list(sym_name_and_arity)) ; tcrepn_du(du_repn) ; tcrepn_maybe_foreign( @@ -937,17 +937,14 @@ maybe(du_repn) ). -:- type wap_kind - ---> wap_foreign_type_assertion - ; wap_mercury_type(sym_name_and_arity). - :- type foreign_type_repn ---> foreign_type_repn( % The name of the foreign type that represents values % of this Mercury type. - frd_foreign_type :: string + frd_foreign_type :: string, - % ZZZ assertions? + % The assertions about this foreign type. + frd_assertions :: foreign_type_assertions ). % There should be exactly one applicable du_repn for any given type_ctor. @@ -1213,7 +1210,7 @@ ---> pragma_info_foreign_enum( foreign_enum_language :: foreign_language, foreign_enum_type_ctor :: type_ctor, - foreign_enum_values :: assoc_list(sym_name, string) + foreign_enum_values :: one_or_more(pair(sym_name, string)) ). :- type pragma_info_external_proc diff --git a/compiler/prog_type.m b/compiler/prog_type.m index 6f6caed..9c76c67 100644 --- a/compiler/prog_type.m +++ b/compiler/prog_type.m @@ -19,8 +19,6 @@ :- module parse_tree.prog_type. :- interface. -:- import_module libs. -:- import_module libs.globals. :- import_module mdbcomp. :- import_module mdbcomp.prim_data. :- import_module mdbcomp.sym_name. @@ -29,7 +27,6 @@ :- import_module bool. :- import_module list. :- import_module map. -:- import_module maybe. :- import_module term. %-----------------------------------------------------------------------------% @@ -338,22 +335,10 @@ % :- pred type_constructors_are_type_info(list(constructor)::in) is semidet. - % type_ctor_should_be_notag(Globals, TypeCtor, ReservedTag, TypeDetailsDu, - % SingleFunctorName, SingleArgType, MaybeSingleArgName): - % - % Succeed if the type constructor with the given name (TypeCtor) and - % details (TypeDetailsDu) is a no_tag type. If it is, return the name - % of its single function symbol, the type of its one argument, - % and its name (if any). - % -:- pred type_ctor_should_be_notag(globals::in, type_ctor::in, - list(constructor)::in, maybe_canonical::in, - sym_name::out, mer_type::out, maybe(string)::out) is semidet. - % Is the discriminated union type with the given list of constructors % a notag type? % -:- pred du_type_is_notag(list(constructor)::in, maybe_canonical::in) +:- pred du_type_is_notag(one_or_more(constructor)::in, maybe_canonical::in) is semidet. % Is the discriminated union type with the given list of constructors @@ -425,13 +410,13 @@ :- implementation. -:- import_module libs.options. :- import_module mdbcomp.builtin_modules. :- import_module parse_tree.prog_out. -:- import_module parse_tree.prog_util. :- import_module parse_tree.prog_type_subst. +:- import_module parse_tree.prog_util. :- import_module int. +:- import_module maybe. :- import_module require. :- import_module string. @@ -987,7 +972,9 @@ name_is_type_info("base_typeclass_info"). %-----------------------------------------------------------------------------% du_type_is_enum(DuDetails, NumBits) :- - DuDetails = type_details_du(Ctors, _MaybeCanonical, _MaybeDirectArgCtors), + DuDetails = type_details_du(OoMCtors, _MaybeCanonical, + _MaybeDirectArgCtors), + Ctors = one_or_more_to_list(OoMCtors), Ctors = [_, _ | _], all_functors_are_enum(Ctors, 0, NumFunctors), int.log2(NumFunctors, NumBits). @@ -1006,47 +993,21 @@ all_functors_are_enum([Ctor | Ctors], !NumFunctors) :- %-----------------------------------------------------------------------------% -type_ctor_should_be_notag(Globals, _TypeCtor, Ctors, MaybeCanonical, - FunctorName, ArgType, MaybeArgName) :- - globals.lookup_bool_option(Globals, unboxed_no_tag_types, yes), - du_type_is_notag_return_info(Ctors, MaybeCanonical, FunctorName, ArgType, - MaybeArgName). - -du_type_is_notag(Ctors, MaybeCanonical) :- - du_type_is_notag_return_info(Ctors, MaybeCanonical, _, _, _). - -:- pred du_type_is_notag_return_info(list(constructor)::in, - maybe_canonical::in, - sym_name::out, mer_type::out, maybe(string)::out) is semidet. -:- pragma inline(du_type_is_notag_return_info/5). - -du_type_is_notag_return_info(Ctors, MaybeCanonical, - FunctorName, ArgType, MaybeArgName) :- - Ctors = [Ctor], - Ctor = ctor(_Ordinal, MaybeExistConstraints, FunctorName, [CtorArg], 1, +du_type_is_notag(OoMCtors, MaybeCanonical) :- + OoMCtors = one_or_more(Ctor, []), + Ctor = ctor(_Ordinal, MaybeExistConstraints, _FunctorName, [_CtorArg], 1, _Context), - MaybeCanonical = canon, MaybeExistConstraints = no_exist_constraints, - - require_det ( - CtorArg = ctor_arg(MaybeFieldName, ArgType, _), - ( - MaybeFieldName = no, - MaybeArgName = no - ; - MaybeFieldName = yes(ctor_field_name(SymName, _)), - MaybeArgName = yes(unqualify_name(SymName)) - ) - ). + MaybeCanonical = canon. du_type_is_dummy(DuDetails) :- DuDetails = type_details_du(Ctors, MaybeCanonical, MaybeDirectArgCtors), - MaybeCanonical = canon, - MaybeDirectArgCtors = no, - Ctors = [Ctor], + Ctors = one_or_more(Ctor, []), Ctor = ctor(_Ordinal, MaybeExistConstraints, _FunctorName, [], 0, _Context), - MaybeExistConstraints = no_exist_constraints. + MaybeExistConstraints = no_exist_constraints, + MaybeCanonical = canon, + MaybeDirectArgCtors = no. %-----------------------------------------------------------------------------% % diff --git a/compiler/recompilation.check.m b/compiler/recompilation.check.m index 1b33171..889c2aa 100644 --- a/compiler/recompilation.check.m +++ b/compiler/recompilation.check.m @@ -1227,8 +1227,8 @@ check_type_defn_ambiguity_with_functor(NeedQualifier, TypeCtor, TypeDefn, ; TypeDefn = parse_tree_du_type(DetailsDu), DetailsDu = type_details_du(Ctors, _, _), - list.foldl(check_functor_ambiguities(NeedQualifier, TypeCtor), Ctors, - !Info) + list.foldl(check_functor_ambiguities(NeedQualifier, TypeCtor), + one_or_more_to_list(Ctors), !Info) ). :- pred check_functor_ambiguities(need_qualifier::in, type_ctor::in, diff --git a/compiler/recompilation.usage.m b/compiler/recompilation.usage.m index 630b2db..afb3d07 100644 --- a/compiler/recompilation.usage.m +++ b/compiler/recompilation.usage.m @@ -1069,7 +1069,7 @@ find_items_used_by_type_and_mode(TypeAndMode, !Info) :- find_items_used_by_type_body(TypeBody, !Info) :- ( TypeBody = hlds_du_type(Ctors, _, _, _), - list.foldl(find_items_used_by_ctor, Ctors, !Info) + list.foldl(find_items_used_by_ctor, one_or_more_to_list(Ctors), !Info) ; TypeBody = hlds_eqv_type(EqvType), find_items_used_by_type(EqvType, !Info) diff --git a/compiler/resolve_unify_functor.m b/compiler/resolve_unify_functor.m index 7d637d1..bbb5280 100644 --- a/compiler/resolve_unify_functor.m +++ b/compiler/resolve_unify_functor.m @@ -586,8 +586,8 @@ get_constructor_containing_field(ModuleInfo, TermType, FieldSymName, ( TermTypeBody = hlds_du_type(Ctors, _, _, _), FieldName = unqualify_name(FieldSymName), - get_constructor_containing_field_loop(TermTypeCtor, Ctors, FieldName, - ConsId, FieldNumber) + get_constructor_containing_field_loop(TermTypeCtor, + one_or_more_to_list(Ctors), FieldName, ConsId, FieldNumber) ; ( TermTypeBody = hlds_eqv_type(_) ; TermTypeBody = hlds_foreign_type(_) diff --git a/compiler/simplify_goal_ite.m b/compiler/simplify_goal_ite.m index 07b4ea1..ffe1900 100644 --- a/compiler/simplify_goal_ite.m +++ b/compiler/simplify_goal_ite.m @@ -437,7 +437,9 @@ can_switch_on_type(TypeBody) = CanSwitchOnType :- % We don't care about _MaybeForeignType, since the unification with % *any* functor of the type means that either there is no foreign type % version, or we are using the Mercury version of the type. - ( if Ctors = [_, _ | _] then + % + % We *do* care that the type has at least two constructors. + ( if Ctors = one_or_more(_, [_ | _]) then CanSwitchOnType = yes else CanSwitchOnType = no diff --git a/compiler/special_pred.m b/compiler/special_pred.m index 18d41fc..66a2cc0 100644 --- a/compiler/special_pred.m +++ b/compiler/special_pred.m @@ -358,9 +358,11 @@ special_pred_for_type_needs_typecheck(ModuleInfo, SpecialPredId, TypeBody) :- ) ) ; - Ctors = TypeBody ^ du_type_ctors, + one_or_more(HeadCtor, TailCtors) = TypeBody ^ du_type_ctors, some [Ctor] ( - list.member(Ctor, Ctors), + ( Ctor = HeadCtor + ; list.member(Ctor, TailCtors) + ), Ctor = ctor(_, MaybeExistConstraints, _, _, _, _), MaybeExistConstraints = exist_constraints(_) ) diff --git a/compiler/switch_util.m b/compiler/switch_util.m index 5498564..63c92d3 100644 --- a/compiler/switch_util.m +++ b/compiler/switch_util.m @@ -915,8 +915,11 @@ type_range(ModuleInfo, TypeCtorCat, Type, Min, Max, NumValues) :- hlds_data.get_type_defn_body(TypeDefn, TypeBody), ( TypeBody = hlds_du_type(Constructors, _, _, _), - list.length(Constructors, NumConstructors), - Max = NumConstructors - 1 + Constructors = one_or_more(_HeadCtor, TailCtors), + list.length(TailCtors, NumTailConstructors), + % NumConstructors = 1 + NumTailConstructors + % Max = NumConstructors - 1 + Max = NumTailConstructors ; ( TypeBody = hlds_eqv_type(_) ; TypeBody = hlds_foreign_type(_) diff --git a/compiler/table_gen.m b/compiler/table_gen.m index 4a05fce..a77a1f4 100644 --- a/compiler/table_gen.m +++ b/compiler/table_gen.m @@ -2509,7 +2509,7 @@ gen_lookup_call_for_type(ArgTablingMethod0, CtorCat, Type, ArgVar, VarSeqNum, MaybeRepn = yes(Repn), Repn ^ dur_kind = du_type_kind_mercury_enum then - list.length(Ctors, EnumRange) + list.length(one_or_more_to_list(Ctors), EnumRange) else unexpected($pred, "enum type is not du_type?") ), diff --git a/compiler/term_norm.m b/compiler/term_norm.m index f668c23..a018f3f 100644 --- a/compiler/term_norm.m +++ b/compiler/term_norm.m @@ -154,7 +154,7 @@ find_weights_for_type(TypeCtor - TypeDefn, !Weights) :- TypeBody = hlds_du_type(Constructors, _, _, _), hlds_data.get_type_defn_tparams(TypeDefn, TypeParams), list.foldl(find_weights_for_cons(TypeCtor, TypeParams), - Constructors, !Weights) + one_or_more_to_list(Constructors), !Weights) ; % This type does not introduce any functors. TypeBody = hlds_eqv_type(_) diff --git a/compiler/type_util.m b/compiler/type_util.m index ad8c895..2a156ed 100644 --- a/compiler/type_util.m +++ b/compiler/type_util.m @@ -1218,7 +1218,8 @@ type_constructors(ModuleInfo, Type, Constructors) :- search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn), hlds_data.get_type_defn_tparams(TypeDefn, TypeParams), hlds_data.get_type_defn_body(TypeDefn, TypeBody), - substitute_type_args(TypeParams, TypeArgs, TypeBody ^ du_type_ctors, + substitute_type_args(TypeParams, TypeArgs, + one_or_more_to_list(TypeBody ^ du_type_ctors), Constructors) ). @@ -1293,8 +1294,9 @@ switch_type_num_functors(ModuleInfo, Type, NumFunctors) :- module_info_get_type_table(ModuleInfo, TypeTable), search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn), hlds_data.get_type_defn_body(TypeDefn, TypeBody), - TypeBody = hlds_du_type(Constructors, _, _, _), - list.length(Constructors, NumFunctors) + TypeBody = hlds_du_type(OoMConstructors, _, _, _), + OoMConstructors = one_or_more(_HeadCtor, TailCtors), + NumFunctors = 1 + list.length(TailCtors) ). %-----------------------------------------------------------------------------% @@ -1361,8 +1363,11 @@ cons_id_arg_types(ModuleInfo, VarType, ConsId, ArgTypes) :- module_info_get_type_table(ModuleInfo, TypeTable), search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn), hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody), - TypeDefnBody = hlds_du_type(Ctors, _, _, _), - list.member(Ctor, Ctors), + TypeDefnBody = hlds_du_type(OoMCtors, _, _, _), + OoMCtors = one_or_more(HeadCtor, TailCtors), + ( Ctor = HeadCtor + ; list.member(Ctor, TailCtors) + ), Ctor = ctor(_Ordinal, _MaybeExistConstraints, Name, _Args, Arity, _Ctxt), ConsId = cons(Name, Arity, TypeCtor), diff --git a/compiler/untupling.m b/compiler/untupling.m index 3f706a8..415d3d5 100644 --- a/compiler/untupling.m +++ b/compiler/untupling.m @@ -767,7 +767,7 @@ expand_type(Type, ContainerTypes, TypeTable, Expansion) :- search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn), get_type_defn_tparams(TypeDefn, []), get_type_defn_body(TypeDefn, TypeBody), - TypeBody ^ du_type_ctors = [SingleCtor], + TypeBody ^ du_type_ctors = one_or_more(SingleCtor, []), SingleCtor ^ cons_maybe_exist = no_exist_constraints, SingleCtorName = SingleCtor ^ cons_name, SingleCtorArgs = SingleCtor ^ cons_args, diff --git a/compiler/unused_imports.m b/compiler/unused_imports.m index 71d15ac..f83219e 100644 --- a/compiler/unused_imports.m +++ b/compiler/unused_imports.m @@ -437,7 +437,8 @@ type_used_modules(_TypeCtor, TypeDefn, !UsedModules) :- Visibility = type_visibility(TypeStatus), ( TypeBody = hlds_du_type(Ctors, _, _, _), - list.foldl(ctor_used_modules(Visibility), Ctors, !UsedModules) + list.foldl(ctor_used_modules(Visibility), + one_or_more_to_list(Ctors), !UsedModules) ; TypeBody = hlds_eqv_type(EqvType), mer_type_used_modules(Visibility, EqvType, !UsedModules) diff --git a/compiler/xml_documentation.m b/compiler/xml_documentation.m index 54eba8b..e1e19bb 100644 --- a/compiler/xml_documentation.m +++ b/compiler/xml_documentation.m @@ -405,7 +405,8 @@ type_param_to_xml(TVarset, TVar) = Xml :- type_body_to_xml(C, TVarSet, TypeDefnBody) = Xmls :- ( - TypeDefnBody = hlds_du_type(Ctors, _, _, _), + TypeDefnBody = hlds_du_type(OoMCtors, _, _, _), + Ctors = one_or_more_to_list(OoMCtors), Xmls = [xml_list("constructors", constructor_to_xml(C, TVarSet), Ctors)] ; diff --git a/library/bimap.m b/library/bimap.m index eefa0ae..e8a6aaf 100644 --- a/library/bimap.m +++ b/library/bimap.m @@ -120,9 +120,10 @@ % % Search for the key K in the bimap. If the key is already in the bimap, % with corresponding value OldV, set MaybeOldV to yes(OldV). If it - % is not in the bimap, then insert it with value V. The value of V - % should be guaranteed to be different to all the values already - % in !.Bimap. If it isn't, this predicate will throw an exception. + % is not in the bimap, then insert it with value V, and set MaybeOldV + % to no. The value of V should be guaranteed to be different to + % all the values already in !.Bimap. If it isn't, this predicate + % will throw an exception. % :- pred search_insert(K::in, V::in, maybe(V)::out, bimap(K, V)::in, bimap(K, V)::out) is det. diff --git a/library/list.m b/library/list.m index 67c3a9e..6cd42fa 100644 --- a/library/list.m +++ b/library/list.m @@ -1920,6 +1920,11 @@ :- func one_or_more_cons(T, one_or_more(T)) = one_or_more(T). +:- func one_or_more_to_list(one_or_more(T)) = list(T). + +:- pred list_to_one_or_more(list(T)::in, one_or_more(T)::out) is semidet. +:- pred list_to_one_or_more_det(list(T)::in, one_or_more(T)::out) is det. + %---------------------------------------------------------------------------% :- implementation. @@ -3460,6 +3465,14 @@ inst_preserving_reverse_prepend([X | Xs], L0, L) :- one_or_more_cons(Head, one_or_more(HeadTail, TailTail)) = one_or_more(Head, [HeadTail | TailTail]). +one_or_more_to_list(one_or_more(Head, Tail)) = [Head | Tail]. + +list_to_one_or_more([Head | Tail], one_or_more(Head, Tail)). + +list_to_one_or_more_det([], _) :- + unexpected($pred, "empty list"). +list_to_one_or_more_det([Head | Tail], one_or_more(Head, Tail)). + %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% diff --git a/library/map.m b/library/map.m index 05fdc14..e7f3e82 100644 --- a/library/map.m +++ b/library/map.m @@ -183,7 +183,8 @@ % % Search for the key K in the map. If the key is already in the map, % with corresponding value OldV, set MaybeOldV to yes(OldV). If it - % is not in the map, then insert it into the map with value V. + % is not in the map, then insert it into the map with value V, + % and set MaybeOldV to no. % :- pred search_insert(K::in, V::in, maybe(V)::out, map(K, V)::in, map(K, V)::out) is det. diff --git a/library/tree234.m b/library/tree234.m index fdb8fbc..a184902 100644 --- a/library/tree234.m +++ b/library/tree234.m @@ -99,7 +99,8 @@ % % Search for the key K in the tree. If the key is already in the tree, % with corresponding value OldV, set MaybeOldV to yes(OldV). If it is - % not in the tree, then insert it into the tree with value V. + % not in the tree, then insert it into the tree with value V, and set + % MaybeOldV to no. % :- pred search_insert(K::in, V::in, maybe(V)::out, tree234(K, V)::in, tree234(K, V)::out) is det.