From 12281f3419fd81f755c6731640eff60a19226bc4 Mon Sep 17 00:00:00 2001 From: Peter Wang Date: Thu, 16 Jun 2011 06:42:19 +0000 Subject: [PATCH] Implement a type representation optimisation ("direct argument functors"), Branches: main Implement a type representation optimisation ("direct argument functors"), where a functor with exactly one argument can be represented by a tagged pointer to the argument value, which itself does not require the tag bits, e.g. :- type maybe_foo ---> yes(foo) ; no. :- type foo ---> foo(int, int). % aligned pointer To ensure that all modules which could construct or deconstruct the functor agree on the type representation, I had planned to automatically output extra information to .int files to notify importing modules about functors using the optimised representation: :- type maybe_foo ---> yes(foo) ; no where direct_arg is [yes/1]. However, the compiler does not perform enough (or any) semantic analysis while making interface files. The fallback solution is to only use the optimised representation when all importing modules can be guaranteed to import both the top-level type and the argument type, namely, when both types are exported from the same module. We also allow certain built-in argument types; currently this only includes tuples. Non-exported types may use the optimised representation, but when intermodule optimisation is enabled, they may be written out to .opt files. Then, we *do* add direct_arg attributes to .opt files to ensure that importing modules agree on the type representation. The attributes may also be added by Mercury programmers to source files, which will be copied directly into .int files without analysis. They will be checked when the module is actually compiled. This patch includes work by Zoltan, who independently implemented a version of this change. compiler/hlds_data.m: Record the direct arg functors in hlds_du_type. Add a new option to cons_tag. Fix some comments. compiler/prog_data.m: compiler/prog_io_type_defn.m: Parse and record `direct_arg' attributes on type definitions. compiler/prog_io_pragma.m: Issue an error if the `direct_arg' attribute is used with a foreign type. compiler/make_tags.m: compiler/mercury_compile_front_end.m: Add a pass to convert suitable functors to use the direct argument representation. The argument type must have been added to the type table, so we do this after all type definitions have been added. Move code to compute cheaper_tag_test here. compiler/ml_unify_gen.m: compiler/unify_gen.m: Generate different code to construct/deconstruct direct argument functors. compiler/intermod.m: Write `direct_arg' attributes to .opt files for functors using the direct argument representation. compiler/mercury_to_mercury.m: Write out `direct_arg' attributes. compiler/rtti.m: compiler/rtti_out.m: compiler/rtti_to_mlds.m: Add an option to the types which describe the location of secondary tag options. The functors which can use the optimised representation are a subset of those which require no secondary tag. Output "MR_SECTAG_NONE_DIRECT_ARG" instead of "MR_SECTAG_NONE" in RTTI structures when applicable. compiler/add_pragma.m: compiler/add_type.m: compiler/bytecode_gen.m: compiler/check_typeclass.m compiler/code_info.m: compiler/equiv_type.m: compiler/export.m: compiler/foreign.m: compiler/hlds_code_util.m: compiler/hlds_out_module.m: compiler/inst_check.m: compiler/ml_proc_gen.m: compiler/ml_switch_gen.m: compiler/ml_tag_switch.m: compiler/ml_type_gen.m: compiler/module_qual.m: compiler/modules.m: compiler/post_term_analysis.m: compiler/post_typecheck.m: compiler/recompilation.check.m: compiler/recompilation.usage.m: compiler/recompilation.version.m: compiler/simplify.m: compiler/structure_reuse.direct.choose_reuse.m: compiler/switch_gen.m: compiler/switch_util.m: compiler/tag_switch.m: compiler/term_norm.m: compiler/type_ctor_info.m: compiler/type_util.m: compiler/unify_proc.m: compiler/unused_imports.m: compiler/xml_documentation.m: Conform to changes. Bump RTTI version number. doc/reference_manual.texi: Add commented out documentation for `direct_arg' attributes. library/construct.m: Handle MR_SECTAG_NONE_DIRECT_ARG in construct.construct/3. library/private_builtin.m: Add MR_SECTAG_NONE_DIRECT_ARG constant for Java for consistency, though it won't be used. runtime/mercury_grade.h: Bump binary compatibility version number. runtime/mercury_type_info.h: Bump RTTI version number. Add MR_SECTAG_NONE_DIRECT_ARG. runtime/mercury_deconstruct.c: runtime/mercury_deep_copy_body.h: runtime/mercury_ml_expand_body.h: runtime/mercury_table_type_body.h: runtime/mercury_term_size.c: runtime/mercury_unify_compare_body.h: Handle MR_SECTAG_NONE_DIRECT_ARG in RTTI code. tests/debugger/Mmakefile: tests/debugger/chooser_tag_test.exp: tests/debugger/chooser_tag_test.inp: tests/debugger/chooser_tag_test.m: tests/hard_coded/Mercury.options: tests/hard_coded/Mmakefile: tests/hard_coded/construct_test.exp: tests/hard_coded/construct_test.m: tests/hard_coded/direct_arg_cyclic1.exp: tests/hard_coded/direct_arg_cyclic1.m: tests/hard_coded/direct_arg_cyclic2.m: tests/hard_coded/direct_arg_cyclic3.m: tests/hard_coded/direct_arg_intermod1.exp: tests/hard_coded/direct_arg_intermod1.m: tests/hard_coded/direct_arg_intermod2.m: tests/hard_coded/direct_arg_intermod3.m: tests/hard_coded/direct_arg_parent.exp: tests/hard_coded/direct_arg_parent.m: tests/hard_coded/direct_arg_sub.m: tests/invalid/Mmakefile: tests/invalid/where_direct_arg.err_exp: tests/invalid/where_direct_arg.m: tests/invalid/where_direct_arg2.err_exp: tests/invalid/where_direct_arg2.m: Add test cases. tests/invalid/ee_invalid.err_exp: Update expected output. --- compiler/add_pragma.m | 23 +- compiler/add_type.m | 40 +- compiler/bytecode_gen.m | 2 + compiler/check_typeclass.m | 4 +- compiler/code_info.m | 4 +- compiler/equiv_type.m | 4 +- compiler/equiv_type_hlds.m | 4 +- compiler/export.m | 5 +- compiler/foreign.m | 2 +- compiler/hlds_code_util.m | 4 +- compiler/hlds_data.m | 19 +- compiler/hlds_out_module.m | 7 +- compiler/inst_check.m | 4 +- compiler/intermod.m | 17 +- compiler/make_tags.m | 401 +++++++++++++++++- compiler/mercury_compile_front_end.m | 17 +- compiler/mercury_to_mercury.m | 47 +- compiler/ml_proc_gen.m | 2 +- compiler/ml_switch_gen.m | 1 + compiler/ml_tag_switch.m | 8 +- compiler/ml_type_gen.m | 9 +- compiler/ml_unify_gen.m | 209 ++++++++- compiler/module_qual.m | 8 +- compiler/modules.m | 45 +- compiler/post_term_analysis.m | 2 +- compiler/post_typecheck.m | 2 +- compiler/prog_data.m | 3 +- compiler/prog_io_pragma.m | 25 +- compiler/prog_io_type_defn.m | 213 ++++++++-- compiler/recompilation.check.m | 2 +- compiler/recompilation.usage.m | 2 +- compiler/recompilation.version.m | 2 +- compiler/rtti.m | 36 +- compiler/rtti_out.m | 4 + compiler/rtti_to_mlds.m | 4 + compiler/simplify.m | 2 +- .../structure_reuse.direct.choose_reuse.m | 2 +- compiler/switch_gen.m | 1 + compiler/switch_util.m | 42 +- compiler/tag_switch.m | 4 +- compiler/term_norm.m | 2 +- compiler/type_ctor_info.m | 31 +- compiler/type_util.m | 12 +- compiler/unify_gen.m | 147 ++++++- compiler/unify_proc.m | 12 +- compiler/unused_imports.m | 2 +- compiler/xml_documentation.m | 4 +- doc/reference_manual.texi | 34 +- library/construct.m | 13 + library/private_builtin.m | 11 +- runtime/mercury_deconstruct.c | 3 +- runtime/mercury_deep_copy_body.h | 39 +- runtime/mercury_grade.h | 2 +- runtime/mercury_ml_expand_body.h | 6 + runtime/mercury_table_type_body.h | 9 +- runtime/mercury_term_size.c | 9 +- runtime/mercury_type_info.h | 14 +- runtime/mercury_unify_compare_body.h | 52 ++- tests/debugger/Mmakefile | 7 +- tests/debugger/chooser_tag_test.exp | 54 +++ tests/debugger/chooser_tag_test.inp | 19 + tests/debugger/chooser_tag_test.m | 173 ++++++++ tests/hard_coded/Mercury.options | 6 + tests/hard_coded/Mmakefile | 3 + tests/hard_coded/construct_test.exp | 7 + tests/hard_coded/construct_test.m | 12 + tests/hard_coded/direct_arg_cyclic1.exp | 1 + tests/hard_coded/direct_arg_cyclic1.m | 17 + tests/hard_coded/direct_arg_cyclic2.m | 14 + tests/hard_coded/direct_arg_cyclic3.m | 10 + tests/hard_coded/direct_arg_intermod1.exp | 4 + tests/hard_coded/direct_arg_intermod1.m | 34 ++ tests/hard_coded/direct_arg_intermod2.m | 65 +++ tests/hard_coded/direct_arg_intermod3.m | 9 + tests/hard_coded/direct_arg_parent.exp | 2 + tests/hard_coded/direct_arg_parent.m | 39 ++ tests/hard_coded/direct_arg_sub.m | 37 ++ tests/invalid/Mmakefile | 2 + tests/invalid/ee_invalid.err_exp | 2 +- tests/invalid/where_direct_arg.err_exp | 9 + tests/invalid/where_direct_arg.m | 23 + tests/invalid/where_direct_arg2.err_exp | 10 + tests/invalid/where_direct_arg2.m | 39 ++ 83 files changed, 1971 insertions(+), 261 deletions(-) create mode 100644 tests/debugger/chooser_tag_test.exp create mode 100644 tests/debugger/chooser_tag_test.inp create mode 100644 tests/debugger/chooser_tag_test.m create mode 100644 tests/hard_coded/direct_arg_cyclic1.exp create mode 100644 tests/hard_coded/direct_arg_cyclic1.m create mode 100644 tests/hard_coded/direct_arg_cyclic2.m create mode 100644 tests/hard_coded/direct_arg_cyclic3.m create mode 100644 tests/hard_coded/direct_arg_intermod1.exp create mode 100644 tests/hard_coded/direct_arg_intermod1.m create mode 100644 tests/hard_coded/direct_arg_intermod2.m create mode 100644 tests/hard_coded/direct_arg_intermod3.m create mode 100644 tests/hard_coded/direct_arg_parent.exp create mode 100644 tests/hard_coded/direct_arg_parent.m create mode 100644 tests/hard_coded/direct_arg_sub.m create mode 100644 tests/invalid/where_direct_arg.err_exp create mode 100644 tests/invalid/where_direct_arg.m create mode 100644 tests/invalid/where_direct_arg2.err_exp create mode 100644 tests/invalid/where_direct_arg2.m diff --git a/compiler/add_pragma.m b/compiler/add_pragma.m index ceded2f07..c7c4581d2 100644 --- a/compiler/add_pragma.m +++ b/compiler/add_pragma.m @@ -546,8 +546,8 @@ add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo, ; ( TypeBody0 = hlds_du_type(Body, _CtorTags0, _CheaperTagTest, - _IsEnum0, MaybeUserEqComp, ReservedTag0, _ReservedAddr, - IsForeign), + _DuTypeKind, MaybeUserEqComp, MaybeDirectArgCtors, + ReservedTag0, _ReservedAddr, IsForeign), ( ReservedTag0 = uses_reserved_tag, % Make doubly sure that we don't get any spurious warnings @@ -570,10 +570,10 @@ add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo, ReservedTag = uses_reserved_tag, module_info_get_globals(!.ModuleInfo, Globals), assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor, - ReservedTag, Globals, CtorTags, ReservedAddr, EnumDummy), + ReservedTag, Globals, CtorTags, ReservedAddr, DuTypeKind), TypeBody = hlds_du_type(Body, CtorTags, no_cheaper_tag_test, - EnumDummy, MaybeUserEqComp, ReservedTag, ReservedAddr, - IsForeign), + DuTypeKind, MaybeUserEqComp, MaybeDirectArgCtors, + ReservedTag, ReservedAddr, IsForeign), hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn), replace_type_ctor_defn(TypeCtor, TypeDefn, TypeTable0, TypeTable), @@ -660,8 +660,8 @@ add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes, ; % XXX How should we handle IsForeignType here? TypeBody = hlds_du_type(Ctors, _TagValues, _CheaperTagTest, - DuTypeKind, _MaybeUserEq, _ReservedTag, _ReservedAddr, - _IsForeignType), + DuTypeKind, _MaybeUserEq, _MaybeDirectArgCtors, + _ReservedTag, _ReservedAddr, _IsForeignType), ( ( DuTypeKind = du_type_kind_mercury_enum ; DuTypeKind = du_type_kind_foreign_enum(_) @@ -710,7 +710,7 @@ add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes, words("error: "), sym_name_and_arity(TypeName / TypeArity), words("is not an enumeration type."), - words("It has one more non-zero arity"), + words("It has one or more non-zero arity"), words("constructors.") ] ) @@ -1014,8 +1014,8 @@ add_pragma_foreign_enum(Lang, TypeName, TypeArity, ForeignTagValues, words("is not an enumeration type"), suffix(".")] ; TypeBody0 = hlds_du_type(Ctors, OldTagValues, CheaperTagTest, - DuTypeKind0, MaybeUserEq, ReservedTag, ReservedAddr, - IsForeignType), + DuTypeKind0, MaybeUserEq, MaybeDirectArgCtors, + ReservedTag, ReservedAddr, IsForeignType), % Work out what language's foreign_enum pragma we should be % looking at for the the current compilation target language. module_info_get_globals(!.ModuleInfo, Globals), @@ -1059,7 +1059,8 @@ add_pragma_foreign_enum(Lang, TypeName, TypeArity, ForeignTagValues, UnmappedCtors = [], TypeBody = hlds_du_type(Ctors, TagValues, CheaperTagTest, DuTypeKind, MaybeUserEq, - ReservedTag, ReservedAddr, IsForeignType), + MaybeDirectArgCtors, ReservedTag, ReservedAddr, + IsForeignType), set_type_defn_body(TypeBody, TypeDefn0, TypeDefn), replace_type_ctor_defn(TypeCtor, TypeDefn, TypeTable0, TypeTable), diff --git a/compiler/add_type.m b/compiler/add_type.m index cc5b03612..6aa632dbc 100644 --- a/compiler/add_type.m +++ b/compiler/add_type.m @@ -87,7 +87,7 @@ module_add_type_defn(TVarSet, Name, Args, TypeDefn, _Cond, Context, ( Body0 = hlds_abstract_type(_) ; - Body0 = hlds_du_type(_, _, _, _, _, _, _, _), + Body0 = hlds_du_type(_, _, _, _, _, _, _, _, _), string.suffix(term.context_file(Context), ".int2") % If the type definition comes from a .int2 file then we must % treat it as abstract. The constructors may only be used @@ -103,7 +103,7 @@ module_add_type_defn(TVarSet, Name, Args, TypeDefn, _Cond, Context, % zero-arity constructor are dummy types. Dummy types are not allowed % to have user-defined equality or comparison. - TypeDefn = parse_tree_du_type(Ctors, MaybeUserUC), + TypeDefn = parse_tree_du_type(Ctors, MaybeUserUC, _MaybeDirectArg), Ctors = [Constructor], list.length(Constructor ^ cons_args, 0), MaybeUserUC = yes(_), @@ -360,7 +360,8 @@ process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !Specs) :- get_type_defn_need_qualifier(TypeDefn, NeedQual), module_info_get_globals(!.ModuleInfo, Globals), ( - Body = hlds_du_type(ConsList, _, _, _, UserEqCmp, ReservedTag, _, _), + Body = hlds_du_type(ConsList, _, _, _, UserEqCmp, _DirectArgCtors, + ReservedTag, _, _), module_info_get_cons_table(!.ModuleInfo, Ctors0), module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo), module_info_get_ctor_field_table(!.ModuleInfo, CtorFields0), @@ -491,7 +492,7 @@ merge_foreign_type_bodies(Target, MakeOptInterface, Body = Body1 ^ du_type_is_foreign_type := yes(ForeignTypeBody) ). merge_foreign_type_bodies(Target, MakeOptInterface, - Body0 @ hlds_du_type(_, _, _, _, _, _, _, _), + Body0 @ hlds_du_type(_, _, _, _, _, _, _, _, _), Body1 @ hlds_foreign_type(_), Body) :- merge_foreign_type_bodies(Target, MakeOptInterface, Body1, Body0, Body). merge_foreign_type_bodies(_, _, hlds_foreign_type(Body0), @@ -603,8 +604,8 @@ combine_status_abstract_imported(Status2, Status) :- :- pred convert_type_defn(type_defn::in, type_ctor::in, globals::in, hlds_type_body::out) is det. -convert_type_defn(parse_tree_du_type(Body, MaybeUserEqComp), TypeCtor, Globals, - HLDSBody) :- +convert_type_defn(parse_tree_du_type(Body, MaybeUserEqComp, + MaybeDirectArgCtors), TypeCtor, Globals, HLDSBody) :- % Initially, when we first see the `:- type' definition, % we assign the constructor tags assuming that there is no % `:- pragma reserve_tag' declaration for this type. @@ -615,33 +616,14 @@ convert_type_defn(parse_tree_du_type(Body, MaybeUserEqComp), TypeCtor, Globals, assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor, ReservedTagPragma, Globals, CtorTagMap, ReservedAddr, IsEnum), IsForeign = no, - ( - ReservedAddr = does_not_use_reserved_address, - map.to_assoc_list(CtorTagMap, CtorTagList), - CtorTagList = [ConsIdA - ConsTagA, ConsIdB - ConsTagB], - ConsIdA = cons(_, ArityA, _), - ConsIdB = cons(_, ArityB, _) - -> - ( - ArityB = 0, - ArityA > 0 - -> - CheaperTagTest = cheaper_tag_test(ConsIdA, ConsTagA, - ConsIdB, ConsTagB) - ; - ArityA = 0, - ArityB > 0 - -> - CheaperTagTest = cheaper_tag_test(ConsIdB, ConsTagB, - ConsIdA, ConsTagA) - ; - CheaperTagTest = no_cheaper_tag_test - ) + ( ReservedAddr = does_not_use_reserved_address -> + compute_cheaper_tag_test(CtorTagMap, CheaperTagTest) ; CheaperTagTest = no_cheaper_tag_test ), HLDSBody = hlds_du_type(Body, CtorTagMap, CheaperTagTest, IsEnum, - MaybeUserEqComp, ReservedTagPragma, ReservedAddr, IsForeign). + MaybeUserEqComp, MaybeDirectArgCtors, ReservedTagPragma, ReservedAddr, + IsForeign). convert_type_defn(parse_tree_eqv_type(Body), _, _, hlds_eqv_type(Body)). convert_type_defn(parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp), _, _, hlds_solver_type(SolverTypeDetails, MaybeUserEqComp)). diff --git a/compiler/bytecode_gen.m b/compiler/bytecode_gen.m index 2c7076171..a200f838c 100644 --- a/compiler/bytecode_gen.m +++ b/compiler/bytecode_gen.m @@ -777,6 +777,8 @@ map_cons_tag(no_tag, byte_no_tag). % this optimization is not important for the bytecode map_cons_tag(single_functor_tag, byte_unshared_tag(0)). map_cons_tag(unshared_tag(Primary), byte_unshared_tag(Primary)). +map_cons_tag(direct_arg_tag(_), _) :- + sorry($module, $pred, "bytecode with direct_arg_tag"). map_cons_tag(shared_remote_tag(Primary, Secondary), byte_shared_remote_tag(Primary, Secondary)). map_cons_tag(shared_local_tag(Primary, Secondary), diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m index 48789b8dd..002642447 100644 --- a/compiler/check_typeclass.m +++ b/compiler/check_typeclass.m @@ -1365,7 +1365,7 @@ is_valid_instance_type(ModuleInfo, ClassId, InstanceDefn, Type, is_valid_instance_type(ModuleInfo, ClassId, InstanceDefn, EqvType, N, _, !SeenTypes, !Specs) ; - ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _) + ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _, _) ; TypeBody = hlds_foreign_type(_) ; TypeBody = hlds_solver_type(_, _) ; TypeBody = hlds_abstract_type(_) @@ -1601,7 +1601,7 @@ check_pred_type_ambiguities(PredInfo, !ModuleInfo, !Specs) :- check_ctor_constraints(TypeCtor - TypeDefn, !ModuleInfo, !Specs) :- get_type_defn_body(TypeDefn, Body), ( - Body = hlds_du_type(Ctors, _, _, _, _, _, _, _), + Body = hlds_du_type(Ctors, _, _, _, _, _, _, _, _), list.foldl2(check_ctor_type_ambiguities(TypeCtor, TypeDefn), Ctors, !ModuleInfo, !Specs) ; diff --git a/compiler/code_info.m b/compiler/code_info.m index b99849a5e..935129216 100644 --- a/compiler/code_info.m +++ b/compiler/code_info.m @@ -1045,7 +1045,7 @@ lookup_cheaper_tag_test(CI, Type) = CheaperTagTest :- ( search_type_defn(CI, Type, TypeDefn), get_type_defn_body(TypeDefn, TypeBody), - TypeBody = hlds_du_type(_, _, CheaperTagTestPrime, _, _, _, _, _) + TypeBody = hlds_du_type(_, _, CheaperTagTestPrime, _, _, _, _, _, _) -> CheaperTagTest = CheaperTagTestPrime ; @@ -3833,7 +3833,7 @@ assign_expr_to_var(Var, Rval, Code, !CI) :- ( Lvals = [], var_locn_assign_expr_to_var(Var, Rval, Code, - VarLocnInfo0, VarLocnInfo) + VarLocnInfo0, VarLocnInfo) ; Lvals = [_ | _], unexpected($module, $pred, "non-var lvals") diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m index 60ba160a2..a4802bf70 100644 --- a/compiler/equiv_type.m +++ b/compiler/equiv_type.m @@ -779,11 +779,11 @@ replace_in_type_defn(Location, EqvMap, EqvInstMap, TypeCtor, TypeDefn0, TypeDefn !UsedModules), TypeDefn = parse_tree_eqv_type(TypeBody) ; - TypeDefn0 = parse_tree_du_type(TypeBody0, EqPred), + TypeDefn0 = parse_tree_du_type(TypeBody0, EqPred, DirectArgFunctors), replace_in_ctors_location(Location, EqvMap, TypeBody0, TypeBody, !VarSet, !EquivTypeInfo, !UsedModules), ContainsCirc = no, - TypeDefn = parse_tree_du_type(TypeBody, EqPred) + TypeDefn = parse_tree_du_type(TypeBody, EqPred, DirectArgFunctors) ; TypeDefn0 = parse_tree_solver_type(SolverDetails0, MaybeUserEqComp), SolverDetails0 = solver_type_details(RepresentationType0, InitPred, diff --git a/compiler/equiv_type_hlds.m b/compiler/equiv_type_hlds.m index ef3e19dd9..4a798d122 100644 --- a/compiler/equiv_type_hlds.m +++ b/compiler/equiv_type_hlds.m @@ -107,7 +107,7 @@ add_type_to_eqv_map(TypeCtor, Defn, !EqvMap, !EqvExportTypes) :- IsExported = no ) ; - ( Body = hlds_du_type(_, _, _, _, _, _, _, _) + ( Body = hlds_du_type(_, _, _, _, _, _, _, _, _) ; Body = hlds_foreign_type(_) ; Body = hlds_solver_type(_, _) ; Body = hlds_abstract_type(_) @@ -155,7 +155,7 @@ replace_in_type_defn(ModuleName, EqvMap, TypeCtor, !Defn, !MaybeRecompInfo) :- maybe_start_recording_expanded_items(ModuleName, TypeCtorSymName, !.MaybeRecompInfo, EquivTypeInfo0), ( - Body0 = hlds_du_type(Ctors0, _, _, _, _, _, _, _), + Body0 = hlds_du_type(Ctors0, _, _, _, _, _, _, _, _), equiv_type.replace_in_ctors(EqvMap, Ctors0, Ctors, TVarSet0, TVarSet, EquivTypeInfo0, EquivTypeInfo), Body = Body0 ^ du_type_ctors := Ctors diff --git a/compiler/export.m b/compiler/export.m index ae68689d8..9087f0a50 100644 --- a/compiler/export.m +++ b/compiler/export.m @@ -829,8 +829,8 @@ output_exported_enum_2(ModuleInfo, ExportedEnumInfo, !IO) :- unexpected($module, $pred, "invalid type for foreign_export_enum") ; TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest, - DuTypeKind, _MaybeUserEq, _ReservedTag, _ReservedAddr, - _IsForeignType), + DuTypeKind, _MaybeUserEq, _MaybeDirectArgCtors, + _ReservedTag, _ReservedAddr, _IsForeignType), ( ( DuTypeKind = du_type_kind_general ; DuTypeKind = du_type_kind_notag(_, _, _) @@ -904,6 +904,7 @@ foreign_const_name_and_tag(TypeCtor, Mapping, TagValues, Ctor, ; TagVal = table_io_decl_tag(_, _) ; TagVal = single_functor_tag ; TagVal = unshared_tag(_) + ; TagVal = direct_arg_tag(_) ; TagVal = shared_remote_tag(_, _) ; TagVal = shared_local_tag(_, _) ; TagVal = no_tag diff --git a/compiler/foreign.m b/compiler/foreign.m index af133362e..d8525e1e6 100644 --- a/compiler/foreign.m +++ b/compiler/foreign.m @@ -419,7 +419,7 @@ to_exported_type(ModuleInfo, Type) = ExportType :- ForeignTypeName, _, Assertions), ExportType = exported_type_foreign(ForeignTypeName, Assertions) ; - ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _) + ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _, _) ; TypeBody = hlds_eqv_type(_) ; TypeBody = hlds_solver_type(_, _) ; TypeBody = hlds_abstract_type(_) diff --git a/compiler/hlds_code_util.m b/compiler/hlds_code_util.m index da888ba5f..e6d25aa0f 100644 --- a/compiler/hlds_code_util.m +++ b/compiler/hlds_code_util.m @@ -1,7 +1,7 @@ %-----------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et %-----------------------------------------------------------------------------% -% Copyright (C) 2002-2010 The University of Melbourne. +% Copyright (C) 2002-2011 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. %-----------------------------------------------------------------------------% @@ -115,7 +115,7 @@ cons_id_to_tag(ModuleInfo, ConsId) = Tag:- lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn), hlds_data.get_type_defn_body(TypeDefn, TypeBody), ( - TypeBody = hlds_du_type(_, ConsTagTable, _, _, _, _, _, _), + TypeBody = hlds_du_type(_, ConsTagTable, _, _, _, _, _, _, _), map.lookup(ConsTagTable, ConsId, Tag) ; ( TypeBody = hlds_eqv_type(_) diff --git a/compiler/hlds_data.m b/compiler/hlds_data.m index 14a430080..c93b806fc 100644 --- a/compiler/hlds_data.m +++ b/compiler/hlds_data.m @@ -225,6 +225,9 @@ % User-defined equality and comparison preds. du_type_usereq :: maybe(unify_compare), + % Direct argument functors. + du_direct_arg_ctors :: maybe(list(sym_name_and_arity)), + % Is there a `:- pragma reserve_tag' pragma for this type? du_type_reserved_tag :: uses_reserved_tag, @@ -381,14 +384,22 @@ ; unshared_tag(tag_bits) % This is for constants or functors which can be distinguished % with just a primary tag. An "unshared" tag is one which fits - % on the bottom of a pointer (i.e. two bits for 32-bit + % on the bottom of a pointer (i.e. two bits for 32-bit % architectures, or three bits for 64-bit architectures), and is % used for just one functor. For constants we store a tagged zero, % for functors we store a tagged pointer to the argument vector. + ; direct_arg_tag(tag_bits) + % This is for functors which can be distinguished with just a + % primary tag. The primary tag says which of the type's functors + % (which must all be arity-1) this word represents. However, the + % body of the word is not a pointer to a cell holding the argument; + % it IS the value of that argument, which must be an untagged + % pointer to a cell. + ; shared_remote_tag(tag_bits, int) % This is for functors or constants which require more than just - % a two-bit tag. In this case, we use both a primary and a + % a primary tag. In this case, we use both a primary and a % secondary tag. Several functors share the primary tag and are % distinguished by the secondary tag. The secondary tag is stored % as the first word of the argument vector. (If it is a constant, @@ -505,6 +516,7 @@ get_primary_tag(Tag) = MaybePrimaryTag :- MaybePrimaryTag = yes(0) ; ( Tag = unshared_tag(PrimaryTag) + ; Tag = direct_arg_tag(PrimaryTag) ; Tag = shared_remote_tag(PrimaryTag, _SecondaryTag) ; Tag = shared_local_tag(PrimaryTag, _SecondaryTag) ), @@ -529,6 +541,7 @@ get_secondary_tag(Tag) = MaybeSecondaryTag :- ; Tag = no_tag ; Tag = reserved_address_tag(_) ; Tag = unshared_tag(_PrimaryTag) + ; Tag = direct_arg_tag(_PrimaryTag) ; Tag = single_functor_tag ), MaybeSecondaryTag = no @@ -544,7 +557,7 @@ get_secondary_tag(Tag) = MaybeSecondaryTag :- get_maybe_cheaper_tag_test(TypeBody) = CheaperTagTest :- ( - TypeBody = hlds_du_type(_, _, CheaperTagTest, _, _, _, _, _) + TypeBody = hlds_du_type(_, _, CheaperTagTest, _, _, _, _, _, _) ; ( TypeBody = hlds_eqv_type(_) ; TypeBody = hlds_foreign_type(_) diff --git a/compiler/hlds_out_module.m b/compiler/hlds_out_module.m index 26be9ec89..f3bfa129f 100644 --- a/compiler/hlds_out_module.m +++ b/compiler/hlds_out_module.m @@ -255,7 +255,8 @@ write_type_params_2(TVarSet, [P | Ps], !IO) :- write_type_body(Info, TypeCtor, TypeBody, Indent, TVarSet, !IO) :- ( TypeBody = hlds_du_type(Ctors, ConsTagMap, CheaperTagTest, DuTypeKind, - MaybeUserEqComp, ReservedTag, ReservedAddr, Foreign), + MaybeUserEqComp, MaybeDirectArgCtors, ReservedTag, ReservedAddr, + Foreign), io.write_string(" --->\n", !IO), ( CheaperTagTest = no_cheaper_tag_test @@ -324,7 +325,7 @@ write_type_body(Info, TypeCtor, TypeBody, Indent, TVarSet, !IO) :- write_constructors(TypeCtor, Indent, TVarSet, Ctors, ConsTagMap, !IO), MercInfo = Info ^ hoi_mercury_to_mercury, mercury_output_where_attributes(MercInfo, TVarSet, no, MaybeUserEqComp, - !IO), + MaybeDirectArgCtors, !IO), ( Foreign = yes(_), write_indent(Indent, !IO), @@ -349,7 +350,7 @@ write_type_body(Info, TypeCtor, TypeBody, Indent, TVarSet, !IO) :- TypeBody = hlds_solver_type(SolverTypeDetails, MaybeUserEqComp), MercInfo = Info ^ hoi_mercury_to_mercury, mercury_output_where_attributes(MercInfo, TVarSet, - yes(SolverTypeDetails), MaybeUserEqComp, !IO), + yes(SolverTypeDetails), MaybeUserEqComp, no, !IO), io.write_string(".\n", !IO) ). diff --git a/compiler/inst_check.m b/compiler/inst_check.m index 1492da3d9..2fcbfe47c 100644 --- a/compiler/inst_check.m +++ b/compiler/inst_check.m @@ -1,7 +1,7 @@ %-----------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et %-----------------------------------------------------------------------------% -% Copyright (C) 2006-2009 The University of Melbourne. +% Copyright (C) 2006-2009, 2011 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. %-----------------------------------------------------------------------------% @@ -351,7 +351,7 @@ strip_qualifiers(qualified(_, Name)) = unqualified(Name). get_du_functors_for_type_def(TypeDef) = Functors :- get_type_defn_body(TypeDef, TypeDefBody), ( - TypeDefBody = hlds_du_type(Constructors, _, _, _, _, _, _, _), + TypeDefBody = hlds_du_type(Constructors, _, _, _, _, _, _, _, _), Functors = list.map(constructor_to_sym_name_and_arity, Constructors) ; ( TypeDefBody = hlds_eqv_type(_) diff --git a/compiler/intermod.m b/compiler/intermod.m index 1194ec997..567b4d249 100644 --- a/compiler/intermod.m +++ b/compiler/intermod.m @@ -1035,7 +1035,8 @@ gather_types_2(TypeCtor, TypeDefn0, !Info) :- hlds_data.get_type_defn_body(TypeDefn0, TypeBody0), ( TypeBody0 = hlds_du_type(Ctors, Tags, CheaperTagTest, Enum, - MaybeUserEqComp0, ReservedTag, ReservedAddr, MaybeForeign0), + MaybeUserEqComp0, MaybeDirectArgCtors, ReservedTag, ReservedAddr, + MaybeForeign0), module_info_get_globals(ModuleInfo, Globals), globals.get_target(Globals, Target), @@ -1066,7 +1067,8 @@ gather_types_2(TypeCtor, TypeDefn0, !Info) :- MaybeForeign = MaybeForeign0 ), TypeBody = hlds_du_type(Ctors, Tags, CheaperTagTest, Enum, - MaybeUserEqComp, ReservedTag, ReservedAddr, MaybeForeign), + MaybeUserEqComp, MaybeDirectArgCtors, ReservedTag, ReservedAddr, + MaybeForeign), hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn) ; TypeBody0 = hlds_foreign_type(ForeignTypeBody0), @@ -1362,8 +1364,9 @@ write_type(OutInfo, TypeCtor - TypeDefn, !IO) :- hlds_data.get_type_defn_context(TypeDefn, Context), TypeCtor = type_ctor(Name, Arity), ( - Body = hlds_du_type(Ctors, _, _, _, MaybeUserEqComp, _, _, _), - TypeBody = parse_tree_du_type(Ctors, MaybeUserEqComp) + Body = hlds_du_type(Ctors, _, _, _, MaybeUserEqComp, MaybeDirectArgCtors, + _, _, _), + TypeBody = parse_tree_du_type(Ctors, MaybeUserEqComp, MaybeDirectArgCtors) ; Body = hlds_eqv_type(EqvType), TypeBody = parse_tree_eqv_type(EqvType) @@ -1470,13 +1473,13 @@ write_type(OutInfo, TypeCtor - TypeDefn, !IO) :- true ), ( - Body = hlds_du_type(_, ConsTagVals, _, DuTypeKind, _, _, _, _), + Body = hlds_du_type(_, ConsTagVals, _, DuTypeKind, _, _, _, _, _), DuTypeKind = du_type_kind_foreign_enum(Lang) -> map.foldl(gather_foreign_enum_value_pair, ConsTagVals, [], ForeignEnumVals), - Pragma = pragma_foreign_enum(Lang, Name, Arity, ForeignEnumVals), - ForeignItemPragma = item_pragma_info(user, Pragma, Context, -1), + ForeignPragma = pragma_foreign_enum(Lang, Name, Arity, ForeignEnumVals), + ForeignItemPragma = item_pragma_info(user, ForeignPragma, Context, -1), ForeignItem = item_pragma(ForeignItemPragma), mercury_output_item(MercInfo, ForeignItem, !IO) ; diff --git a/compiler/make_tags.m b/compiler/make_tags.m index 11351f7c0..fc8661a1f 100644 --- a/compiler/make_tags.m +++ b/compiler/make_tags.m @@ -60,12 +60,16 @@ :- interface. :- import_module hlds.hlds_data. +:- import_module hlds.hlds_module. :- import_module libs.globals. +:- import_module parse_tree.error_util. :- import_module parse_tree.prog_data. :- import_module list. :- import_module maybe. +%-----------------------------------------------------------------------------% + % assign_constructor_tags(Constructors, MaybeUserEq, TypeCtor, % ReservedTagPragma, Globals, TagValues, IsEnum): % @@ -80,18 +84,37 @@ globals::in, cons_tag_values::out, uses_reserved_address::out, du_type_kind::out) is det. + % For data types with exactly two alternatives, one of which is a constant, + % we can test against the constant (negating the result of the test, if + % needed), since a test against a constant is cheaper than a tag test. + % + % The type must not use reserved tags or reserved addresses. + % +:- pred compute_cheaper_tag_test(cons_tag_values::in, + maybe_cheaper_tag_test::out) is det. + + % Look for general du type definitions that can be converted into + % direct arg type definitions. + % +:- pred post_process_type_defns(module_info::in, module_info::out, + list(error_spec)::out) is det. + %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. +:- import_module hlds.hlds_pred. :- import_module libs.globals. :- import_module libs.options. +:- import_module mdbcomp.prim_data. :- import_module parse_tree.prog_type. +:- import_module assoc_list. :- import_module bool. :- import_module int. :- import_module map. +:- import_module pair. :- import_module require. %-----------------------------------------------------------------------------% @@ -185,8 +208,8 @@ assign_constructor_tags(Ctors, UserEqCmp, TypeCtor, ReservedTagPragma, Globals, ; MaxTag = max_num_tags(NumTagBits) - 1, separate_out_constants(Ctors, Constants, Functors), - assign_constant_tags(TypeCtor, Constants, !CtorTags, - InitTag, NextTag), + assign_constant_tags(TypeCtor, Constants, InitTag, NextTag, + !CtorTags), assign_unshared_tags(TypeCtor, Functors, NextTag, MaxTag, [], !CtorTags), ReservedAddr = does_not_use_reserved_address @@ -267,18 +290,17 @@ assign_reserved_symbolic_addresses(TypeCtor, [Ctor | Ctors], LeftOverConstants, ). :- pred assign_constant_tags(type_ctor::in, list(constructor)::in, - cons_tag_values::in, cons_tag_values::out, int::in, int::out) is det. + int::in, int::out, cons_tag_values::in, cons_tag_values::out) is det. +assign_constant_tags(TypeCtor, Constants, InitTag, NextTag, !CtorTags) :- % If there's no constants, don't do anything. Otherwise, allocate the % first tag for the constants, and give them all shared local tags % with that tag as the primary tag, and different secondary tags % starting from zero. % - % Note that if there's a single constant, we still give it a - % shared_local_tag rather than a unshared_tag. That's because + % Note that if there is a single constant, we still give it a + % shared_local_tag rather than a unshared_tag. That is because % deconstruction of the shared_local_tag is more efficient. - % -assign_constant_tags(TypeCtor, Constants, !CtorTags, InitTag, NextTag) :- ( Constants = [], NextTag = InitTag @@ -377,13 +399,371 @@ maybe_add_reserved_addresses(ReservedAddresses, Tag0) = Tag :- %-----------------------------------------------------------------------------% +compute_cheaper_tag_test(CtorTagMap, CheaperTagTest) :- + ( + map.to_assoc_list(CtorTagMap, CtorTagList), + CtorTagList = [ConsIdA - ConsTagA, ConsIdB - ConsTagB], + ConsIdA = cons(_, ArityA, _), + ConsIdB = cons(_, ArityB, _) + -> + ( + ArityB = 0, + ArityA > 0 + -> + CheaperTagTest = cheaper_tag_test(ConsIdA, ConsTagA, + ConsIdB, ConsTagB) + ; + ArityA = 0, + ArityB > 0 + -> + CheaperTagTest = cheaper_tag_test(ConsIdB, ConsTagB, + ConsIdA, ConsTagA) + ; + CheaperTagTest = no_cheaper_tag_test + ) + ; + CheaperTagTest = no_cheaper_tag_test + ). + +%-----------------------------------------------------------------------------% + +post_process_type_defns(!HLDS, Specs) :- + module_info_get_globals(!.HLDS, Globals), + globals.get_target(Globals, Target), + ( + Target = target_c, + globals.lookup_bool_option(Globals, record_term_sizes_as_words, + TermSizeWords), + globals.lookup_bool_option(Globals, record_term_sizes_as_cells, + TermSizeCells), + ( + TermSizeWords = no, + TermSizeCells = no + -> + module_info_get_type_table(!.HLDS, TypeTable0), + get_all_type_ctor_defns(TypeTable0, TypeCtorsDefns), + globals.lookup_int_option(Globals, num_tag_bits, NumTagBits), + MaxTag = max_num_tags(NumTagBits) - 1, + convert_direct_arg_functors(MaxTag, TypeCtorsDefns, + TypeTable0, TypeTable, [], Specs), + module_info_set_type_table(TypeTable, !HLDS) + ; + % We cannot use direct arg functors in term size grades. + Specs = [] + ) + ; + ( Target = target_il + ; Target = target_csharp + ; Target = target_java + ; Target = target_erlang + ; Target = target_asm + ; Target = target_x86_64 + ), + % Direct arg functors have not (yet) been implemented on these targets. + Specs = [] + ). + +:- pred convert_direct_arg_functors(int::in, + assoc_list(type_ctor, hlds_type_defn)::in, type_table::in, type_table::out, + list(error_spec)::in, list(error_spec)::out) is det. + +convert_direct_arg_functors(_, [], !TypeTable, !Specs). +convert_direct_arg_functors(MaxTag, [TypeCtor - TypeDefn | TypeCtorsDefns], + !TypeTable, !Specs) :- + convert_direct_arg_functors_if_suitable(MaxTag, TypeCtor, TypeDefn, + !TypeTable, !Specs), + convert_direct_arg_functors(MaxTag, TypeCtorsDefns, + !TypeTable, !Specs). + +:- pred convert_direct_arg_functors_if_suitable(int::in, + type_ctor::in, hlds_type_defn::in, type_table::in, type_table::out, + list(error_spec)::in, list(error_spec)::out) is det. + +convert_direct_arg_functors_if_suitable(MaxTag, TypeCtor, TypeDefn, + !TypeTable, !Specs) :- + get_type_defn_body(TypeDefn, Body), + ( + Body = hlds_du_type(Ctors, _ConsTagValues, _MaybeCheaperTagTest, + DuKind, MaybeUserEqComp, MaybeAssertedDirectArgCtors, + ReservedTag, ReservedAddr, MaybeForeign), + ( + Ctors = [_, _ | _], + DuKind = du_type_kind_general, + ReservedTag = does_not_use_reserved_tag, + ReservedAddr = does_not_use_reserved_address, + MaybeForeign = no, + TypeCtor = type_ctor(TypeCtorSymName, _TypeCtorArity), + sym_name_get_module_name(TypeCtorSymName, TypeCtorModule) + -> + get_type_defn_status(TypeDefn, TypeStatus), + ( + MaybeAssertedDirectArgCtors = yes(AssertedDirectArgFunctors) + ; + MaybeAssertedDirectArgCtors = no, + AssertedDirectArgFunctors = [] + ), + separate_out_constants(Ctors, Constants, Functors), + list.filter(is_direct_arg_ctor(!.TypeTable, TypeCtorModule, + TypeStatus, AssertedDirectArgFunctors), + Functors, DirectArgFunctors, NonDirectArgFunctors), + ( + DirectArgFunctors = [] + % We cannot use the direct argument representation for any + % functors. + ; + DirectArgFunctors = [_ | _], + some [!NextTag, !CtorTags] ( + !:NextTag = 0, + map.init(!:CtorTags), + assign_constant_tags(TypeCtor, Constants, + !NextTag, !CtorTags), + % We prefer to allocate primary tags to direct argument + % functors. + assign_direct_arg_tags(TypeCtor, DirectArgFunctors, + !NextTag, MaxTag, LeftOverDirectArgFunctors, !CtorTags), + assign_unshared_tags(TypeCtor, + LeftOverDirectArgFunctors ++ NonDirectArgFunctors, + !.NextTag, MaxTag, [], !CtorTags), + DirectArgConsTagValues = !.CtorTags + ), + compute_cheaper_tag_test(DirectArgConsTagValues, + MaybeCheaperTagTest), + DirectArgFunctorNames = + list.map(constructor_to_sym_name_and_arity, + DirectArgFunctors), + DirectArgBody = hlds_du_type(Ctors, DirectArgConsTagValues, + MaybeCheaperTagTest, DuKind, MaybeUserEqComp, + yes(DirectArgFunctorNames), ReservedTag, ReservedAddr, + MaybeForeign), + set_type_defn_body(DirectArgBody, TypeDefn, DirectArgTypeDefn), + replace_type_ctor_defn(TypeCtor, DirectArgTypeDefn, !TypeTable) + ), + check_incorrect_direct_arg_assertions(AssertedDirectArgFunctors, + NonDirectArgFunctors, !Specs) + ; + % We cannot use the direct argument representation for any + % functors. + true + ) + ; + ( Body = hlds_eqv_type(_) + ; Body = hlds_foreign_type(_) + ; Body = hlds_solver_type(_, _) + ; Body = hlds_abstract_type(_) + ) + % Leave these types alone. + ). + +:- pred is_direct_arg_ctor(type_table::in, module_name::in, import_status::in, + list(sym_name_and_arity)::in, constructor::in) is semidet. + +is_direct_arg_ctor(TypeTable, TypeCtorModule, TypeStatus, + AssertedDirectArgCtors, Ctor) :- + Ctor = ctor(ExistQTVars, ExistConstraints, ConsName, ConsArgs, + _CtorContext), + ExistQTVars = [], + ExistConstraints = [], + ConsArgs = [ConsArg], + Arity = 1, + ConsArg = ctor_arg(_MaybeFieldName, ArgType, _ArgContext), + type_to_ctor_and_args(ArgType, ArgTypeCtor, ArgTypeCtorArgTypes), + + ( + % Trust the `direct_arg' attribute of an imported type. + status_is_imported(TypeStatus) = yes, + list.contains(AssertedDirectArgCtors, ConsName / Arity) + -> + ArgCond = direct_arg_asserted + ; + % Tuples are always acceptable argument types as they are represented + % by word-aligned vector pointers. + % Strings are *not* always word-aligned (yet) so are not acceptable. + type_ctor_is_tuple(ArgTypeCtor) + -> + ArgCond = direct_arg_builtin_type + ; + ArgTypeCtorArgTypes = [], + % XXX We could let this be a subset of the type params, 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. + + search_type_ctor_defn(TypeTable, ArgTypeCtor, ArgTypeDefn), + get_type_defn_body(ArgTypeDefn, ArgBody), + ArgBody = hlds_du_type(ArgCtors, ArgConsTagValues, + ArgMaybeCheaperTagTest, ArgDuKind, _ArgMaybeUserEqComp, + ArgDirectArgCtors, ArgReservedTag, ArgReservedAddr, + ArgMaybeForeign), + ArgCtors = [_], + ArgMaybeCheaperTagTest = no_cheaper_tag_test, + ArgDuKind = du_type_kind_general, + ArgDirectArgCtors = no, + ArgReservedTag = does_not_use_reserved_tag, + ArgReservedAddr = does_not_use_reserved_address, + ArgMaybeForeign = no, + + map.to_assoc_list(ArgConsTagValues, ArgConsTagValueList), + ArgConsTagValueList = [ArgConsTagValue], + ArgConsTagValue = _ConsId - single_functor_tag, + + ( + status_defined_in_this_module(TypeStatus) = yes, + list.contains(AssertedDirectArgCtors, ConsName / Arity) + -> + ArgCond = direct_arg_asserted + ; + ArgTypeCtor = type_ctor(ArgTypeCtorSymName, _ArgTypeCtorArity), + sym_name_get_module_name(ArgTypeCtorSymName, ArgTypeCtorModule), + ( TypeCtorModule = ArgTypeCtorModule -> + get_type_defn_status(ArgTypeDefn, ArgTypeStatus), + ArgCond = direct_arg_same_module(ArgTypeStatus) + ; + ArgCond = direct_arg_different_module + ) + ) + ), + + check_direct_arg_cond(TypeStatus, ArgCond). + +:- type direct_arg_cond + ---> direct_arg_builtin_type + % The argument is of a builtin type that is represented with an + % untagged pointer. + + ; direct_arg_asserted + % A `where direct_arg' attribute asserts that the direct arg + % representation may be used for the constructor. + + ; direct_arg_same_module(import_status) + % The argument type is defined in the same module as the outer + % type, and has the given import status. + + ; direct_arg_different_module. + % The argument type is defined in a different module to the outer + % type. + +:- pred check_direct_arg_cond(import_status::in, direct_arg_cond::in) + is semidet. + +check_direct_arg_cond(TypeStatus, ArgCond) :- + ( + % If the outer type _definition_ is not exported from this module then + % the direct arg representation may be used. In the absence of + % intermodule optimisation, only this module can [de]construct values + % of this type. + ( TypeStatus = status_local + ; TypeStatus = status_abstract_exported + ) + ; + % If the outer type is opt-exported, another module may opt-import this + % type, but abstract-import the argument type. It could not then infer + % if the direct arg representation is required for any functors of the + % outer type. The problem is overcome by adding `where direct_arg' + % attributes to the opt-exported type definition in .opt files, + % which state the functors that require the direct arg representation. + TypeStatus = status_opt_exported + ; + % If the outer type is exported from this module, then the direct arg + % representation may be used, so long as any importing modules will + % infer the same thing. + ( TypeStatus = status_exported + ; TypeStatus = status_exported_to_submodules + ), + ( ArgCond = direct_arg_builtin_type + ; ArgCond = direct_arg_asserted + ; ArgCond = direct_arg_same_module(status_exported) + ; ArgCond = direct_arg_same_module(TypeStatus) + % If the outer type is exported to sub-modules only, the argument + % type only needs to be exported to sub-modules as well. + ) + ; + % The direct arg representation is required if the outer type is + % imported, and: + % - if the argument type is an acceptable builtin type + % - a `where direct_arg' attribute says so + % - if the argument type is imported from the same module + TypeStatus = status_imported(_), + ( ArgCond = direct_arg_builtin_type + ; ArgCond = direct_arg_asserted + ; ArgCond = direct_arg_same_module(status_imported(_)) + ) + ; + % If the outer type is opt-imported, there will always be a + % `where direct_arg' attribute on the type definition which states + % if the direct argument representation must be used. + ( TypeStatus = status_opt_imported + ; TypeStatus = status_abstract_imported + ), + ArgCond = direct_arg_asserted + ). + +:- pred assign_direct_arg_tags(type_ctor::in, list(constructor)::in, + int::in, int::out, int::in, list(constructor)::out, + cons_tag_values::in, cons_tag_values::out) is det. + +assign_direct_arg_tags(_, [], !Val, _, [], !CtorTags). +assign_direct_arg_tags(TypeCtor, [Ctor | Ctors], !Val, MaxTag, LeftOverCtors, + !CtorTags) :- + Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt), + ConsId = cons(Name, list.length(Args), TypeCtor), + ( + % If we are about to run out of unshared tags, stop, and return + % the leftovers. + !.Val = MaxTag, + Ctors = [_ | _] + -> + LeftOverCtors = [Ctor | Ctors] + ; + Tag = direct_arg_tag(!.Val), + % We call set instead of det_insert because we don't want types + % that erroneously contain more than one copy of a cons_id to crash + % the compiler. + map.set(ConsId, Tag, !CtorTags), + !:Val = !.Val + 1, + assign_direct_arg_tags(TypeCtor, Ctors, !Val, MaxTag, LeftOverCtors, + !CtorTags) + ). + +:- pred check_incorrect_direct_arg_assertions(list(sym_name_and_arity)::in, + list(constructor)::in, list(error_spec)::in, list(error_spec)::out) is det. + +check_incorrect_direct_arg_assertions(_AssertedDirectArgCtors, [], !Specs). +check_incorrect_direct_arg_assertions(AssertedDirectArgCtors, [Ctor | Ctors], + !Specs) :- + ( + Ctor = ctor(_, _, SymName, Args, Context), + list.length(Args, Arity), + list.contains(AssertedDirectArgCtors, SymName / Arity) + -> + Pieces = [words("Error:"), sym_name_and_arity(SymName / Arity), + words("cannot be represented as a direct pointer to its"), + words("sole argument."), nl], + Msg = simple_msg(Context, [always(Pieces)]), + Spec = error_spec(severity_error, phase_type_check, [Msg]), + !:Specs = [Spec | !.Specs] + ; + true + ), + check_incorrect_direct_arg_assertions(AssertedDirectArgCtors, Ctors, + !Specs). + +:- func constructor_to_sym_name_and_arity(constructor) = sym_name_and_arity. + +constructor_to_sym_name_and_arity(ctor(_, _, Name, Args, _)) = + Name / list.length(Args). + +%-----------------------------------------------------------------------------% +% +% Auxiliary functions and predicates. +% + :- func max_num_tags(int) = int. max_num_tags(NumTagBits) = MaxTags :- int.pow(2, NumTagBits, MaxTags). -%-----------------------------------------------------------------------------% - :- pred ctors_are_all_constants(list(constructor)::in) is semidet. ctors_are_all_constants([]). @@ -392,8 +772,6 @@ ctors_are_all_constants([Ctor | Rest]) :- Args = [], ctors_are_all_constants(Rest). -%-----------------------------------------------------------------------------% - :- pred separate_out_constants(list(constructor)::in, list(constructor)::out, list(constructor)::out) is det. @@ -412,4 +790,5 @@ separate_out_constants([Ctor | Ctors], Constants, Functors) :- ). %-----------------------------------------------------------------------------% +:- end_module hlds.make_tags. %-----------------------------------------------------------------------------% diff --git a/compiler/mercury_compile_front_end.m b/compiler/mercury_compile_front_end.m index 200a43da0..c889c94fc 100644 --- a/compiler/mercury_compile_front_end.m +++ b/compiler/mercury_compile_front_end.m @@ -92,6 +92,7 @@ :- import_module check_hlds.unused_imports. :- import_module hlds.hlds_error_util. :- import_module hlds.hlds_statistics. +:- import_module hlds.make_tags. :- import_module libs.file_util. :- import_module libs.globals. :- import_module libs.options. @@ -131,9 +132,17 @@ frontend_pass(QualInfo0, FoundUndefTypeError, FoundUndefModeError, !FoundError, ; FoundUndefTypeError = no, maybe_write_out_errors(Verbose, Globals, !HLDS, !Specs, !IO), + + maybe_write_string(Verbose, + "% Post-processing type definitions...\n", !IO), + post_process_type_defns(!HLDS, PostTypeSpecs), + PostTypeErrors = contains_errors(Globals, PostTypeSpecs), + bool.or(PostTypeErrors, !FoundError), + maybe_dump_hlds(!.HLDS, 3, "typedefn", !DumpInfo, !IO), + maybe_write_string(Verbose, "% Checking typeclasses...\n", !IO), check_typeclasses(!HLDS, QualInfo0, QualInfo, [], TypeClassSpecs), - !:Specs = TypeClassSpecs ++ !.Specs, + !:Specs = PostTypeSpecs ++ TypeClassSpecs ++ !.Specs, maybe_dump_hlds(!.HLDS, 5, "typeclass", !DumpInfo, !IO), set_module_recomp_info(QualInfo, !HLDS), @@ -145,16 +154,16 @@ frontend_pass(QualInfo0, FoundUndefTypeError, FoundUndefModeError, !FoundError, !:FoundError = yes ; TypeClassErrors = no, - frontend_pass_after_typecheck(FoundUndefModeError, + frontend_pass_after_typeclass_check(FoundUndefModeError, !FoundError, !HLDS, !DumpInfo, !Specs, !IO) ) ). -:- pred frontend_pass_after_typecheck(bool::in, bool::in, bool::out, +:- pred frontend_pass_after_typeclass_check(bool::in, bool::in, bool::out, module_info::in, module_info::out, dump_info::in, dump_info::out, list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det. -frontend_pass_after_typecheck(FoundUndefModeError, !FoundError, +frontend_pass_after_typeclass_check(FoundUndefModeError, !FoundError, !HLDS, !DumpInfo, !Specs, !IO) :- module_info_get_globals(!.HLDS, Globals), globals.lookup_bool_option(Globals, verbose, Verbose), diff --git a/compiler/mercury_to_mercury.m b/compiler/mercury_to_mercury.m index 84f2652b5..7b67901fa 100644 --- a/compiler/mercury_to_mercury.m +++ b/compiler/mercury_to_mercury.m @@ -359,8 +359,8 @@ bool::in, io::di, io::uo) is det. :- pred mercury_output_where_attributes(merc_out_info::in, tvarset::in, - maybe(solver_type_details)::in, maybe(unify_compare)::in, io::di, io::uo) - is det. + maybe(solver_type_details)::in, maybe(unify_compare)::in, + maybe(list(sym_name_and_arity))::in, io::di, io::uo) is det. :- func describe_error_term(varset(T), term(T)) = string. @@ -1928,7 +1928,7 @@ mercury_output_type_defn(Info, TVarSet, Name, TParams, TypeDefn, Context, mercury_output_type(TVarSet, no, Body, !IO), io.write_string(".\n", !IO) ; - TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp), + TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp, MaybeDirectArgs), mercury_output_begin_type_decl(non_solver_type, !IO), Args = list.map((func(V) = term.variable(V, Context)), TParams), construct_qualified_term(Name, Args, Context, TypeTerm), @@ -1936,7 +1936,7 @@ mercury_output_type_defn(Info, TVarSet, Name, TParams, TypeDefn, Context, io.write_string("\n\t--->\t", !IO), mercury_output_ctors(Ctors, TVarSet, !IO), mercury_output_where_attributes(Info, TVarSet, no, MaybeUserEqComp, - !IO), + MaybeDirectArgs, !IO), io.write_string(".\n", !IO) ; TypeDefn = parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp), @@ -1945,7 +1945,7 @@ mercury_output_type_defn(Info, TVarSet, Name, TParams, TypeDefn, Context, construct_qualified_term(Name, Args, Context, TypeTerm), mercury_output_term(TVarSet, no, TypeTerm, !IO), mercury_output_where_attributes(Info, TVarSet, yes(SolverTypeDetails), - MaybeUserEqComp, !IO), + MaybeUserEqComp, no, !IO), io.write_string(".\n", !IO) ; TypeDefn = parse_tree_foreign_type(ForeignType, MaybeUserEqComp, @@ -2007,7 +2007,7 @@ mercury_output_type_defn(Info, TVarSet, Name, TParams, TypeDefn, Context, ), io.write_string(")", !IO), mercury_output_where_attributes(Info, TVarSet, no, MaybeUserEqComp, - !IO), + no, !IO), io.write_string(".\n", !IO) ). @@ -2036,10 +2036,11 @@ mercury_output_begin_type_decl(IsSolverType, !IO) :- ). mercury_output_where_attributes(Info, TVarSet, - MaybeSolverTypeDetails, MaybeUserEqComp, !IO) :- + MaybeSolverTypeDetails, MaybeUserEqComp, MaybeDirectArgs, !IO) :- ( MaybeSolverTypeDetails = no, - MaybeUserEqComp = no + MaybeUserEqComp = no, + MaybeDirectArgs = no -> true ; @@ -2090,9 +2091,23 @@ mercury_output_where_attributes(Info, TVarSet, ( MaybeComparePred = yes(ComparePredName), io.write_string("comparison is ", !IO), - mercury_output_bracketed_sym_name(ComparePredName, !IO) + mercury_output_bracketed_sym_name(ComparePredName, !IO), + ( + MaybeDirectArgs = yes(_), + io.write_string(",\n\t\t", !IO) + ; + MaybeDirectArgs = no + ) ; MaybeComparePred = no + ), + ( + MaybeDirectArgs = yes(DirectArgFunctors), + io.write_string("direct_arg is [", !IO), + mercury_output_direct_arg_functors(DirectArgFunctors, !IO), + io.write_string("]", !IO) + ; + MaybeDirectArgs = no ) ). @@ -2223,6 +2238,12 @@ mercury_output_ctor_arg_name_prefix(yes(Name), !IO) :- mercury_output_bracketed_sym_name(Name, !IO), io.write_string(" :: ", !IO). +:- pred mercury_output_direct_arg_functors(list(sym_name_and_arity)::in, + io::di, io::uo) is det. + +mercury_output_direct_arg_functors(Ctors, !IO) :- + io.write_list(Ctors, ", ", mercury_format_sym_name_and_arity, !IO). + %-----------------------------------------------------------------------------% :- pred mercury_format_pred_or_func_decl(pred_or_func::in, tvarset::in, @@ -4715,6 +4736,14 @@ mercury_format_sym_name(Name, NextToGraphicToken, !U) :- mercury_format_quoted_atom(PredName, NextToGraphicToken, !U) ). +:- pred mercury_format_sym_name_and_arity(sym_name_and_arity::in, U::di, U::uo) + is det <= output(U). + +mercury_format_sym_name_and_arity(Name / Arity, !U) :- + mercury_format_sym_name(Name, !U), + add_char('/', !U), + add_int(Arity, !U). + :- pred mercury_quote_atom(string::in, needs_quotes::in, io::di, io::uo) is det. diff --git a/compiler/ml_proc_gen.m b/compiler/ml_proc_gen.m index a2587a953..3f205328e 100644 --- a/compiler/ml_proc_gen.m +++ b/compiler/ml_proc_gen.m @@ -173,7 +173,7 @@ foreign_type_required_imports(Target, _TypeCtor - TypeDefn) = Imports :- unexpected($module, $pred, "no IL type") ) ; - ( TypeBody = hlds_du_type(_, _, _,_, _, _, _, _) + ( TypeBody = hlds_du_type(_, _, _,_, _, _, _, _, _) ; TypeBody = hlds_eqv_type(_) ; TypeBody = hlds_solver_type(_, _) ; TypeBody = hlds_abstract_type(_) diff --git a/compiler/ml_switch_gen.m b/compiler/ml_switch_gen.m index 9bab5b285..7bf263fbe 100644 --- a/compiler/ml_switch_gen.m +++ b/compiler/ml_switch_gen.m @@ -582,6 +582,7 @@ ml_tagged_cons_id_to_match_cond(MLDS_Type, TaggedConsId, MatchCond) :- ; Tag = table_io_decl_tag(_, _) ; Tag = single_functor_tag ; Tag = unshared_tag(_) + ; Tag = direct_arg_tag(_) ; Tag = shared_remote_tag(_, _) ; Tag = shared_local_tag(_, _) ; Tag = no_tag diff --git a/compiler/ml_tag_switch.m b/compiler/ml_tag_switch.m index 5a690b890..9bda742ab 100644 --- a/compiler/ml_tag_switch.m +++ b/compiler/ml_tag_switch.m @@ -169,7 +169,9 @@ gen_ptag_case(PtagCase, CodeMap, Var, CanFail, CodeModel, PtagCountMap, "secondary tag locations differ"), map.to_assoc_list(GoalMap, GoalList), ( - SecTagLocn = sectag_none, + ( SecTagLocn = sectag_none + ; SecTagLocn = sectag_none_direct_arg + ), % There is no secondary tag, so there is no switch on it. ( GoalList = [], @@ -283,7 +285,9 @@ gen_stag_switch(Cases, CodeMap, PrimaryTag, StagLocn, Var, CodeModel, STagRval = ml_gen_secondary_tag_rval(ModuleInfo, PrimaryTag, VarType, VarRval) ; - StagLocn = sectag_none, + ( StagLocn = sectag_none + ; StagLocn = sectag_none_direct_arg + ), unexpected($module, $pred, "no stag") ), diff --git a/compiler/ml_type_gen.m b/compiler/ml_type_gen.m index dad7e31ef..f4510fc37 100644 --- a/compiler/ml_type_gen.m +++ b/compiler/ml_type_gen.m @@ -181,7 +181,7 @@ ml_gen_type_defn_2(ModuleInfo, TypeCtor, TypeDefn, !Defns) :- % The same issue arises for some of the cases below. ; TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest, DuTypeKind, - MaybeUserEqComp, _ReservedTag, _, _), + MaybeUserEqComp, _MaybeDirectArgCtors, _ReservedTag, _, _), % XXX We probably shouldn't ignore _ReservedTag. ml_gen_equality_members(MaybeUserEqComp, MaybeEqualityMembers), ( @@ -325,6 +325,7 @@ ml_gen_enum_constant(Context, TypeCtor, ConsTagValues, MLDS_Type, Ctor) ; TagVal = table_io_decl_tag(_, _) ; TagVal = single_functor_tag ; TagVal = unshared_tag(_) + ; TagVal = direct_arg_tag(_) ; TagVal = shared_remote_tag(_, _) ; TagVal = shared_local_tag(_, _) ; TagVal = no_tag @@ -868,6 +869,7 @@ ml_tag_uses_base_class(Tag) = UsesBaseClass :- ; Tag = deep_profiling_proc_layout_tag(_, _) ; Tag = table_io_decl_tag(_, _) ; Tag = unshared_tag(_) + ; Tag = direct_arg_tag(_) ; Tag = shared_remote_tag(_, _) ; Tag = shared_local_tag(_, _) ; Tag = no_tag @@ -1205,8 +1207,8 @@ ml_gen_exported_enum(_ModuleInfo, TypeTable, ExportedEnumInfo, unexpected($module, $pred, "invalid type") ; TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest, - _IsEnumOrDummy, _MaybeUserEq, _ReservedTag, _ReservedAddr, - _IsForeignType), + _IsEnumOrDummy, _MaybeUserEq, _MaybeDirectArgCtors, + _ReservedTag, _ReservedAddr, _IsForeignType), ml_gen_type_name(TypeCtor, QualifiedClassName, MLDS_ClassArity), MLDS_Type = mlds_class_type(QualifiedClassName, MLDS_ClassArity, mlds_enum), @@ -1246,6 +1248,7 @@ generate_foreign_enum_constant(TypeCtor, Mapping, TagValues, MLDS_Type, Ctor, ; TagVal = table_io_decl_tag(_, _) ; TagVal = single_functor_tag ; TagVal = unshared_tag(_) + ; TagVal = direct_arg_tag(_) ; TagVal = shared_remote_tag(_, _) ; TagVal = shared_local_tag(_, _) ; TagVal = no_tag diff --git a/compiler/ml_unify_gen.m b/compiler/ml_unify_gen.m index 7ab7d181e..9e7d0c190 100644 --- a/compiler/ml_unify_gen.m +++ b/compiler/ml_unify_gen.m @@ -149,6 +149,10 @@ :- import_module term. :- import_module varset. +:- inst no_or_direct_arg_tag + ---> no_tag + ; direct_arg_tag(ground). + %-----------------------------------------------------------------------------% ml_gen_unification(Unification, CodeModel, Context, Statements, !Info) :- @@ -297,13 +301,16 @@ ml_gen_construct_tag(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr, ml_gen_construct_tag(ThisTag, Type, Var, ConsId, Args, ArgModes, TakeAddr, HowToConstruct, Context, Statements, !Info) ; - Tag = no_tag, + ( Tag = no_tag + ; Tag = direct_arg_tag(_) + ), ( Args = [ArgVar], - ArgModes = [_ArgMode] + ArgModes = [ArgMode] -> ml_gen_var(!.Info, Var, VarLval), ml_gen_info_get_module_info(!.Info, ModuleInfo), + MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type), ( ml_gen_info_search_const_var(!.Info, ArgVar, ArgGroundTerm) -> ArgGroundTerm = ml_ground_term(ArgRval, _ArgType, MLDS_ArgType), @@ -311,27 +318,35 @@ ml_gen_construct_tag(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr, ml_gen_box_const_rval(ModuleInfo, Context, MLDS_ArgType, ArgRval, Rval0, GlobalData0, GlobalData), ml_gen_info_set_global_data(GlobalData, !Info), - MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type), - Rval = ml_unop(cast(MLDS_Type), Rval0), + Rval = ml_cast_cons_tag(MLDS_Type, Tag, Rval0), GroundTerm = ml_ground_term(Rval, Type, MLDS_Type), - ml_gen_info_set_const_var(Var, GroundTerm, !Info) + ml_gen_info_set_const_var(Var, GroundTerm, !Info), + Statement = ml_gen_assign(VarLval, Rval, Context), + Statements = [Statement] ; - ml_gen_var(!.Info, ArgVar, ArgVarLval), + ml_gen_var(!.Info, ArgVar, ArgLval), ml_variable_type(!.Info, ArgVar, ArgType), - ArgRval = ml_lval(ArgVarLval), - ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, Type, - native_if_possible, ArgRval, Rval) - ), - Statement = ml_gen_assign(VarLval, Rval, Context), - Statements = [Statement] + ( + Tag = no_tag, + ArgRval = ml_lval(ArgLval), + ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, Type, + native_if_possible, ArgRval, Rval), + Statement = ml_gen_assign(VarLval, Rval, Context), + Statements = [Statement] + ; + Tag = direct_arg_tag(Ptag), + ml_variable_type(!.Info, Var, VarType), + ml_gen_direct_arg_construct(ModuleInfo, ArgMode, Ptag, + ArgLval, ArgType, VarLval, VarType, Context, Statements) + ) + ) ; + Tag = no_tag, unexpected($module, $pred, "no_tag: arity != 1") + ; + Tag = direct_arg_tag(_), + unexpected($module, $pred, "direct_arg_tag: arity != 1") ) - ; - % Lambda expressions. - Tag = closure_tag(PredId, ProcId, _EvalMethod), - ml_gen_closure(PredId, ProcId, Var, Args, ArgModes, HowToConstruct, - Context, Statements, !Info) ; % Ordinary compound terms. ( @@ -349,6 +364,11 @@ ml_gen_construct_tag(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr, ml_gen_compound(ConsId, Ptag, MaybeStag, UsesBaseClass, Var, Args, ArgModes, TakeAddr, HowToConstruct, Context, Statements, !Info) + ; + % Lambda expressions. + Tag = closure_tag(PredId, ProcId, _EvalMethod), + ml_gen_closure(PredId, ProcId, Var, Args, ArgModes, HowToConstruct, + Context, Statements, !Info) ; % Constants. ( Tag = int_tag(_) @@ -467,6 +487,9 @@ ml_gen_constant(Tag, VarType, MLDS_VarType, Rval, !Info) :- ; Tag = unshared_tag(_), unexpected($module, $pred, "unshared_tag") + ; + Tag = direct_arg_tag(_), + unexpected($module, $pred, "direct_arg_tag") ; Tag = shared_remote_tag(_, _), unexpected($module, $pred, "shared_remote_tag") @@ -1116,6 +1139,19 @@ constructor_arg_types(ModuleInfo, ConsId, ArgTypes, Type) = ConsArgTypes :- ml_gen_mktag(Tag) = ml_unop(std_unop(mktag), ml_const(mlconst_int(Tag))). +:- func ml_cast_cons_tag(mlds_type::in, cons_tag::in(no_or_direct_arg_tag), + mlds_rval::in) = (mlds_rval::out) is det. + +ml_cast_cons_tag(Type, Tag, Rval) = CastRval :- + ( + Tag = no_tag, + TagRval = Rval + ; + Tag = direct_arg_tag(Ptag), + TagRval = ml_mkword(Ptag, Rval) + ), + CastRval = ml_unop(cast(Type), TagRval). + :- pred ml_gen_box_or_unbox_const_rval_list(module_info::in, list(mer_type)::in, list(mer_type)::in, list(mlds_rval)::in, prog_context::in, list(mlds_rval)::out, @@ -1401,6 +1437,21 @@ ml_gen_det_deconstruct_tag(Tag, Type, Var, ConsId, Args, Modes, Context, ; unexpected($module, $pred, "no_tag: arity != 1") ) + ; + Tag = direct_arg_tag(Ptag), + ( + Args = [Arg], + Modes = [Mode] + -> + ml_variable_type(!.Info, Arg, ArgType), + ml_gen_var(!.Info, Arg, ArgLval), + ml_gen_var(!.Info, Var, VarLval), + ml_gen_info_get_module_info(!.Info, ModuleInfo), + ml_gen_direct_arg_deconstruct(ModuleInfo, Mode, Ptag, + ArgLval, ArgType, VarLval, Type, Context, Statements) + ; + unexpected($module, $pred, "direct_arg_tag: arity != 1") + ) ; ( Tag = single_functor_tag ; Tag = unshared_tag(_UnsharedTag) @@ -1436,7 +1487,9 @@ ml_tag_offset_and_argnum(Tag, TagBits, OffSet, ArgNum) :- OffSet = 0, ArgNum = 1 ; - Tag = unshared_tag(UnsharedTag), + ( Tag = unshared_tag(UnsharedTag) + ; Tag = direct_arg_tag(UnsharedTag) + ), TagBits = UnsharedTag, OffSet = 0, ArgNum = 1 @@ -1711,6 +1764,114 @@ ml_gen_sub_unify(ModuleInfo, Mode, ArgLval, ArgType, FieldLval, FieldType, unexpected($module, $pred, "some strange unify") ). +:- pred ml_gen_direct_arg_construct(module_info::in, uni_mode::in, int::in, + mlds_lval::in, mer_type::in, mlds_lval::in, mer_type::in, prog_context::in, + list(statement)::out) is det. + +ml_gen_direct_arg_construct(ModuleInfo, Mode, Ptag, + ArgLval, ArgType, VarLval, VarType, Context, Statements) :- + Mode = ((LI - RI) -> (LF - RF)), + mode_to_arg_mode(ModuleInfo, (LI -> LF), ArgType, LeftMode), + mode_to_arg_mode(ModuleInfo, (RI -> RF), ArgType, RightMode), + ( + % Skip dummy argument types, since they will not have been declared. + ( check_dummy_type(ModuleInfo, ArgType) = is_dummy_type + ; check_dummy_type(ModuleInfo, VarType) = is_dummy_type + ) + -> + unexpected($module, $pred, "dummy unify") + ; + % Both input: it's a test unification. + LeftMode = top_in, + RightMode = top_in + -> + % This shouldn't happen, since mode analysis should avoid creating + % any tests in the arguments of a construction or deconstruction + % unification. + unexpected($module, $pred, "test in arg of [de]construction") + ; + % Input - output: it's an assignment to the RHS. + LeftMode = top_in, + RightMode = top_out + -> + unexpected($module, $pred, "left-to-right data flow in construction") + ; + % Output - input: it's an assignment to the LHS. + LeftMode = top_out, + RightMode = top_in + -> + ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, VarType, + native_if_possible, ml_lval(ArgLval), ArgRval), + MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, VarType), + CastRval = ml_unop(cast(MLDS_Type), ml_mkword(Ptag, ArgRval)), + Statement = ml_gen_assign(VarLval, CastRval, Context), + Statements = [Statement] + ; + % Unused - unused: the unification has no effect. + LeftMode = top_unused, + RightMode = top_unused + -> + Statements = [] + ; + unexpected($module, $pred, "some strange unify") + ). + +:- pred ml_gen_direct_arg_deconstruct(module_info::in, uni_mode::in, int::in, + mlds_lval::in, mer_type::in, mlds_lval::in, mer_type::in, prog_context::in, + list(statement)::out) is det. + +ml_gen_direct_arg_deconstruct(ModuleInfo, Mode, Ptag, + ArgLval, ArgType, VarLval, VarType, Context, Statements) :- + Mode = ((LI - RI) -> (LF - RF)), + mode_to_arg_mode(ModuleInfo, (LI -> LF), ArgType, LeftMode), + mode_to_arg_mode(ModuleInfo, (RI -> RF), ArgType, RightMode), + ( + % Skip dummy argument types, since they will not have been declared. + ( check_dummy_type(ModuleInfo, ArgType) = is_dummy_type + ; check_dummy_type(ModuleInfo, VarType) = is_dummy_type + ) + -> + unexpected($module, $pred, "dummy unify") + ; + % Both input: it's a test unification. + LeftMode = top_in, + RightMode = top_in + -> + % This shouldn't happen, since mode analysis should avoid creating + % any tests in the arguments of a construction or deconstruction + % unification. + unexpected($module, $pred, "test in arg of [de]construction") + ; + % Input - output: it's an assignment to the RHS. + LeftMode = top_in, + RightMode = top_out + -> + ml_gen_box_or_unbox_rval(ModuleInfo, VarType, ArgType, + native_if_possible, ml_lval(VarLval), VarRval), + MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, ArgType), + CastRval = ml_unop(cast(MLDS_Type), + ml_binop(body, VarRval, ml_const(mlconst_int(Ptag)))), + Statement = ml_gen_assign(ArgLval, CastRval, Context), + Statements = [Statement] + ; + % Output - input: it's an assignment to the LHS. + LeftMode = top_out, + RightMode = top_in + -> + ml_gen_box_or_unbox_rval(ModuleInfo, ArgType, VarType, + native_if_possible, ml_lval(ArgLval), ArgRval), + Statement = ml_gen_assign(VarLval, ml_mkword(Ptag, ArgRval), Context), + Statements = [Statement] + ; + % Unused - unused: the unification has no effect. + LeftMode = top_unused, + RightMode = top_unused + -> + Statements = [] + ; + unexpected($module, $pred, "some strange unify") + ). + %-----------------------------------------------------------------------------% % Generate a semidet deconstruction. A semidet deconstruction unification @@ -1822,7 +1983,9 @@ ml_gen_tag_test_rval(Tag, Type, ModuleInfo, Rval) = TagTestRval :- Tag = single_functor_tag, TagTestRval = ml_const(mlconst_true) ; - Tag = unshared_tag(UnsharedTagNum), + ( Tag = unshared_tag(UnsharedTagNum) + ; Tag = direct_arg_tag(UnsharedTagNum) + ), RvalTag = ml_unop(std_unop(tag), Rval), UnsharedTag = ml_unop(std_unop(mktag), ml_const(mlconst_int(UnsharedTagNum))), @@ -1922,7 +2085,7 @@ ml_gen_hl_tag_field_id(ModuleInfo, Type) = FieldId :- hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody), ( TypeDefnBody = - hlds_du_type(Ctors, TagValues, _, _, _, _ReservedTag, _, _), + hlds_du_type(Ctors, TagValues, _, _, _, _, _ReservedTag, _, _), % XXX We probably shouldn't ignore ReservedTag here. ( some [Ctor] ( @@ -2135,14 +2298,16 @@ ml_gen_ground_term_conjunct_tag(ModuleInfo, Target, HighLevelData, VarTypes, VarTypes, Var, VarType, MLDS_Type, ConsId, ThisTag, Args, Context, !GlobalData, !GroundTermMap) ; - ConsTag = no_tag, + ( ConsTag = no_tag + ; ConsTag = direct_arg_tag(_) + ), ( Args = [Arg], map.det_remove(Arg, ArgGroundTerm, !GroundTermMap), ArgGroundTerm = ml_ground_term(ArgRval, _ArgType, MLDS_ArgType), ml_gen_box_const_rval(ModuleInfo, Context, MLDS_ArgType, ArgRval, Rval0, !GlobalData), - Rval = ml_unop(cast(MLDS_Type), Rval0), + Rval = ml_cast_cons_tag(MLDS_Type, ConsTag, Rval0), GroundTerm = ml_ground_term(Rval, VarType, MLDS_Type), map.det_insert(Var, GroundTerm, !GroundTermMap) ; diff --git a/compiler/module_qual.m b/compiler/module_qual.m index fc4a8a9a8..d7cdab245 100644 --- a/compiler/module_qual.m +++ b/compiler/module_qual.m @@ -999,15 +999,17 @@ update_import_status(md_include_module(_), !Info, yes) :- mq_info::in, mq_info::out, list(error_spec)::in, list(error_spec)::out) is det. -qualify_type_defn(parse_tree_du_type(Ctors0, MaybeUserEqComp0), - parse_tree_du_type(Ctors, MaybeUserEqComp), +qualify_type_defn( + parse_tree_du_type(Ctors0, MaybeUserEqComp0, MaybeDirectArgCtors0), + parse_tree_du_type(Ctors, MaybeUserEqComp, MaybeDirectArgCtors), !Info, !Specs) :- qualify_constructors(Ctors0, Ctors, !Info, !Specs), % 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. + MaybeUserEqComp = MaybeUserEqComp0, + MaybeDirectArgCtors = MaybeDirectArgCtors0. qualify_type_defn(parse_tree_eqv_type(Type0), parse_tree_eqv_type(Type), !Info, !Specs) :- qualify_type(Type0, Type, !Info, !Specs). diff --git a/compiler/modules.m b/compiler/modules.m index 53beadbe6..a692ddee4 100644 --- a/compiler/modules.m +++ b/compiler/modules.m @@ -937,10 +937,10 @@ insert_type_defn(New, [Head | Tail], Result) :- make_impl_type_abstract(TypeDefnMap, !TypeDefnPairs) :- ( - !.TypeDefnPairs = - [parse_tree_du_type(Ctors, MaybeEqCmp) - ItemTypeDefn0], + !.TypeDefnPairs = [TypeDefn0 - ItemTypeDefn0], + TypeDefn0 = parse_tree_du_type(Ctors, MaybeEqCmp, MaybeDirectArgCtors), not constructor_list_represents_dummy_argument_type(TypeDefnMap, - Ctors, MaybeEqCmp) + Ctors, MaybeEqCmp, MaybeDirectArgCtors) -> Defn = parse_tree_abstract_type(non_solver_type), ItemTypeDefn = ItemTypeDefn0 ^ td_ctor_defn := Defn, @@ -960,18 +960,19 @@ make_impl_type_abstract(TypeDefnMap, !TypeDefnPairs) :- % 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(unify_compare)::in) is semidet. + list(constructor)::in, maybe(unify_compare)::in, + maybe(list(sym_name_and_arity))::in) is semidet. constructor_list_represents_dummy_argument_type(TypeDefnMap, - Ctors, MaybeEqCmp) :- + Ctors, MaybeEqCmp, MaybeDirectArgCtors) :- constructor_list_represents_dummy_argument_type_2(TypeDefnMap, - Ctors, MaybeEqCmp, []). + Ctors, MaybeEqCmp, MaybeDirectArgCtors, []). :- pred constructor_list_represents_dummy_argument_type_2(type_defn_map::in, - list(constructor)::in, maybe(unify_compare)::in, list(mer_type)::in) - is semidet. + list(constructor)::in, maybe(unify_compare)::in, + maybe(list(sym_name_and_arity))::in, list(mer_type)::in) is semidet. -constructor_list_represents_dummy_argument_type_2(TypeDefnMap, [Ctor], no, +constructor_list_represents_dummy_argument_type_2(TypeDefnMap, [Ctor], no, no, CoveredTypes) :- Ctor = ctor(ExistQTVars, Constraints, _Name, Args, _Context), ExistQTVars = [], @@ -1006,10 +1007,11 @@ ctor_arg_is_dummy_type(TypeDefnMap, Type, CoveredTypes0) = IsDummyType :- % dummy type? multi_map.search(TypeDefnMap, TypeCtor, TypeDefns), list.member(TypeDefn - _, TypeDefns), - TypeDefn = parse_tree_du_type(TypeCtors, MaybeEqCmp), + TypeDefn = parse_tree_du_type(TypeCtors, MaybeEqCmp, + MaybeDirectArgCtors), CoveredTypes = [Type | CoveredTypes0], constructor_list_represents_dummy_argument_type_2(TypeDefnMap, - TypeCtors, MaybeEqCmp, CoveredTypes) + TypeCtors, MaybeEqCmp, MaybeDirectArgCtors, CoveredTypes) -> IsDummyType = yes ; @@ -1146,9 +1148,9 @@ accumulate_abs_impl_exported_type_lhs(InterfaceTypeMap, BothTypesMap, -> set.insert(TypeCtor, !AbsEqvLhsTypeCtors) ; - TypeDefn = parse_tree_du_type(Ctors, MaybeEqCmp), + TypeDefn = parse_tree_du_type(Ctors, MaybeEqCmp, MaybeDirectArgCtors), constructor_list_represents_dummy_argument_type(BothTypesMap, - Ctors, MaybeEqCmp) + Ctors, MaybeEqCmp, MaybeDirectArgCtors) -> set.insert(TypeCtor, !DummyTypeCtors) ; @@ -1184,7 +1186,7 @@ accumulate_abs_eqv_type_rhs_2(ImplTypeMap, TypeDefn - _, set.union(NewRhsTypeCtors, !AbsEqvRhsTypeCtors), set.fold3(accumulate_abs_impl_exported_type_rhs(ImplTypeMap), NewRhsTypeCtors, !AbsEqvRhsTypeCtors, set.init, _, !Modules) - ; TypeDefn = parse_tree_du_type(Ctors, _) -> + ; TypeDefn = parse_tree_du_type(Ctors, _, _) -> % There must exist a foreign type alternative to this type. As the du % type will be exported, we require the types of all the fields. ctors_to_type_ctor_set(Ctors, set.init, RhsTypeCtors), @@ -1587,8 +1589,9 @@ pragma_allowed_in_interface(Pragma) = Allowed :- Allowed = no ; % Note that the parser will strip out `source_file' pragmas anyway, - % and that `reserve_tag' must be in the interface iff the corresponding - % type definition is in the interface. This is checked in make_hlds. + % and that `reserve_tag' and `direct_arg' must be in the interface iff + % the corresponding type definition is in the interface. This is + % checked in make_hlds. ( Pragma = pragma_foreign_enum(_, _, _, _) ; Pragma = pragma_foreign_import_module(_, _) ; Pragma = pragma_obsolete(_, _) @@ -3924,7 +3927,7 @@ make_abstract_defn(Item, ShortInterfaceKind, AbstractItem) :- Item = item_type_defn(ItemTypeDefn), TypeDefn = ItemTypeDefn ^ td_ctor_defn, ( - TypeDefn = parse_tree_du_type(_, _), + TypeDefn = parse_tree_du_type(_, _, _), IsSolverType = non_solver_type, % For the `.int2' files, we need the full definitions of % discriminated union types. Even if the functors for a type @@ -3982,9 +3985,11 @@ make_abstract_unify_compare(Item, int2, AbstractItem) :- Item = item_type_defn(ItemTypeDefn), TypeDefn = ItemTypeDefn ^ td_ctor_defn, ( - TypeDefn = parse_tree_du_type(Constructors, yes(_UserEqComp)), - AbstractTypeDefn = parse_tree_du_type(Constructors, yes( - abstract_noncanonical_type(non_solver_type))) + TypeDefn = parse_tree_du_type(Constructors, yes(_UserEqComp), + MaybeDirectArgCtors), + MaybeUserEqComp = yes(abstract_noncanonical_type(non_solver_type)), + AbstractTypeDefn = parse_tree_du_type(Constructors, MaybeUserEqComp, + MaybeDirectArgCtors) ; TypeDefn = parse_tree_foreign_type(ForeignType, yes(_UserEqComp), Assertions), diff --git a/compiler/post_term_analysis.m b/compiler/post_term_analysis.m index 19f2cc842..320cf3ad5 100644 --- a/compiler/post_term_analysis.m +++ b/compiler/post_term_analysis.m @@ -212,7 +212,7 @@ special_pred_needs_term_check(ModuleInfo, SpecialPredId, TypeDefn) :- unify_compare::out) is semidet. get_user_unify_compare(_ModuleInfo, TypeBody, UnifyCompare) :- - TypeBody = hlds_du_type(_, _, _, _, yes(UnifyCompare), _, _, _). + TypeBody = hlds_du_type(_, _, _, _, yes(UnifyCompare), _, _, _, _). get_user_unify_compare(ModuleInfo, TypeBody, UnifyCompare) :- TypeBody = hlds_foreign_type(ForeignTypeBody), foreign_type_body_has_user_defined_eq_comp_pred(ModuleInfo, diff --git a/compiler/post_typecheck.m b/compiler/post_typecheck.m index 0c9ab6cdb..c03f70f7e 100644 --- a/compiler/post_typecheck.m +++ b/compiler/post_typecheck.m @@ -1503,7 +1503,7 @@ get_constructor_containing_field(ModuleInfo, TermType, FieldName, lookup_type_ctor_defn(TypeTable, TermTypeCtor, TermTypeDefn), hlds_data.get_type_defn_body(TermTypeDefn, TermTypeBody), ( - TermTypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _), + TermTypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _, _), get_constructor_containing_field_2(TermTypeCtor, Ctors, FieldName, ConsId, FieldNumber) ; diff --git a/compiler/prog_data.m b/compiler/prog_data.m index e0bcf398c..0c66b118f 100644 --- a/compiler/prog_data.m +++ b/compiler/prog_data.m @@ -1628,7 +1628,8 @@ equivalent_cons_ids(ConsIdA, ConsIdB) :- :- type type_defn ---> parse_tree_du_type( du_ctors :: list(constructor), - du_user_uc :: maybe(unify_compare) + du_user_uc :: maybe(unify_compare), + du_direct_arg :: maybe(list(sym_name_and_arity)) ) ; parse_tree_eqv_type( eqv_type :: mer_type diff --git a/compiler/prog_io_pragma.m b/compiler/prog_io_pragma.m index 88b8a0ee3..27010ffb8 100644 --- a/compiler/prog_io_pragma.m +++ b/compiler/prog_io_pragma.m @@ -81,7 +81,8 @@ parse_pragma(ModuleName, VarSet, PragmaTerms, Context, SeqNum, MaybeItem) :- % Because this is a non-solver type, if the unification with % MaybeWherePart succeeds then _SolverTypeDetails is guaranteed % to be `no'. - MaybeWherePart = ok2(_SolverTypeDetails, MaybeUserEqComp), + MaybeWherePart = ok3(_SolverTypeDetails, MaybeUserEqComp, + MaybeDirectArgIs), ( MaybeUserEqComp = yes(_), MaybeItem0 = ok1(Item0) @@ -95,7 +96,7 @@ parse_pragma(ModuleName, VarSet, PragmaTerms, Context, SeqNum, MaybeItem) :- parse_tree_foreign_type(Type, MaybeUserEqComp, Assertions), Item = item_type_defn(ItemTypeDefn), - MaybeItem = ok1(Item) + MaybeItem1 = ok1(Item) ; Pieces = [words("Error: unexpected"), quote("where equality/comparison is"), @@ -103,13 +104,27 @@ parse_pragma(ModuleName, VarSet, PragmaTerms, Context, SeqNum, MaybeItem) :- Spec = error_spec(severity_error, phase_term_to_parse_tree, [simple_msg(get_term_context(SinglePragmaTerm0), [always(Pieces)])]), - MaybeItem = error1([Spec]) + MaybeItem1 = error1([Spec]) ) ; - MaybeItem = MaybeItem0 + MaybeItem1 = MaybeItem0 + ), + ( + MaybeDirectArgIs = yes(_), + MaybeItem1 = ok1(_) + -> + PiecesB = [words("Error:"), quote("direct_arg"), + words("attribute is not applicable to foreign types."), + nl], + SpecB = error_spec(severity_error, phase_term_to_parse_tree, + [simple_msg(get_term_context(SinglePragmaTerm0), + [always(PiecesB)])]), + MaybeItem = error1([SpecB]) + ; + MaybeItem = MaybeItem1 ) ; - MaybeWherePart = error2(Specs), + MaybeWherePart = error3(Specs), MaybeItem = error1(Specs) ) ; diff --git a/compiler/prog_io_type_defn.m b/compiler/prog_io_type_defn.m index 429a4e29c..8e4202ced 100644 --- a/compiler/prog_io_type_defn.m +++ b/compiler/prog_io_type_defn.m @@ -47,7 +47,8 @@ % :- pred parse_type_decl_where_part_if_present(is_solver_type::in, module_name::in, varset::in, term::in, term::out, - maybe2(maybe(solver_type_details), maybe(unify_compare))::out) is det. + maybe3(maybe(solver_type_details), maybe(unify_compare), + maybe(list(sym_name_and_arity)))::out) is det. %-----------------------------------------------------------------------------% @@ -138,25 +139,35 @@ parse_du_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0, ( MaybeTypeCtorAndArgs = ok2(Name, Params), MaybeCtors = ok1(Ctors), - MaybeWhere = ok2(_NoSolverTypeDetails, MaybeUserEqComp) + MaybeWhere = ok3(_NoSolverTypeDetails, MaybeUserEqComp, + MaybeDirectArgIs) -> process_du_ctors(Params, VarSet, BodyTerm, Ctors, [], CtorsSpecs), ( - CtorsSpecs = [], + MaybeDirectArgIs = yes(DirectArgCtors), + check_direct_arg_ctors(Ctors, DirectArgCtors, BodyTerm, + CtorsSpecs, ErrorSpecs) + ; + MaybeDirectArgIs = no, + ErrorSpecs = CtorsSpecs + ), + ( + ErrorSpecs = [], varset.coerce(VarSet, TypeVarSet), - TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp), - ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params, - TypeDefn, Condition, Context, SeqNum), + TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp, + MaybeDirectArgIs), + ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, + Params, TypeDefn, Condition, Context, SeqNum), Item = item_type_defn(ItemTypeDefn), MaybeItem0 = ok1(Item), check_no_attributes(MaybeItem0, Attributes, MaybeItem) ; - CtorsSpecs = [_ | _], - MaybeItem = error1(CtorsSpecs) + ErrorSpecs = [_ | _], + MaybeItem = error1(ErrorSpecs) ) ; Specs = get_any_errors2(MaybeTypeCtorAndArgs) ++ - get_any_errors1(MaybeCtors) ++ get_any_errors2(MaybeWhere), + get_any_errors1(MaybeCtors) ++ get_any_errors3(MaybeWhere), MaybeItem = error1(Specs) ) ). @@ -467,6 +478,58 @@ process_du_ctors(Params, VarSet, BodyTerm, [Ctor | Ctors], !Specs) :- ), process_du_ctors(Params, VarSet, BodyTerm, Ctors, !Specs). +:- pred check_direct_arg_ctors(list(constructor)::in, + list(sym_name_and_arity)::in, term::in, + list(error_spec)::in, list(error_spec)::out) is det. + +check_direct_arg_ctors(_Ctors, [], _ErrorTerm, !Specs). +check_direct_arg_ctors(Ctors, [DirectArgCtor | DirectArgCtors], ErrorTerm, + !Specs) :- + DirectArgCtor = SymName / Arity, + ( find_constructor(Ctors, SymName, Arity, Ctor) -> + Ctor = ctor(ExistQVars, _Constraints, _SymName, _Args, _Context), + ( Arity \= 1 -> + Pieces = [words("Error: the"), quote("direct_arg"), + words("attribute contains a function symbol whose arity"), + words("is not 1."), nl], + Spec = error_spec(severity_error, phase_term_to_parse_tree, + [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]), + !:Specs = [Spec | !.Specs] + ; ExistQVars = [_ | _] -> + Pieces = [words("Error: the"), quote("direct_arg"), + words("attribute contains a function symbol"), + sym_name_and_arity(DirectArgCtor), + words("with existentially quantified type variables."), nl], + Spec = error_spec(severity_error, phase_term_to_parse_tree, + [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]), + !:Specs = [Spec | !.Specs] + ; + true + ) + ; + Pieces = [words("Error: the"), quote("direct_arg"), + words("attribute lists the function symbol"), + sym_name_and_arity(DirectArgCtor), + words("which is not in the type definition."), nl], + Spec = error_spec(severity_error, phase_term_to_parse_tree, + [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]), + !:Specs = [Spec | !.Specs] + ), + check_direct_arg_ctors(Ctors, DirectArgCtors, ErrorTerm, !Specs). + +:- pred find_constructor(list(constructor)::in, sym_name::in, arity::in, + constructor::out) is semidet. + +find_constructor([H | T], SymName, Arity, Ctor) :- + ( + H = ctor(_, _, SymName, Args, _), + list.length(Args, Arity) + -> + Ctor = H + ; + find_constructor(T, SymName, Arity, Ctor) + ). + %-----------------------------------------------------------------------------% % parse_eqv_type_defn parses the definition of an equivalence type. @@ -540,13 +603,24 @@ parse_solver_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0, MaybeWhere = parse_type_decl_where_term(solver_type, ModuleName, VarSet, yes(BodyTerm)), ( - MaybeWhere = error2(Specs), + MaybeWhere = error3(Specs), MaybeItem = error1(Specs) ; - MaybeWhere = ok2(MaybeSolverTypeDetails, MaybeUserEqComp), - parse_solver_type_base(ModuleName, VarSet, HeadTerm, - MaybeSolverTypeDetails, MaybeUserEqComp, Attributes, - Condition, Context, SeqNum, MaybeItem) + MaybeWhere = ok3(MaybeSolverTypeDetails, MaybeUserEqComp, + MaybeDirectArgCtors), + ( + MaybeDirectArgCtors = yes(_), + Pieces = [words("Error: solver type definitions cannot have a"), + quote("direct_arg"), words("attribute."), nl], + Spec = error_spec(severity_error, phase_term_to_parse_tree, + [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]), + MaybeItem = error1([Spec]) + ; + MaybeDirectArgCtors = no, + parse_solver_type_base(ModuleName, VarSet, HeadTerm, + MaybeSolverTypeDetails, MaybeUserEqComp, Attributes, + Condition, Context, SeqNum, MaybeItem) + ) ) ). @@ -659,7 +733,7 @@ parse_type_decl_where_part_if_present(IsSolverType, ModuleName, VarSet, ModuleName, VarSet, yes(WhereTerm)) ; BeforeWhereTerm = Term, - MaybeWhereDetails = ok2(no, no) + MaybeWhereDetails = ok3(no, no, no) ). % The maybe2 wrapper allows us to return an error code or a pair @@ -667,13 +741,14 @@ parse_type_decl_where_part_if_present(IsSolverType, ModuleName, VarSet, % wrapper around each of those. % :- func parse_type_decl_where_term(is_solver_type, module_name, varset, - maybe(term)) = maybe2(maybe(solver_type_details), maybe(unify_compare)). + maybe(term)) = maybe3(maybe(solver_type_details), maybe(unify_compare), + maybe(list(sym_name_and_arity))). parse_type_decl_where_term(IsSolverType, ModuleName, VarSet, MaybeTerm0) = MaybeWhereDetails :- ( MaybeTerm0 = no, - MaybeWhereDetails = ok2(no, no) + MaybeWhereDetails = ok3(no, no, no) ; MaybeTerm0 = yes(Term0), some [!MaybeTerm] ( @@ -701,6 +776,9 @@ parse_type_decl_where_term(IsSolverType, ModuleName, VarSet, MaybeTerm0) = parse_where_attribute(parse_where_is("comparison", parse_where_pred_is(ModuleName, VarSet)), MaybeComparisonIs, !MaybeTerm), + parse_where_attribute(parse_where_is("direct_arg", + parse_where_direct_arg_is(ModuleName, VarSet)), + MaybeDirectArgIs, !MaybeTerm), parse_where_end(!.MaybeTerm, MaybeWhereEnd) ), MaybeWhereDetails = make_maybe_where_details( @@ -713,6 +791,7 @@ parse_type_decl_where_term(IsSolverType, ModuleName, VarSet, MaybeTerm0) = MaybeCStoreIs, MaybeEqualityIs, MaybeComparisonIs, + MaybeDirectArgIs, MaybeWhereEnd, Term0 ) @@ -900,6 +979,38 @@ parse_mutable_decl_term(ModuleName, Term, MaybeItem) :- MaybeItem = error1([Spec]) ). +:- func parse_where_direct_arg_is(module_name, varset, term) = + maybe1(list(sym_name_and_arity)). + +parse_where_direct_arg_is(ModuleName, VarSet, Term) = MaybeDirectArgCtors :- + ( list_term_to_term_list(Term, FunctorsTerms) -> + map_parser(parse_direct_arg_functor(ModuleName, VarSet), + FunctorsTerms, MaybeDirectArgCtors) + ; + Pieces = [words("Error: malformed functors list in"), + quote("direct_arg"), words("attribute."), nl], + Spec = error_spec(severity_error, phase_term_to_parse_tree, + [simple_msg(get_term_context(Term), + [always(Pieces)])]), + MaybeDirectArgCtors = error1([Spec]) + ). + +:- pred parse_direct_arg_functor(module_name::in, varset::in, term::in, + maybe1(sym_name_and_arity)::out) is det. + +parse_direct_arg_functor(ModuleName, VarSet, Term, MaybeFunctor) :- + ( parse_name_and_arity(ModuleName, Term, Name, Arity) -> + MaybeFunctor = ok1(Name / Arity) + ; + TermStr = describe_error_term(VarSet, Term), + Pieces = [words("Error: expected functor"), + words("name/arity for"), quote("direct_arg"), + words("attribute, not"), quote(TermStr), suffix("."), nl], + Spec = error_spec(severity_error, phase_term_to_parse_tree, + [simple_msg(get_term_context(Term), [always(Pieces)])]), + MaybeFunctor = error1([Spec]) + ). + :- pred parse_where_end(maybe(term)::in, maybe1(maybe(unit))::out) is det. parse_where_end(no, ok1(yes(unit))). @@ -914,14 +1025,16 @@ parse_where_end(yes(Term), error1([Spec])) :- maybe1(maybe(mer_inst)), maybe1(maybe(mer_inst)), maybe1(maybe(list(item))), maybe1(maybe(equality_pred)), maybe1(maybe(comparison_pred)), + maybe1(maybe(list(sym_name_and_arity))), maybe1(maybe(unit)), term) - = maybe2(maybe(solver_type_details), maybe(unify_compare)). + = maybe3(maybe(solver_type_details), maybe(unify_compare), + maybe(list(sym_name_and_arity))). make_maybe_where_details(IsSolverType, MaybeTypeIsAbstractNoncanonical, MaybeRepresentationIs, MaybeInitialisationIs, MaybeGroundIs, MaybeAnyIs, MaybeCStoreIs, - MaybeEqualityIs, MaybeComparisonIs, MaybeWhereEnd, WhereTerm) - = MaybeSolverUC :- + MaybeEqualityIs, MaybeComparisonIs, MaybeDirectArgIs, + MaybeWhereEnd, WhereTerm) = MaybeWhereDetails :- ( MaybeTypeIsAbstractNoncanonical = ok1(TypeIsAbstractNoncanonical), MaybeRepresentationIs = ok1(RepresentationIs), @@ -931,11 +1044,12 @@ make_maybe_where_details(IsSolverType, MaybeTypeIsAbstractNoncanonical, MaybeCStoreIs = ok1(CStoreIs), MaybeEqualityIs = ok1(EqualityIs), MaybeComparisonIs = ok1(ComparisonIs), + MaybeDirectArgIs = ok1(DirectArgIs), MaybeWhereEnd = ok1(WhereEnd) -> - MaybeSolverUC = make_maybe_where_details_2(IsSolverType, + MaybeWhereDetails = make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical, RepresentationIs, InitialisationIs, - GroundIs, AnyIs, CStoreIs, EqualityIs, ComparisonIs, + GroundIs, AnyIs, CStoreIs, EqualityIs, ComparisonIs, DirectArgIs, WhereEnd, WhereTerm) ; Specs = @@ -947,19 +1061,22 @@ make_maybe_where_details(IsSolverType, MaybeTypeIsAbstractNoncanonical, get_any_errors1(MaybeCStoreIs) ++ get_any_errors1(MaybeEqualityIs) ++ get_any_errors1(MaybeComparisonIs) ++ + get_any_errors1(MaybeDirectArgIs) ++ get_any_errors1(MaybeWhereEnd), - MaybeSolverUC = error2(Specs) + MaybeWhereDetails = error3(Specs) ). :- func make_maybe_where_details_2(is_solver_type, maybe(unit), maybe(mer_type), maybe(init_pred), maybe(mer_inst), maybe(mer_inst), maybe(list(item)), maybe(equality_pred), maybe(comparison_pred), - maybe(unit), term) - = maybe2(maybe(solver_type_details), maybe(unify_compare)). + maybe(list(sym_name_and_arity)), maybe(unit), term) + = maybe3(maybe(solver_type_details), maybe(unify_compare), + maybe(list(sym_name_and_arity))). make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical, RepresentationIs, InitialisationIs, GroundIs, AnyIs, CStoreIs, - EqualityIs, ComparisonIs, _WhereEnd, WhereTerm) = MaybeSolverUC :- + EqualityIs, ComparisonIs, DirectArgIs, _WhereEnd, WhereTerm) + = MaybeWhereDetails :- ( TypeIsAbstractNoncanonical = yes(_), % rafe: XXX I think this is wrong. There isn't a problem with having @@ -971,10 +1088,11 @@ make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical, AnyIs = maybe.no, EqualityIs = maybe.no, ComparisonIs = maybe.no, - CStoreIs = maybe.no + CStoreIs = maybe.no, + DirectArgIs = maybe.no -> - MaybeSolverUC = - ok2(no, yes(abstract_noncanonical_type(IsSolverType))) + MaybeWhereDetails = + ok3(no, yes(abstract_noncanonical_type(IsSolverType)), no) ; Pieces = [words("Error:"), quote("where type_is_abstract_noncanonical"), @@ -982,13 +1100,22 @@ make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical, words("attributes."), nl], Spec = error_spec(severity_error, phase_term_to_parse_tree, [simple_msg(get_term_context(WhereTerm), [always(Pieces)])]), - MaybeSolverUC = error2([Spec]) + MaybeWhereDetails = error3([Spec]) ) ; TypeIsAbstractNoncanonical = maybe.no, ( IsSolverType = solver_type, ( + DirectArgIs = yes(_) + -> + Pieces = [words("Error: solver type definitions cannot have"), + quote("direct_arg"), words("attributes."), nl], + Spec = error_spec(severity_error, phase_term_to_parse_tree, + [simple_msg(get_term_context(WhereTerm), + [always(Pieces)])]), + MaybeWhereDetails = error3([Spec]) + ; RepresentationIs = yes(RepnType), InitialisationIs = MaybeInitialisation, GroundIs = MaybeGroundInst, @@ -1034,7 +1161,8 @@ make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical, MaybeUnifyCompare = yes(unify_compare( MaybeEqPred, MaybeCmpPred)) ), - MaybeSolverUC = ok2(MaybeSolverTypeDetails, MaybeUnifyCompare) + MaybeWhereDetails = ok3(MaybeSolverTypeDetails, + MaybeUnifyCompare, no) ; RepresentationIs = no -> @@ -1043,7 +1171,7 @@ make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical, Spec = error_spec(severity_error, phase_term_to_parse_tree, [simple_msg(get_term_context(WhereTerm), [always(Pieces)])]), - MaybeSolverUC = error2([Spec]) + MaybeWhereDetails = error3([Spec]) ; unexpected($module, $pred, "make_maybe_where_details_2: " ++ "shouldn't have reached this point! (1)") @@ -1063,16 +1191,27 @@ make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical, Spec = error_spec(severity_error, phase_term_to_parse_tree, [simple_msg(get_term_context(WhereTerm), [always(Pieces)])]), - MaybeSolverUC = error2([Spec]) + MaybeWhereDetails = error3([Spec]) ; - EqualityIs = MaybeEqPred, - ComparisonIs = MaybeCmpPred, - MaybeSolverUC = - ok2(no, yes(unify_compare(MaybeEqPred, MaybeCmpPred))) + MaybeUC = maybe_unify_compare(EqualityIs, ComparisonIs), + MaybeWhereDetails = ok3(no, MaybeUC, DirectArgIs) ) ) ). +:- func maybe_unify_compare(maybe(equality_pred), maybe(comparison_pred)) + = maybe(unify_compare). + +maybe_unify_compare(MaybeEqPred, MaybeCmpPred) = + ( + MaybeEqPred = no, + MaybeCmpPred = no + -> + no + ; + yes(unify_compare(MaybeEqPred, MaybeCmpPred)) + ). + %-----------------------------------------------------------------------------% % % Predicates useful for parsing several kinds of type definitions. diff --git a/compiler/recompilation.check.m b/compiler/recompilation.check.m index 6e213eaf6..384dac580 100644 --- a/compiler/recompilation.check.m +++ b/compiler/recompilation.check.m @@ -1173,7 +1173,7 @@ check_type_defn_ambiguity_with_functor(NeedQualifier, TypeCtor, TypeDefn, ; TypeDefn = parse_tree_solver_type(_, _) ) ; - TypeDefn = parse_tree_du_type(Ctors, _), + TypeDefn = parse_tree_du_type(Ctors, _, _), list.foldl(check_functor_ambiguities(NeedQualifier, TypeCtor), Ctors, !Info) ). diff --git a/compiler/recompilation.usage.m b/compiler/recompilation.usage.m index 9ed367180..944ab16b3 100644 --- a/compiler/recompilation.usage.m +++ b/compiler/recompilation.usage.m @@ -1060,7 +1060,7 @@ find_items_used_by_type_and_mode(TypeAndMode, !Info) :- :- pred find_items_used_by_type_body(hlds_type_body::in, recompilation_usage_info::in, recompilation_usage_info::out) is det. -find_items_used_by_type_body(hlds_du_type(Ctors, _, _, _, _, _, _, _), +find_items_used_by_type_body(hlds_du_type(Ctors, _, _, _, _, _, _, _, _), !Info) :- list.foldl(find_items_used_by_ctor, Ctors, !Info). find_items_used_by_type_body(hlds_eqv_type(Type), !Info) :- diff --git a/compiler/recompilation.version.m b/compiler/recompilation.version.m index 82101c8d9..f66abb8d6 100644 --- a/compiler/recompilation.version.m +++ b/compiler/recompilation.version.m @@ -293,7 +293,7 @@ gather_items_2(Item, !Section, !Info) :- % procedure. BodyItem = Item ; - Body = parse_tree_du_type(_, _), + Body = parse_tree_du_type(_, _, _), NameItemTypeDefn = item_type_defn_info(VarSet, Name, Args, parse_tree_abstract_type(non_solver_type), Cond, Context, SeqNum), diff --git a/compiler/rtti.m b/compiler/rtti.m index 20c3d92bb..ffc78e3cb 100644 --- a/compiler/rtti.m +++ b/compiler/rtti.m @@ -381,6 +381,7 @@ % :- type sectag_locn ---> sectag_none + ; sectag_none_direct_arg ; sectag_local ; sectag_remote. @@ -389,6 +390,7 @@ % :- type sectag_and_locn ---> sectag_locn_none + ; sectag_locn_none_direct_arg ; sectag_locn_local(int) ; sectag_locn_remote(int). @@ -1512,13 +1514,35 @@ type_info_list_to_string(TypeInfoList) = pred_or_func_to_string(pf_predicate, "MR_PREDICATE"). pred_or_func_to_string(pf_function, "MR_FUNCTION"). -sectag_locn_to_string(sectag_none, "MR_SECTAG_NONE"). -sectag_locn_to_string(sectag_local, "MR_SECTAG_LOCAL"). -sectag_locn_to_string(sectag_remote, "MR_SECTAG_REMOTE"). +sectag_locn_to_string(SecTag, String) :- + ( + SecTag = sectag_none, + String = "MR_SECTAG_NONE" + ; + SecTag = sectag_none_direct_arg, + String = "MR_SECTAG_NONE_DIRECT_ARG" + ; + SecTag = sectag_local, + String = "MR_SECTAG_LOCAL" + ; + SecTag = sectag_remote, + String = "MR_SECTAG_REMOTE" + ). -sectag_and_locn_to_locn_string(sectag_locn_none, "MR_SECTAG_NONE"). -sectag_and_locn_to_locn_string(sectag_locn_local(_), "MR_SECTAG_LOCAL"). -sectag_and_locn_to_locn_string(sectag_locn_remote(_), "MR_SECTAG_REMOTE"). +sectag_and_locn_to_locn_string(SecTag, String) :- + ( + SecTag = sectag_locn_none, + String = "MR_SECTAG_NONE" + ; + SecTag = sectag_locn_none_direct_arg, + String = "MR_SECTAG_NONE_DIRECT_ARG" + ; + SecTag = sectag_locn_local(_), + String = "MR_SECTAG_LOCAL" + ; + SecTag = sectag_locn_remote(_), + String = "MR_SECTAG_REMOTE" + ). type_ctor_rep_to_string(TypeCtorData, RepStr) :- TypeCtorDetails = TypeCtorData ^ tcr_rep_details, diff --git a/compiler/rtti_out.m b/compiler/rtti_out.m index 725b3aeae..2d0a27a21 100644 --- a/compiler/rtti_out.m +++ b/compiler/rtti_out.m @@ -917,6 +917,10 @@ output_du_functor_defn(Info, RttiTypeCtor, DuFunctor, !DeclSet, !IO) :- SectagAndLocn = sectag_locn_none, Locn = "MR_SECTAG_NONE", Stag = -1 + ; + SectagAndLocn = sectag_locn_none_direct_arg, + Locn = "MR_SECTAG_NONE_DIRECT_ARG", + Stag = -1 ; SectagAndLocn = sectag_locn_local(Stag), Locn = "MR_SECTAG_LOCAL" diff --git a/compiler/rtti_to_mlds.m b/compiler/rtti_to_mlds.m index 9abc5fb88..4d30e916f 100644 --- a/compiler/rtti_to_mlds.m +++ b/compiler/rtti_to_mlds.m @@ -763,6 +763,10 @@ gen_du_functor_desc(ModuleInfo, RttiTypeCtor, DuFunctor, !GlobalData) :- SectagAndLocn = sectag_locn_none, Locn = sectag_none, Stag = -1 + ; + SectagAndLocn = sectag_locn_none_direct_arg, + Locn = sectag_none_direct_arg, + Stag = -1 ; SectagAndLocn = sectag_locn_local(Stag), Locn = sectag_local diff --git a/compiler/simplify.m b/compiler/simplify.m index 874030e3a..3ff04a96d 100644 --- a/compiler/simplify.m +++ b/compiler/simplify.m @@ -1777,7 +1777,7 @@ warn_switch_for_ite_cond(ModuleInfo, VarTypes, Cond, !CondCanSwitch) :- can_switch_on_type(TypeBody) = CanSwitchOnType :- ( TypeBody = hlds_du_type(_Ctors, _TagValues, _CheaperTagTest, - DuTypeKind, _UserEq, _ReservedTag, _ReservedAddr, + DuTypeKind, _UserEq, _DirectArgCtors, _ReservedTag, _ReservedAddr, _MaybeForeignType), % We don't care about _UserEq, since the unification with *any* functor % of the type indicates that we are deconstructing the physical diff --git a/compiler/structure_reuse.direct.choose_reuse.m b/compiler/structure_reuse.direct.choose_reuse.m index 92b21c834..9f3f259e8 100644 --- a/compiler/structure_reuse.direct.choose_reuse.m +++ b/compiler/structure_reuse.direct.choose_reuse.m @@ -1045,7 +1045,7 @@ has_secondary_tag(ModuleInfo, VarTypes, Var, ConsId, SecondaryTag) :- ( map.lookup(VarTypes, Var, Type), type_to_type_defn_body(ModuleInfo, Type, TypeBody), - TypeBody = hlds_du_type(_, ConsTagValues, _, _, _, _, _, _), + TypeBody = hlds_du_type(_, ConsTagValues, _, _, _, _, _, _, _), map.search(ConsTagValues, ConsId, ConsTag), MaybeSecondaryTag = get_secondary_tag(ConsTag), MaybeSecondaryTag = yes(_) diff --git a/compiler/switch_gen.m b/compiler/switch_gen.m index dc22ca529..2d1a3fe1e 100644 --- a/compiler/switch_gen.m +++ b/compiler/switch_gen.m @@ -435,6 +435,7 @@ is_reserved_addr_tag(TaggedConsId) = IsReservedAddr :- ; ConsTag = tabling_info_tag(_, _) ; ConsTag = type_ctor_info_tag(_, _, _) ; ConsTag = unshared_tag(_) + ; ConsTag = direct_arg_tag(_) ), IsReservedAddr = no ). diff --git a/compiler/switch_util.m b/compiler/switch_util.m index 47be76655..14a39353e 100644 --- a/compiler/switch_util.m +++ b/compiler/switch_util.m @@ -524,7 +524,9 @@ estimate_switch_tag_test_cost(Tag) = Cost :- % of the scan over them. Cost = 2 ; - Tag = unshared_tag(_), + ( Tag = unshared_tag(_) + ; Tag = direct_arg_tag(_) + ), % You need to compute the primary tag and compare it. Cost = 2 ; @@ -585,7 +587,7 @@ type_range(ModuleInfo, TypeCtorCat, Type, Min, Max, NumValues) :- lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn), hlds_data.get_type_defn_body(TypeDefn, TypeBody), ( - TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _, _), + TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _, _, _), map.count(ConsTable, TypeRange), Max = TypeRange - 1 ; @@ -1059,7 +1061,7 @@ get_ptag_counts(Type, ModuleInfo, MaxPrimary, PtagCountMap) :- lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn), hlds_data.get_type_defn_body(TypeDefn, TypeBody), ( - TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _, _), + TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _, _, _), map.to_assoc_list(ConsTable, ConsList), assoc_list.values(ConsList, TagList) ; @@ -1079,14 +1081,22 @@ get_ptag_counts(Type, ModuleInfo, MaxPrimary, PtagCountMap) :- get_ptag_counts_2([], !MaxPrimary, !PtagCountMap). get_ptag_counts_2([Tag | Tags], !MaxPrimary, !PtagCountMap) :- ( - ( Tag = single_functor_tag, Primary = 0 - ; Tag = unshared_tag(Primary) + ( + Tag = single_functor_tag, + Primary = 0, + SecTag = sectag_none + ; + Tag = unshared_tag(Primary), + SecTag = sectag_none + ; + Tag = direct_arg_tag(Primary), + SecTag = sectag_none_direct_arg ), int.max(Primary, !MaxPrimary), ( map.search(!.PtagCountMap, Primary, _) -> unexpected($module, $pred, "unshared tag is shared") ; - map.det_insert(Primary, sectag_none - (-1), !PtagCountMap) + map.det_insert(Primary, SecTag - (-1), !PtagCountMap) ) ; Tag = shared_remote_tag(Primary, Secondary), @@ -1098,6 +1108,7 @@ get_ptag_counts_2([Tag | Tags], !MaxPrimary, !PtagCountMap) :- ; ( TagType = sectag_local ; TagType = sectag_none + ; TagType = sectag_none_direct_arg ), unexpected($module, $pred, "remote tag is shared with non-remote") @@ -1117,6 +1128,7 @@ get_ptag_counts_2([Tag | Tags], !MaxPrimary, !PtagCountMap) :- ; ( TagType = sectag_remote ; TagType = sectag_none + ; TagType = sectag_none_direct_arg ), unexpected($module, $pred, "local tag is shared with non-local") @@ -1181,14 +1193,22 @@ group_case_by_ptag(CaseNum, CaseRep, TaggedConsId, !CaseNumPtagsMap, !PtagCaseMap) :- TaggedConsId = tagged_cons_id(_ConsId, Tag), ( - ( Tag = single_functor_tag, Primary = 0 - ; Tag = unshared_tag(Primary) + ( + Tag = single_functor_tag, + Primary = 0, + SecTag = sectag_none + ; + Tag = unshared_tag(Primary), + SecTag = sectag_none + ; + Tag = direct_arg_tag(Primary), + SecTag = sectag_none_direct_arg ), ( map.search(!.PtagCaseMap, Primary, _Group) -> unexpected($module, $pred, "unshared tag is shared") ; StagGoalMap = map.singleton(-1, CaseRep), - map.det_insert(Primary, ptag_case(sectag_none, StagGoalMap), + map.det_insert(Primary, ptag_case(SecTag, StagGoalMap), !PtagCaseMap) ) ; @@ -1291,7 +1311,9 @@ build_ptag_case_rev_map([Entry | Entries], PtagCountMap, !RevMap) :- Entry = Ptag - Case, map.lookup(PtagCountMap, Ptag, CountSecTagLocn - Count), ( - CountSecTagLocn = sectag_none, + ( CountSecTagLocn = sectag_none + ; CountSecTagLocn = sectag_none_direct_arg + ), ( map.search(!.RevMap, Case, OldEntry) -> OldEntry = ptag_case_rev_map_entry(OldCount, OldFirstPtag, OldLaterPtags0, OldCase), diff --git a/compiler/tag_switch.m b/compiler/tag_switch.m index 1833331ec..2f1947b37 100644 --- a/compiler/tag_switch.m +++ b/compiler/tag_switch.m @@ -667,7 +667,9 @@ generate_primary_tag_code(StagGoalMap, MainPtag, OtherPtags, MaxSecondary, StagReg, StagLoc, Rval, MaybeFailLabel, Code, !CaseLabelMap, !CI) :- map.to_assoc_list(StagGoalMap, StagGoalList), ( - StagLoc = sectag_none, + ( StagLoc = sectag_none + ; StagLoc = sectag_none_direct_arg + ), % There is no secondary tag, so there is no switch on it. ( StagGoalList = [], diff --git a/compiler/term_norm.m b/compiler/term_norm.m index ac9377f44..9d5ef6d84 100644 --- a/compiler/term_norm.m +++ b/compiler/term_norm.m @@ -146,7 +146,7 @@ find_weights(ModuleInfo, Weights) :- find_weights_for_type(TypeCtor - TypeDefn, !Weights) :- hlds_data.get_type_defn_body(TypeDefn, TypeBody), ( - TypeBody = hlds_du_type(Constructors, _, _, _, _, _, _, _), + TypeBody = hlds_du_type(Constructors, _, _, _, _, _, _, _, _), hlds_data.get_type_defn_tparams(TypeDefn, TypeParams), list.foldl(find_weights_for_cons(TypeCtor, TypeParams), Constructors, !Weights) diff --git a/compiler/type_ctor_info.m b/compiler/type_ctor_info.m index 884210ad2..02100c953 100644 --- a/compiler/type_ctor_info.m +++ b/compiler/type_ctor_info.m @@ -371,8 +371,8 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :- Details = tcd_eqv(MaybePseudoTypeInfo) ; TypeBody = hlds_du_type(Ctors, ConsTagMap, _CheaperTagTest, - DuTypeKind, MaybeUserEqComp, ReservedTag, ReservedAddr, - _IsForeignType), + DuTypeKind, MaybeUserEqComp, _MaybeDirectArgCtors, + ReservedTag, ReservedAddr, _IsForeignType), ( MaybeUserEqComp = yes(_), EqualityAxioms = user_defined @@ -407,7 +407,7 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :- some [!Flags] ( !:Flags = set.init, ( - TypeBody = hlds_du_type(_, _, _, _, _, BodyReservedTag, _, _), + TypeBody = hlds_du_type(_, _, _, _, _, _, BodyReservedTag, _, _), set.insert(kind_of_du_flag, !Flags), ( BodyReservedTag = uses_reserved_tag, @@ -487,7 +487,7 @@ impl_type_ctor("table_builtin", "ml_subgoal", 0, impl_ctor_subgoal). % :- func type_ctor_info_rtti_version = int. -type_ctor_info_rtti_version = 13. +type_ctor_info_rtti_version = 14. % Construct an rtti_data for a pseudo_type_info, and also construct % rtti_data definitions for all of the pseudo_type_infos that it references @@ -712,6 +712,7 @@ make_foreign_enum_functors(TypeCtor, Lang, [Functor | Functors], NextOrdinal, ; ConsTag = table_io_decl_tag(_, _) ; ConsTag = single_functor_tag ; ConsTag = unshared_tag(_) + ; ConsTag = direct_arg_tag(_) ; ConsTag = shared_remote_tag(_, _) ; ConsTag = shared_local_tag(_, _) ; ConsTag = no_tag @@ -819,7 +820,7 @@ make_maybe_res_functors(TypeCtor, [Functor | Functors], NextOrdinal, FunctorName = unqualify_name(SymName), ConsId = cons(SymName, list.length(ConstructorArgs), TypeCtor), map.lookup(ConsTagMap, ConsId, ConsTag), - process_cons_tag(ConsTag, ConsRep), + get_maybe_reserved_rep(ConsTag, ConsRep), list.map(generate_du_arg_info(TypeArity, ExistTvars), ConstructorArgs, ArgInfos), ( @@ -847,16 +848,22 @@ make_maybe_res_functors(TypeCtor, [Functor | Functors], NextOrdinal, make_maybe_res_functors(TypeCtor, Functors, NextOrdinal + 1, ConsTagMap, TypeArity, ModuleInfo, MaybeResFunctors). -:- pred process_cons_tag(cons_tag::in, maybe_reserved_rep::out) is det. +:- pred get_maybe_reserved_rep(cons_tag::in, maybe_reserved_rep::out) is det. -process_cons_tag(ConsTag, ConsRep) :- +get_maybe_reserved_rep(ConsTag, ConsRep) :- ( ConsTag = single_functor_tag, ConsPtag = 0, - ConsRep = du_rep(du_ll_rep(ConsPtag, sectag_locn_none)) + SecTagLocn = sectag_locn_none, + ConsRep = du_rep(du_ll_rep(ConsPtag, SecTagLocn)) ; ConsTag = unshared_tag(ConsPtag), - ConsRep = du_rep(du_ll_rep(ConsPtag, sectag_locn_none)) + SecTagLocn = sectag_locn_none, + ConsRep = du_rep(du_ll_rep(ConsPtag, SecTagLocn)) + ; + ConsTag = direct_arg_tag(ConsPtag), + SecTagLocn = sectag_locn_none_direct_arg, + ConsRep = du_rep(du_ll_rep(ConsPtag, SecTagLocn)) ; ConsTag = shared_local_tag(ConsPtag, ConsStag), ConsRep = du_rep(du_ll_rep(ConsPtag, sectag_locn_local(ConsStag))) @@ -870,7 +877,7 @@ process_cons_tag(ConsTag, ConsRep) :- ConsTag = shared_with_reserved_addresses_tag(_RAs, ThisTag), % Here we can just ignore the fact that this cons_tag is % shared with reserved addresses. - process_cons_tag(ThisTag, ConsRep) + get_maybe_reserved_rep(ThisTag, ConsRep) ; ( ConsTag = no_tag ; ConsTag = string_tag(_) @@ -997,6 +1004,10 @@ make_du_ptag_ordered_table(DuFunctor, !PtagTable) :- SectagAndLocn = sectag_locn_none, SectagLocn = sectag_none, Sectag = 0 + ; + SectagAndLocn = sectag_locn_none_direct_arg, + SectagLocn = sectag_none_direct_arg, + Sectag = 0 ; SectagAndLocn = sectag_locn_local(Sectag), SectagLocn = sectag_local diff --git a/compiler/type_util.m b/compiler/type_util.m index 85736087b..c193b3085 100644 --- a/compiler/type_util.m +++ b/compiler/type_util.m @@ -421,7 +421,7 @@ type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody, UserEqComp) :- module_info_get_globals(ModuleInfo, Globals), globals.get_target(Globals, Target), ( - TypeBody = hlds_du_type(_, _, _, _, _, _, _, _), + TypeBody = hlds_du_type(_, _, _, _, _, _, _, _, _), ( TypeBody ^ du_type_is_foreign_type = yes(ForeignTypeBody), have_foreign_type_for_backend(Target, ForeignTypeBody, yes) @@ -489,7 +489,7 @@ type_body_definitely_has_no_user_defined_equality_pred(ModuleInfo, Type, module_info_get_globals(ModuleInfo, Globals), globals.get_target(Globals, Target), ( - TypeBody = hlds_du_type(_, _, _, _, _, _, _, _), + TypeBody = hlds_du_type(_, _, _, _, _, _, _, _, _), ( TypeBody ^ du_type_is_foreign_type = yes(ForeignTypeBody), have_foreign_type_for_backend(Target, ForeignTypeBody, yes) @@ -641,7 +641,7 @@ check_dummy_type_2(ModuleInfo, Type, CoveredTypes) = IsDummy :- ( search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn)-> get_type_defn_body(TypeDefn, TypeBody), ( - TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _), + TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _, _), ( DuTypeKind = du_type_kind_direct_dummy, IsDummy = is_dummy_type @@ -685,7 +685,7 @@ type_ctor_has_hand_defined_rtti(Type, Body) :- ; Name = "typeclass_info" ; Name = "base_typeclass_info" ), - \+ ( Body = hlds_du_type(_, _, _, _, _, _, _, yes(_)) + \+ ( Body = hlds_du_type(_, _, _, _, _, _, _, _, yes(_)) ; Body = hlds_foreign_type(_) ; Body = hlds_solver_type(_, _) ). @@ -780,7 +780,7 @@ classify_type_ctor(ModuleInfo, TypeCtor) = TypeCategory :- lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn), hlds_data.get_type_defn_body(TypeDefn, TypeBody), ( - TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _), + TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _, _), ( DuTypeKind = du_type_kind_mercury_enum, TypeCategory = ctor_cat_enum(cat_enum_mercury) @@ -818,7 +818,7 @@ classify_type_defn_body(TypeBody) = TypeCategory :- % already done that. ( - TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _), + TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _, _), ( DuTypeKind = du_type_kind_mercury_enum, TypeCategory = ctor_cat_enum(cat_enum_mercury) diff --git a/compiler/unify_gen.m b/compiler/unify_gen.m index 2c5894fc9..e986cd0a9 100644 --- a/compiler/unify_gen.m +++ b/compiler/unify_gen.m @@ -392,7 +392,9 @@ raw_tag_test(Rval, ConsTag, TestRval) :- ConsTag = single_functor_tag, TestRval = const(llconst_true) ; - ConsTag = unshared_tag(UnsharedTag), + ( ConsTag = unshared_tag(UnsharedTag) + ; ConsTag = direct_arg_tag(UnsharedTag) + ), VarPtag = unop(tag, Rval), ConstPtag = unop(mktag, const(llconst_int(UnsharedTag))), TestRval = binop(eq, VarPtag, ConstPtag) @@ -514,6 +516,24 @@ generate_construction_2(ConsTag, Var, Args, Modes, HowToConstruct, Context = goal_info_get_context(GoalInfo), construct_cell(Var, Ptag, MaybeRvals, HowToConstruct, MaybeSize, FieldAddrs, Context, MayUseAtomic, Code, !CI) + ; + ConsTag = direct_arg_tag(Ptag), + ( + Args = [Arg], + Modes = [Mode] + -> + ( + TakeAddr = [], + Type = variable_type(!.CI, Arg), + generate_direct_arg_construct(Var, Arg, Ptag, Mode, Type, Code, + !CI) + ; + TakeAddr = [_ | _], + unexpected($module, $pred, "direct_arg_tag: take_addr") + ) + ; + unexpected($module, $pred, "direct_arg_tag: arity != 1") + ) ; ConsTag = shared_remote_tag(Ptag, Sectag), var_types(!.CI, Args, ArgTypes), @@ -1125,6 +1145,18 @@ generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI) :- make_fields_and_argvars(Args, Rval, 0, Ptag, Fields, ArgVars), var_types(!.CI, Args, ArgTypes), generate_unify_args(Fields, ArgVars, Modes, ArgTypes, Code, !CI) + ; + Tag = direct_arg_tag(Ptag), + ( + Args = [Arg], + Modes = [Mode] + -> + Type = variable_type(!.CI, Arg), + generate_direct_arg_deconstruct(Var, Arg, Ptag, Mode, Type, Code, + !CI) + ; + unexpected($module, $pred, "direct_arg_tag: arity != 1") + ) ; Tag = shared_remote_tag(Ptag, _Sectag1), Rval = var(Var), @@ -1232,8 +1264,6 @@ generate_sub_unify(L, R, Mode, Type, Code, !CI) :- unexpected($module, $pred, "some strange unify") ). -%---------------------------------------------------------------------------% - :- pred generate_sub_assign(uni_val::in, uni_val::in, llds_code::out, code_info::in, code_info::out) is det. @@ -1270,6 +1300,103 @@ generate_sub_assign(Left, Right, Code, !CI) :- ) ). +%---------------------------------------------------------------------------% + + % Generate a direct arg unification between + % - the left-hand-side (the whole term), and + % - the right-hand-side (the one argument). + % +:- pred generate_direct_arg_construct(prog_var::in, prog_var::in, tag_bits::in, + uni_mode::in, mer_type::in, llds_code::out, + code_info::in, code_info::out) is det. + +generate_direct_arg_construct(Var, Arg, Ptag, Mode, Type, Code, !CI) :- + Mode = ((LI - RI) -> (LF - RF)), + get_module_info(!.CI, ModuleInfo), + mode_to_arg_mode(ModuleInfo, (LI -> LF), Type, LeftMode), + mode_to_arg_mode(ModuleInfo, (RI -> RF), Type, RightMode), + ( + % Input - input == test unification + LeftMode = top_in, + RightMode = top_in + -> + % This shouldn't happen, since mode analysis should avoid creating + % any tests in the arguments of a construction or deconstruction + % unification. + unexpected($module, $pred, "test in arg of [de]construction") + ; + % Input - Output == assignment -> + LeftMode = top_in, + RightMode = top_out + -> + unexpected($module, $pred, "left-to-right data flow in construction") + ; + % Output - Input == assignment <- + LeftMode = top_out, + RightMode = top_in + -> + assign_expr_to_var(Var, mkword(Ptag, var(Arg)), Code, !CI) + ; + LeftMode = top_unused, + RightMode = top_unused + -> + Code = empty + % free-free - ignore + % XXX I think this will have to change if we start to support aliasing. + ; + unexpected($module, $pred, "some strange unify") + ). + + % Generate a direct arg unification between + % - the left-hand-side (the whole term), and + % - the right-hand-side (the one argument). + % +:- pred generate_direct_arg_deconstruct(prog_var::in, prog_var::in, + tag_bits::in, uni_mode::in, mer_type::in, llds_code::out, + code_info::in, code_info::out) is det. + +generate_direct_arg_deconstruct(Var, Arg, Ptag, Mode, Type, Code, !CI) :- + Mode = ((LI - RI) -> (LF - RF)), + get_module_info(!.CI, ModuleInfo), + mode_to_arg_mode(ModuleInfo, (LI -> LF), Type, LeftMode), + mode_to_arg_mode(ModuleInfo, (RI -> RF), Type, RightMode), + ( + % Input - input == test unification + LeftMode = top_in, + RightMode = top_in + -> + % This shouldn't happen, since mode analysis should avoid creating + % any tests in the arguments of a construction or deconstruction + % unification. + unexpected($module, $pred, "test in arg of [de]construction") + ; + % Input - Output == assignment -> + LeftMode = top_in, + RightMode = top_out + -> + ( variable_is_forward_live(!.CI, Arg) -> + assign_expr_to_var(Arg, + binop(body, var(Var), const(llconst_int(Ptag))), Code, !CI) + ; + Code = empty + ) + ; + % Output - Input == assignment <- + LeftMode = top_out, + RightMode = top_in + -> + assign_expr_to_var(Var, mkword(Ptag, var(Arg)), Code, !CI) + ; + LeftMode = top_unused, + RightMode = top_unused + -> + Code = empty + % free-free - ignore + % XXX I think this will have to change if we start to support aliasing. + ; + unexpected($module, $pred, "some strange unify") + ). + %---------------------------------------------------------------------------% :- type active_ground_term == pair(rval, llds_type). @@ -1426,6 +1553,20 @@ generate_ground_term_conjunct_tag(Var, ConsTag, Args, UnboxedFloats, Rval = mkword(Ptag, CellPtrConst), ActiveGroundTerm = Rval - lt_data_ptr, map.det_insert(Var, ActiveGroundTerm, !ActiveMap) + ; + ConsTag = direct_arg_tag(Ptag), + ( + Args = [Arg], + map.det_remove(Arg, ArgRval - _RvalType, !ActiveMap), + Rval = mkword(Ptag, ArgRval), + ActiveGroundTerm = Rval - lt_data_ptr, + map.det_insert(Var, ActiveGroundTerm, !ActiveMap) + ; + ( Args = [] + ; Args = [_, _ | _] + ), + unexpected($module, $pred, "direct_arg_tag: arity != 1") + ) ; ConsTag = shared_remote_tag(Ptag, Stag), generate_ground_term_args(Args, ArgRvalsTypes, !ActiveMap), diff --git a/compiler/unify_proc.m b/compiler/unify_proc.m index 81d2a0a6f..a317f69ae 100644 --- a/compiler/unify_proc.m +++ b/compiler/unify_proc.m @@ -401,12 +401,14 @@ add_lazily_generated_unify_pred(TypeCtor, PredId, !ModuleInfo) :- ConsId = tuple_cons(TupleArity), map.from_assoc_list([ConsId - single_functor_tag], ConsTagValues), UnifyPred = no, + DirectArgCtors = no, DuTypeKind = du_type_kind_general, ReservedTag = does_not_use_reserved_tag, ReservedAddr = does_not_use_reserved_address, IsForeign = no, TypeBody = hlds_du_type([Ctor], ConsTagValues, no_cheaper_tag_test, - DuTypeKind, UnifyPred, ReservedTag, ReservedAddr, IsForeign), + DuTypeKind, UnifyPred, DirectArgCtors, ReservedTag, ReservedAddr, + IsForeign), construct_type(TypeCtor, TupleArgTypes, Type), term.context_init(Context) @@ -613,7 +615,7 @@ generate_initialise_proc_body(_Type, TypeBody, X, Context, Clause, !Info) :- Goal = hlds_goal(Call, GoalInfo), quantify_clause_body([X], Goal, Context, Clause, !Info) ; - ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _) + ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _, _) ; TypeBody = hlds_foreign_type(_) ; TypeBody = hlds_abstract_type(_) ), @@ -641,7 +643,7 @@ generate_unify_proc_body(Type, TypeBody, X, Y, Context, Clause, !Info) :- Clause, !Info) ; ( - TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _), + TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _, _), ( ( DuTypeKind = du_type_kind_mercury_enum ; DuTypeKind = du_type_kind_foreign_enum(_) @@ -842,7 +844,7 @@ generate_index_proc_body(Type, TypeBody, X, Index, Context, Clause, !Info) :- "trying to create index proc for non-canonical type") ; ( - TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _), + TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _, _), ( % For enum types, the generated comparison predicate performs % an integer comparison, and does not call the type's index @@ -914,7 +916,7 @@ generate_compare_proc_body(Type, TypeBody, Res, X, Y, Context, Clause, Res, X, Y, Context, Clause, !Info) ; ( - TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _), + TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _, _), ( ( DuTypeKind = du_type_kind_mercury_enum ; DuTypeKind = du_type_kind_foreign_enum(_) diff --git a/compiler/unused_imports.m b/compiler/unused_imports.m index 7d75bca43..7950f6f43 100644 --- a/compiler/unused_imports.m +++ b/compiler/unused_imports.m @@ -198,7 +198,7 @@ type_used_modules(_TypeCtor, TypeDefn, !UsedModules) :- DefinedInThisModule = yes, Visibility = item_visibility(ImportStatus), ( - TypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _), + TypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _, _), list.foldl(ctor_used_modules(Visibility), Ctors, !UsedModules) ; TypeBody = hlds_eqv_type(EqvType), diff --git a/compiler/xml_documentation.m b/compiler/xml_documentation.m index 79e581d28..6d71d5820 100644 --- a/compiler/xml_documentation.m +++ b/compiler/xml_documentation.m @@ -372,7 +372,7 @@ type_documentation(C, type_ctor(TypeName, TypeArity), TypeDefn, !Xmls) :- :- func type_xml_tag(hlds_type_body) = string. -type_xml_tag(hlds_du_type(_, _, _, _, _, _, _, _)) = "du_type". +type_xml_tag(hlds_du_type(_, _, _, _, _, _, _, _, _)) = "du_type". type_xml_tag(hlds_eqv_type(_)) = "eqv_type". type_xml_tag(hlds_foreign_type(_)) = "foreign_type". type_xml_tag(hlds_solver_type(_, _)) = "solver_type". @@ -386,7 +386,7 @@ type_param(TVarset, TVar) = Xml :- :- func type_body(comments, tvarset, hlds_type_body) = list(xml). -type_body(C, TVarset, hlds_du_type(Ctors, _, _, _, _, _, _, _)) = +type_body(C, TVarset, hlds_du_type(Ctors, _, _, _, _, _, _, _, _)) = [xml_list("constructors", constructor(C, TVarset), Ctors)]. type_body(_, TVarset, hlds_eqv_type(Type)) = [elem("equivalent_type", [], [mer_type(TVarset, Type)])]. diff --git a/doc/reference_manual.texi b/doc/reference_manual.texi index 6201c0ae4..a5bc2eac0 100644 --- a/doc/reference_manual.texi +++ b/doc/reference_manual.texi @@ -2005,6 +2005,39 @@ Note that excessive overloading of constructors can slow down type checking and can make the program confusing for human readers, so overloading should not be over-used. +@c XXX The `where direct_arg' attribute is not documented because it requires +@c the user has a detailed understanding of the type representation, and +@c is very implementation specific. The following is for implementors. + +@c Discriminated union type definitions may be followed by a +@c @samp{direct_arg} attribute of the following form: +@c +@c @example +@c where direct_arg is @var{ctors} +@c @end example +@c +@c @noindent +@c where @var{ctors} is a list of @var{functor-name} / @var{functor-arity}. +@c The functor arities must always be one. +@c +@c The attribute notifies importing modules that each of the functors +@c listed is to be represented as a tagged pointer to its argument. The +@c argument type must be known, when compiling the module that the type is +@c defined in, to not require the use of the tag bits. The compiler will +@c emit an error message otherwise. The compiler will silently ignore +@c functors which require a secondary tag. +@c +@c The optimised type representation is usually only applied if the +@c argument type is defined in the interface section of the same module. +@c This attribute allows the programmer to also apply it when the argument +@c type is known to the defining module, but not necessarily modules which +@c import the top-level type. +@c +@c Ideally, the @samp{direct_arg} attribute would be automatically +@c generated when making an interface file, so the user would never need to +@c write it manually. At this time, the compiler does not have enough +@c information when making interface files. + @node Equivalence types @subsection Equivalence types @@ -10051,7 +10084,6 @@ function then the compiler will quit with an error message. @c compiler option will have any useful effect if the @samp{--high-level-data} @c option is used (e.g. for the .NET or Java back-ends). - @c XXX TO DO! @c @node Compile-time garbage collection @c @section Compile-time garbage collection diff --git a/library/construct.m b/library/construct.m index 2a8485f0a..7ba5fa4dc 100644 --- a/library/construct.m +++ b/library/construct.m @@ -732,6 +732,19 @@ find_functor_2(TypeInfo, Functor, Arity, Num0, FunctorNumber, ArgTypes) :- MR_define_size_slot(ptag, new_data, size); break; + case MR_SECTAG_NONE_DIRECT_ARG: + arity = functor_desc->MR_du_functor_orig_arity; + if (arity != 1) { + MR_fatal_error( + ""construct(): direct_arg_tag arity != 1""); + } + + arg_data = MR_field(MR_UNIV_TAG, MR_list_head(arg_list), + MR_UNIV_OFFSET_FOR_DATA); + new_data = (MR_Word) MR_mkword(MR_mktag(ptag), arg_data); + arg_list = MR_list_tail(arg_list); + break; + case MR_SECTAG_VARIABLE: new_data = (MR_Word) 0; /* avoid a warning */ MR_fatal_error(""construct(): cannot construct variable""); diff --git a/library/private_builtin.m b/library/private_builtin.m index e9d00ef79..f624ffc89 100644 --- a/library/private_builtin.m +++ b/library/private_builtin.m @@ -1,7 +1,7 @@ %---------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et wm=0 tw=0 %---------------------------------------------------------------------------% -% Copyright (C) 1994-2007, 2010 The University of Melbourne. +% Copyright (C) 1994-2007, 2011 The University of Melbourne. % This file may only be copied under the terms of the GNU Library General % Public License - see the file COPYING.LIB in the Mercury distribution. %---------------------------------------------------------------------------% @@ -1722,10 +1722,11 @@ no_clauses(PredName) :- public static final int MR_TYPECTOR_REP_UNKNOWN = 46; public static final int MR_TYPECTOR_REP_MAX = 47; - public static final int MR_SECTAG_NONE = 0; - public static final int MR_SECTAG_LOCAL = 1; - public static final int MR_SECTAG_REMOTE = 2; - public static final int MR_SECTAG_VARIABLE = 3; + public static final int MR_SECTAG_NONE = 0; + public static final int MR_SECTAG_NONE_DIRECT_ARG = 1; + public static final int MR_SECTAG_LOCAL = 2; + public static final int MR_SECTAG_REMOTE = 3; + public static final int MR_SECTAG_VARIABLE = 4; public static final int MR_PREDICATE = 0; public static final int MR_FUNCTION = 1; diff --git a/runtime/mercury_deconstruct.c b/runtime/mercury_deconstruct.c index 7e826d3e3..d66ec7cb5 100644 --- a/runtime/mercury_deconstruct.c +++ b/runtime/mercury_deconstruct.c @@ -2,7 +2,7 @@ ** vim:ts=4 sw=4 expandtab */ /* -** Copyright (C) 2002-2007 The University of Melbourne. +** Copyright (C) 2002-2007, 2011 The University of Melbourne. ** This file may only be copied under the terms of the GNU Library General ** Public License - see the file COPYING.LIB in the Mercury distribution. */ @@ -202,6 +202,7 @@ MR_named_arg_num(MR_TypeInfo type_info, MR_Word *term_ptr, switch (ptag_layout->MR_sectag_locn) { case MR_SECTAG_NONE: + case MR_SECTAG_NONE_DIRECT_ARG: functor_desc = ptag_layout->MR_sectag_alternatives[0]; break; case MR_SECTAG_LOCAL: diff --git a/runtime/mercury_deep_copy_body.h b/runtime/mercury_deep_copy_body.h index 11c17c4c3..5adb1ace9 100644 --- a/runtime/mercury_deep_copy_body.h +++ b/runtime/mercury_deep_copy_body.h @@ -2,7 +2,7 @@ ** vim: ts=4 sw=4 expandtab */ /* -** Copyright (C) 1997-2005, 2007 The University of Melbourne. +** Copyright (C) 1997-2005, 2007, 2011 The University of Melbourne. ** This file may only be copied under the terms of the GNU Library General ** Public License - see the file COPYING.LIB in the Mercury distribution. */ @@ -183,6 +183,7 @@ try_again: /* case MR_SECTAG_REMOTE: */ /* case MR_SECTAG_NONE: */ + /* case MR_SECTAG_NONE_DIRECT_ARG: */ /* ** The code we want to execute for the MR_SECTAG_REMOTE ** and MR_SECTAG_NONE cases is very similar. However, @@ -323,6 +324,42 @@ try_again: MR_handle_sectag_remote_or_none(MR_FALSE); return new_data; + case MR_SECTAG_NONE_DIRECT_ARG: + /* + ** This code is a cut-down and specialized version + ** of the code for MR_SECTAG_NONE. + */ + data_value = (MR_Word *) MR_body(data, ptag); + RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word); + { + const MR_DuFunctorDesc *functor_desc; + const MR_DuExistInfo *exist_info; + int arity; + + functor_desc = ptag_layout->MR_sectag_alternatives[0]; + arity = functor_desc->MR_du_functor_orig_arity; + exist_info = functor_desc->MR_du_functor_exist_info; + if (arity != 1) { + MR_fatal_error("arity != 1 in direct arg tag functor"); + } + if (exist_info != NULL) { + MR_fatal_error("exist_info in direct arg tag functor"); + } + + new_data = copy((MR_Word) data_value, + MR_pseudo_type_info_is_ground( + functor_desc->MR_du_functor_arg_types[0]), + lower_limit, upper_limit); + + new_data = (MR_Word) MR_mkword(ptag, new_data); + /* + ** We cannot (and shouldn't need to) leave a forwarding + ** pointer for the whole term that is separate from the + ** forwarding pointer for the argument. + */ + } + return new_data; + case MR_SECTAG_VARIABLE: MR_fatal_error("copy(): attempt to copy variable"); diff --git a/runtime/mercury_grade.h b/runtime/mercury_grade.h index 093485503..96b658675 100644 --- a/runtime/mercury_grade.h +++ b/runtime/mercury_grade.h @@ -64,7 +64,7 @@ ** low-level C parallel grades respectively. */ -#define MR_GRADE_PART_0 v16_ +#define MR_GRADE_PART_0 v17_ #define MR_GRADE_EXEC_TRACE_VERSION_NO 9 #define MR_GRADE_DEEP_PROF_VERSION_NO 3 #define MR_GRADE_LLC_PAR_VERSION_NO 1 diff --git a/runtime/mercury_ml_expand_body.h b/runtime/mercury_ml_expand_body.h index 6b1ec891c..c6eb568e0 100644 --- a/runtime/mercury_ml_expand_body.h +++ b/runtime/mercury_ml_expand_body.h @@ -482,6 +482,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr, int ptag; MR_Word sectag; MR_Word *arg_vector; + MR_Word direct_arg; data = *data_word_ptr; ptag = MR_tag(data); @@ -492,6 +493,11 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr, functor_desc = ptag_layout->MR_sectag_alternatives[0]; arg_vector = (MR_Word *) MR_body(data, ptag); break; + case MR_SECTAG_NONE_DIRECT_ARG: + functor_desc = ptag_layout->MR_sectag_alternatives[0]; + direct_arg = MR_body(data, ptag); + arg_vector = &direct_arg; + break; case MR_SECTAG_LOCAL: sectag = MR_unmkbody(data); functor_desc = diff --git a/runtime/mercury_table_type_body.h b/runtime/mercury_table_type_body.h index d2a4c7bc7..8b94e6951 100644 --- a/runtime/mercury_table_type_body.h +++ b/runtime/mercury_table_type_body.h @@ -2,7 +2,7 @@ ** vim: ts=4 sw=4 expandtab */ /* -** Copyright (C) 2006-2007 The University of Melbourne. +** Copyright (C) 2006-2007, 2011 The University of Melbourne. ** This file may only be copied under the terms of the GNU Library General ** Public License - see the file COPYING.LIB in the Mercury distribution. */ @@ -136,6 +136,7 @@ int ptag; MR_Word sectag; MR_Word *arg_vector; + MR_Word direct_arg; int meta_args; int i; @@ -149,6 +150,12 @@ arg_vector = (MR_Word *) MR_body(data, ptag); break; + case MR_SECTAG_NONE_DIRECT_ARG: + functor_desc = ptag_layout->MR_sectag_alternatives[0]; + direct_arg = MR_body(data, ptag); + arg_vector = &direct_arg; + break; + case MR_SECTAG_LOCAL: sectag = MR_unmkbody(data); functor_desc = diff --git a/runtime/mercury_term_size.c b/runtime/mercury_term_size.c index 2542f2557..78d558f1c 100644 --- a/runtime/mercury_term_size.c +++ b/runtime/mercury_term_size.c @@ -2,7 +2,7 @@ ** vim:ts=4 sw=4 expandtab */ /* -** Copyright (C) 2003-2005, 2007, 2009 The University of Melbourne. +** Copyright (C) 2003-2005, 2007, 2009, 2011 The University of Melbourne. ** This file may only be copied under the terms of the GNU Library General ** Public License - see the file COPYING.LIB in the Mercury distribution. */ @@ -86,6 +86,13 @@ try_again: #endif return MR_field(MR_mktag(ptag), term, -1); + case MR_SECTAG_NONE_DIRECT_ARG: + /* + ** The compiler should not generate direct arg tags + ** in term size recording grades. + */ + MR_fatal_error("MR_term_size: DIRECT_ARG"); + case MR_SECTAG_LOCAL: #ifdef MR_DEBUG_TERM_SIZES if (MR_heapdebug && MR_lld_print_enabled) { diff --git a/runtime/mercury_type_info.h b/runtime/mercury_type_info.h index 279e4f12c..c12974e25 100644 --- a/runtime/mercury_type_info.h +++ b/runtime/mercury_type_info.h @@ -72,7 +72,7 @@ ** compiler/type_ctor_info.m. */ -#define MR_RTTI_VERSION MR_RTTI_VERSION__BITMAP +#define MR_RTTI_VERSION MR_RTTI_VERSION__DIRECT_ARG #define MR_RTTI_VERSION__INITIAL 2 #define MR_RTTI_VERSION__USEREQ 3 #define MR_RTTI_VERSION__CLEAN_LAYOUT 4 @@ -85,6 +85,7 @@ #define MR_RTTI_VERSION__DUMMY 11 #define MR_RTTI_VERSION__FUNCTOR_NUMBERS 12 #define MR_RTTI_VERSION__BITMAP 13 +#define MR_RTTI_VERSION__DIRECT_ARG 14 /* ** Check that the RTTI version is in a sensible range. @@ -839,6 +840,8 @@ typedef struct { ** ** The primary and secondary fields give the corresponding tag values, and ** the sectag_locn field gives the location of the secondary tag. +** MR_SECTAG_NONE_DIRECT_ARG is a sub-case of MR_SECTAG_NONE, where the +** function symbol is represented as a tagged pointer to its only argument. ** ** The ordinal field gives the position of the function symbol in the ** list of function symbols of the type; one function symbol compares @@ -872,6 +875,7 @@ typedef struct { typedef enum { MR_DEFINE_BUILTIN_ENUM_CONST(MR_SECTAG_NONE), + MR_DEFINE_BUILTIN_ENUM_CONST(MR_SECTAG_NONE_DIRECT_ARG), MR_DEFINE_BUILTIN_ENUM_CONST(MR_SECTAG_LOCAL), MR_DEFINE_BUILTIN_ENUM_CONST(MR_SECTAG_REMOTE), MR_DEFINE_BUILTIN_ENUM_CONST(MR_SECTAG_VARIABLE) @@ -969,9 +973,9 @@ typedef const MR_ReservedAddrFunctorDesc *MR_ReservedAddrFunctorDescPtr; ** ** The intention is that if you have a word in a DU type that you want to ** interpret, you compute its primary tag and find its MR_DuPtagLayout. -** You then look at the locn field. If it is MR_SECTAG_NONE, you index -** the alternatives field with zero; if it is MR_SECTAG_{LOCAL,REMOTE}, you -** compute the secondary tag and index the alternatives field with that. +** You then look at the locn field. If it is MR_SECTAG_NONE{,_DIRECT_ARG}, you +** index the alternatives field with zero; if it is MR_SECTAG_{LOCAL,REMOTE}, +** you compute the secondary tag and index the alternatives field with that. ** ** A value of type MR_DuTypeLayout points to an array of MR_DuPtagLayout ** structures. The element at index k gives information about primary tag @@ -1399,7 +1403,7 @@ typedef void MR_CALL MR_CompareFunc_5(MR_Mercury_Type_Info, #define MR_DEFINE_TYPE_CTOR_INFO_BODY_FLAG(m, n, a, cr, u, c, f, fns) \ { \ a, \ - MR_RTTI_VERSION__FUNCTOR_NUMBERS, \ + MR_RTTI_VERSION__DIRECT_ARG, \ -1, \ MR_PASTE2(MR_TYPECTOR_REP_, cr), \ MR_DEFINE_TYPE_CTOR_INFO_CODE(u), \ diff --git a/runtime/mercury_unify_compare_body.h b/runtime/mercury_unify_compare_body.h index 1d9f2a0c4..08c3941a5 100644 --- a/runtime/mercury_unify_compare_body.h +++ b/runtime/mercury_unify_compare_body.h @@ -2,7 +2,7 @@ ** vim:ts=4 sw=4 expandtab */ /* -** Copyright (C) 2000-2005, 2007 The University of Melbourne. +** Copyright (C) 2000-2005, 2007, 2011 The University of Melbourne. ** This file may only be copied under the terms of the GNU Library General ** Public License - see the file COPYING.LIB in the Mercury distribution. */ @@ -228,6 +228,7 @@ start_label: sectag = data_value[0]; \ break; \ case MR_SECTAG_NONE: \ + case MR_SECTAG_NONE_DIRECT_ARG: \ sectag = 0; \ break; \ case MR_SECTAG_VARIABLE: \ @@ -300,6 +301,7 @@ start_label: break; case MR_SECTAG_NONE: + case MR_SECTAG_NONE_DIRECT_ARG: x_sectag = 0; break; @@ -311,12 +313,52 @@ start_label: functor_desc = ptaglayout->MR_sectag_alternatives[x_sectag]; #endif /* select_compare_code */ - if (functor_desc->MR_du_functor_sectag_locn == - MR_SECTAG_REMOTE) - { + switch (functor_desc->MR_du_functor_sectag_locn) { + + case MR_SECTAG_NONE_DIRECT_ARG: + /* the work is done in the switch */ + { + MR_TypeInfo arg_type_info; + + arg_type_info = (MR_TypeInfo) + functor_desc->MR_du_functor_arg_types[0]; + MR_save_transient_registers(); + #ifdef select_compare_code + #ifdef include_compare_rep_code + result = MR_generic_compare_representation( + arg_type_info, + (MR_Word) x_data_value, (MR_Word) y_data_value); + #else + result = MR_generic_compare(arg_type_info, + (MR_Word) x_data_value, (MR_Word) y_data_value); + #endif + #else + result = MR_generic_unify(arg_type_info, + (MR_Word) x_data_value, (MR_Word) y_data_value); + #endif + MR_restore_transient_registers(); + } + + #ifdef select_compare_code + return_compare_answer(builtin, user_by_rtti, 0, result); + #else + return_unify_answer(builtin, user_by_rtti, 0, result); + #endif + break; + + case MR_SECTAG_REMOTE: cur_slot = 1; - } else { + /* the work is done after the switch */ + break; + + case MR_SECTAG_NONE: + case MR_SECTAG_LOCAL: cur_slot = 0; + /* the work is done after the switch */ + break; + + default: + MR_fatal_error("bad sectag location in direct arg switch"); } arity = functor_desc->MR_du_functor_orig_arity; diff --git a/tests/debugger/Mmakefile b/tests/debugger/Mmakefile index 58040eea0..50d354466 100644 --- a/tests/debugger/Mmakefile +++ b/tests/debugger/Mmakefile @@ -7,6 +7,7 @@ THIS_DIR = debugger RETRY_PROGS = \ all_solutions \ browser_test \ + chooser_tag_test \ io_tab_goto \ lambda_expr \ mdb_command_test \ @@ -284,7 +285,11 @@ cmd_quote.out: cmd_quote cmd_quote.inp sed 's/io.m:[0-9]*/io.m:NNNN/g' > cmd_quote.out 2>&1 cond.out: cond cond.inp - $(MDB_STD) ./cond < cond.inp 2>&1 > cond.out 2>&1 + $(MDB_STD) ./cond < cond.inp > cond.out 2>&1 + +chooser_tag_test.out: chooser_tag_test chooser_tag_test.inp + $(MDB_STD) ./chooser_tag_test < chooser_tag_test.inp \ + > chooser_tag_test.out 2>&1 # Set up readline to make it easier to use completion non-interactively. completion.out: completion completion.inp diff --git a/tests/debugger/chooser_tag_test.exp b/tests/debugger/chooser_tag_test.exp new file mode 100644 index 000000000..361cc338e --- /dev/null +++ b/tests/debugger/chooser_tag_test.exp @@ -0,0 +1,54 @@ + E1: C1 CALL pred chooser_tag_test.main/2-0 (det) chooser_tag_test.m:54 +mdb> mdb> echo on +Command echo enabled. +mdb> context none +Contexts will not be printed. +mdb> break test_wraps + 0: + stop interface pred chooser_tag_test.test_wraps/2-0 (det) +mdb> continue + E2: C2 CALL pred chooser_tag_test.test_wraps/2-0 (det) +mdb> finish +test_wrap_a: A0 = a(10, 11), X = xa(a(10, 11)), A1 = a(10, 11) +test_wrap_a: A0 = a(12, 20), X = xa(a(12, 20)), A1 = a(12, 20) +test_wrap_b: B0 = b(10, "eleven"), X = xb(b(10, "eleven")), B1 = b(10, "eleven") +test_wrap_b: B0 = b(12, "twenty"), X = xb(b(12, "twenty")), B1 = b(12, "twenty") +test_wrap_c: C0 = c("ten", 11), X = xc(c("ten", 11)), C1 = c("ten", 11) +test_wrap_c: C0 = c("twelve", 20), X = xc(c("twelve", 20)), C1 = c("twelve", 20) + E3: C2 EXIT pred chooser_tag_test.test_wraps/2-0 (det) +mdb> retry -f + E2: C2 CALL pred chooser_tag_test.test_wraps/2-0 (det) +mdb> break wrap_a + 1: + stop interface pred chooser_tag_test.wrap_a/2-0 (det) +mdb> continue + E4: C3 CALL pred chooser_tag_test.wrap_a/2-0 (det) +mdb> print * + A (arg 1) a(10, 11) +mdb> finish + E5: C3 EXIT pred chooser_tag_test.wrap_a/2-0 (det) +mdb> print * + A (arg 1) a(10, 11) + HeadVar__2 xa(a(10, 11)) +mdb> delete * + 0: E stop interface pred chooser_tag_test.test_wraps/2-0 (det) + 1: E stop interface pred chooser_tag_test.wrap_a/2-0 (det) +mdb> break unwrap_b + 0: + stop interface pred chooser_tag_test.unwrap_b/2-0 (semidet) +mdb> condition HeadVar__1 = xb(b(12, _)) + 0: + stop interface pred chooser_tag_test.unwrap_b/2-0 (semidet) + HeadVar__1 = xb(b(12, _)) +mdb> continue +test_wrap_a: A0 = a(10, 11), X = xa(a(10, 11)), A1 = a(10, 11) +test_wrap_a: A0 = a(12, 20), X = xa(a(12, 20)), A1 = a(12, 20) +test_wrap_b: B0 = b(10, "eleven"), X = xb(b(10, "eleven")), B1 = b(10, "eleven") + E6: C4 CALL pred chooser_tag_test.unwrap_b/2-0 (semidet) +mdb> print +unwrap_b(xb(b(12, "twenty")), _) +mdb> delete * + 0: E stop interface pred chooser_tag_test.unwrap_b/2-0 (semidet) + HeadVar__1 = xb(b(12, _)) +mdb> continue +test_wrap_b: B0 = b(12, "twenty"), X = xb(b(12, "twenty")), B1 = b(12, "twenty") +test_wrap_c: C0 = c("ten", 11), X = xc(c("ten", 11)), C1 = c("ten", 11) +test_wrap_c: C0 = c("twelve", 20), X = xc(c("twelve", 20)), C1 = c("twelve", 20) +solns for 30 = [xa(a(30, 30)), xa(a(31, 31)), xb(b(30, "b2")), xb(b(31, "b2")), xc(c("c1", 30)), xc(c("c1", 31))] +solns for 130 = [] diff --git a/tests/debugger/chooser_tag_test.inp b/tests/debugger/chooser_tag_test.inp new file mode 100644 index 000000000..1788179e4 --- /dev/null +++ b/tests/debugger/chooser_tag_test.inp @@ -0,0 +1,19 @@ +register --quiet +echo on +context none +break test_wraps +continue +finish +retry -f +break wrap_a +continue +print * +finish +print * +delete * +break unwrap_b +condition HeadVar__1 = xb(b(12, _)) +continue +print +delete * +continue diff --git a/tests/debugger/chooser_tag_test.m b/tests/debugger/chooser_tag_test.m new file mode 100644 index 000000000..2ca064950 --- /dev/null +++ b/tests/debugger/chooser_tag_test.m @@ -0,0 +1,173 @@ +%-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 +%-----------------------------------------------------------------------------% + +:- module chooser_tag_test. +:- interface. + +:- import_module io. + +:- type a + ---> a(a1 :: int, a2 :: int). + +:- type b + ---> b(b1 :: int, b2 :: string). + +:- type c + ---> c(c1 :: string, c2 :: int). + +:- type x + ---> xa(xaf:: a) + ; xb(xbf:: b) + ; xc(xcf:: c) + ; xd + ; xe. + +:- pred wrap_a(a::in, x::out) is det. +:- pred wrap_b(b::in, x::out) is det. +:- pred wrap_c(c::in, x::out) is det. + +:- pred unwrap_a(x::in, a::out) is semidet. +:- pred unwrap_b(x::in, b::out) is semidet. +:- pred unwrap_c(x::in, c::out) is semidet. + +:- pred main(io::di, io::uo) is det. + +%-----------------------------------------------------------------------------% + +:- implementation. + +:- import_module int. +:- import_module list. +:- import_module maybe. +:- import_module solutions. +:- import_module string. + +wrap_a(A, xa(A)). +wrap_b(B, xb(B)). +wrap_c(C, xc(C)). + +unwrap_a(xa(A), A). +unwrap_b(xb(B), B). +unwrap_c(xc(C), C). + +main(!IO) :- + test_wraps(!IO), + test_solutions(30, !IO), + test_solutions(130, !IO). + +:- pred test_wraps(io::di, io::uo) is det. + +test_wraps(!IO) :- + list.foldl(test_wrap_a, [a(10, 11), a(12, 20)], !IO), + list.foldl(test_wrap_b, [b(10, "eleven"), b(12, "twenty")], !IO), + list.foldl(test_wrap_c, [c("ten", 11), c("twelve", 20)], !IO). + +:- pred test_wrap_a(a::in, io::di, io::uo) is det. + +test_wrap_a(A0, !IO) :- + wrap_a(A0, X), + ( unwrap_a(X, A1_Prime) -> + MaybeA1 = yes(A1_Prime) + ; + MaybeA1 = no + ), + io.write_string("test_wrap_a: A0 = ", !IO), + io.write(A0, !IO), + io.write_string(", X = ", !IO), + io.write(X, !IO), + io.write_string(", A1 = ", !IO), + ( + MaybeA1 = yes(A1), + io.write(A1, !IO) + ; + MaybeA1 = no, + io.write_string("unwrap failed", !IO) + ), + io.nl(!IO). + +:- pred test_wrap_b(b::in, io::di, io::uo) is det. + +test_wrap_b(B0, !IO) :- + wrap_b(B0, X), + ( unwrap_b(X, B1_Prime) -> + MaybeB1 = yes(B1_Prime) + ; + MaybeB1 = no + ), + io.write_string("test_wrap_b: B0 = ", !IO), + io.write(B0, !IO), + io.write_string(", X = ", !IO), + io.write(X, !IO), + io.write_string(", B1 = ", !IO), + ( + MaybeB1 = yes(B1), + io.write(B1, !IO) + ; + MaybeB1 = no, + io.write_string("unwrap failed", !IO) + ), + io.nl(!IO). + +:- pred test_wrap_c(c::in, io::di, io::uo) is det. + +test_wrap_c(C0, !IO) :- + wrap_c(C0, X), + ( unwrap_c(X, C1_Prime) -> + MaybeC1 = yes(C1_Prime) + ; + MaybeC1 = no + ), + io.write_string("test_wrap_c: C0 = ", !IO), + io.write(C0, !IO), + io.write_string(", X = ", !IO), + io.write(X, !IO), + io.write_string(", C1 = ", !IO), + ( + MaybeC1 = yes(C1), + io.write(C1, !IO) + ; + MaybeC1 = no, + io.write_string("unwrap failed", !IO) + ), + io.nl(!IO). + +:- pred test_solutions(int::in, io::di, io::uo) is det. + +test_solutions(N, !IO) :- + solutions(get_solutions(N), Solns), + io.format("solns for %d = ", [i(N)], !IO), + io.write(Solns, !IO), + io.nl(!IO). + +:- pred get_solutions(int::in, x::out) is nondet. + +get_solutions(N, X) :- + ( get_solutions_a(N, X) + ; get_solutions_b(N, X) + ; get_solutions_c(N, X) + ). + +:- pred get_solutions_a(int::in, x::out) is nondet. + +get_solutions_a(N, X) :- + N < 100, + ( X = xa(a(N, N)) + ; X = xa(a(N+1, N+1)) + ). + +:- pred get_solutions_b(int::in, x::out) is nondet. + +get_solutions_b(N, X) :- + N < 100, + ( X = xb(b(N, "b2")) + ; X = xb(b(N+1, "b2")) + ). + +:- pred get_solutions_c(int::in, x::out) is nondet. + +get_solutions_c(N, X) :- + N < 100, + ( X = xc(c("c1", N)) + ; X = xc(c("c1", N+1)) + ). diff --git a/tests/hard_coded/Mercury.options b/tests/hard_coded/Mercury.options index cc52d3939..3d9a64a47 100644 --- a/tests/hard_coded/Mercury.options +++ b/tests/hard_coded/Mercury.options @@ -18,6 +18,12 @@ MCFLAGS-constraint_order = --constraint-propagation --enable-termination MCFLAGS-deforest_cc_bug = --deforestation MCFLAGS-delay_partial_test = --delay-partial-instantiations MCFLAGS-delay_partial_test2 = --delay-partial-instantiations +MCFLAGS-direct_arg_cyclic1 = --intermodule-optimization +MCFLAGS-direct_arg_cyclic2 = --intermodule-optimization +MCFLAGS-direct_arg_cyclic3 = --intermodule-optimization +MCFLAGS-direct_arg_intermod1 = --intermodule-optimization +MCFLAGS-direct_arg_intermod2 = --intermodule-optimization +MCFLAGS-direct_arg_intermod3 = --intermodule-optimization MCFLAGS-lp = --intermodule-optimization -O3 MCFLAGS-elim_local_var_char = --eliminate-local-vars MCFLAGS-float_consistency = --optimize-constant-propagation diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile index c0e167bbd..5ccabd3d7 100644 --- a/tests/hard_coded/Mmakefile +++ b/tests/hard_coded/Mmakefile @@ -61,6 +61,9 @@ ORDINARY_PROGS= \ dense_lookup_switch3 \ dense_lookup_switch_non \ det_in_semidet_cntxt \ + direct_arg_cyclic1 \ + direct_arg_intermod1 \ + direct_arg_parent \ disjs_in_switch \ division_test \ dos \ diff --git a/tests/hard_coded/construct_test.exp b/tests/hard_coded/construct_test.exp index 15f0004db..cc7d8ee91 100644 --- a/tests/hard_coded/construct_test.exp +++ b/tests/hard_coded/construct_test.exp @@ -184,6 +184,11 @@ TESTING OTHER TYPES 0 - dummy/0 [] ordinal: 0 lex: 0 +2 functors in this type +1 - unboxed_arg/1 [_] ordinal: 1 lex: 1 +0 - no/0 [] ordinal: 0 lex: 0 + + 1 functors in this type 0 - xyzzy/1 [f21name] ordinal: 0 lex: 0 @@ -218,6 +223,8 @@ About to construct zop/2 Constructed: zop(2.1, 2.1) About to construct qwerty/1 Constructed: qwerty(1) +About to construct unboxed_arg/1 +Constructed: unboxed_arg(unboxed_struct(12, 34)) About to construct poly_one/1 Constructed: poly_one(1) About to construct poly_two/1 diff --git a/tests/hard_coded/construct_test.m b/tests/hard_coded/construct_test.m index ae041be5c..006d1c191 100644 --- a/tests/hard_coded/construct_test.m +++ b/tests/hard_coded/construct_test.m @@ -31,6 +31,10 @@ :- type dummy ---> dummy. +:- type unboxed_arg ---> no ; unboxed_arg(unboxed_struct). + +:- type unboxed_struct ---> unboxed_struct(int, int). + :- type exist_type ---> some [T] xyzzy(f21name :: T). %----------------------------------------------------------------------------% @@ -84,6 +88,11 @@ test_construct --> % No-tag type: test_construct_2(type_desc__type_of(qwerty(7)), "qwerty", 1, [One]), + % Functor with single unboxed argument. + { type_to_univ(unboxed_struct(12, 34), UnboxedStruct) }, + test_construct_2(type_desc__type_of(_ : unboxed_arg), "unboxed_arg", + 1, [UnboxedStruct]), + { type_to_univ("goodbye", Bye) }, test_construct_2(type_desc__type_of(poly_four(3, "hello")), @@ -316,6 +325,9 @@ test_other --> % a dummy type test_all(dummy), newline, + % a functor with a single unboxed argument + test_all(unboxed_arg(unboxed_struct(12, 34))), newline, + % an existential type: { ExistVal = 'new xyzzy'(8) }, test_all(ExistVal), newline. diff --git a/tests/hard_coded/direct_arg_cyclic1.exp b/tests/hard_coded/direct_arg_cyclic1.exp new file mode 100644 index 000000000..af5626b4a --- /dev/null +++ b/tests/hard_coded/direct_arg_cyclic1.exp @@ -0,0 +1 @@ +Hello, world! diff --git a/tests/hard_coded/direct_arg_cyclic1.m b/tests/hard_coded/direct_arg_cyclic1.m new file mode 100644 index 000000000..a9f2802a9 --- /dev/null +++ b/tests/hard_coded/direct_arg_cyclic1.m @@ -0,0 +1,17 @@ +:- module direct_arg_cyclic1. + +:- interface. + +:- import_module io. + +:- pred main(io, io). +:- mode main(di, uo) is det. + +:- implementation. + +:- import_module direct_arg_cyclic2. +% not :- import_module direct_arg_cyclic3. + +main(!IO) :- + write_string("Hello, world!\n", !IO). + diff --git a/tests/hard_coded/direct_arg_cyclic2.m b/tests/hard_coded/direct_arg_cyclic2.m new file mode 100644 index 000000000..96929b3a6 --- /dev/null +++ b/tests/hard_coded/direct_arg_cyclic2.m @@ -0,0 +1,14 @@ +:- module direct_arg_cyclic2. + +:- interface. + +:- import_module direct_arg_cyclic3. + +:- type grapheme + ---> grapheme(int, int, int, int). + +:- func okay(int) = maybe_grapheme. + +:- implementation. + +okay(_) = no_grapheme. diff --git a/tests/hard_coded/direct_arg_cyclic3.m b/tests/hard_coded/direct_arg_cyclic3.m new file mode 100644 index 000000000..2020433f6 --- /dev/null +++ b/tests/hard_coded/direct_arg_cyclic3.m @@ -0,0 +1,10 @@ +:- module direct_arg_cyclic3. + +:- interface. + +:- import_module direct_arg_cyclic2. + +:- type maybe_grapheme + ---> no_grapheme + ; yes_grapheme(grapheme) + where direct_arg is [yes_grapheme/1]. diff --git a/tests/hard_coded/direct_arg_intermod1.exp b/tests/hard_coded/direct_arg_intermod1.exp new file mode 100644 index 000000000..047486dcc --- /dev/null +++ b/tests/hard_coded/direct_arg_intermod1.exp @@ -0,0 +1,4 @@ +yes(foo(1, 1)) +yes(foo(1, 1)) +yes(foo(1, 2)) +yes(foo(1, 2)) diff --git a/tests/hard_coded/direct_arg_intermod1.m b/tests/hard_coded/direct_arg_intermod1.m new file mode 100644 index 000000000..c9c7e4033 --- /dev/null +++ b/tests/hard_coded/direct_arg_intermod1.m @@ -0,0 +1,34 @@ +% A tricky situation for the direct argument type representation optimisation. + +:- module direct_arg_intermod1. +:- interface. + +:- import_module io. + +:- pred main(io::di, io::uo) is det. + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +:- implementation. + +:- import_module direct_arg_intermod2. + +%-----------------------------------------------------------------------------% + +main(!IO) :- + M1 = mk_maybe_inline(one, 1), + write_maybe_inline(M1, !IO), + write_maybe_no_inline(M1, !IO), + + M2 = mk_maybe_no_inline(one, 2), + write_maybe_inline(M2, !IO), + write_maybe_no_inline(M2, !IO). + +:- func one = int. +:- pragma no_inline(one/0). + +one = 1. + +%-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sts=4 sw=4 et diff --git a/tests/hard_coded/direct_arg_intermod2.m b/tests/hard_coded/direct_arg_intermod2.m new file mode 100644 index 000000000..9041b029d --- /dev/null +++ b/tests/hard_coded/direct_arg_intermod2.m @@ -0,0 +1,65 @@ +%-----------------------------------------------------------------------------% + +:- module direct_arg_intermod2. +:- interface. + +:- import_module io. + +:- type maybe. + +:- func mk_maybe_inline(int, int) = maybe. + +:- func mk_maybe_no_inline(int, int) = maybe. + +:- pred write_maybe_inline(maybe::in, io::di, io::uo) is det. + +:- pred write_maybe_no_inline(maybe::in, io::di, io::uo) is det. + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +:- implementation. + +:- import_module direct_arg_intermod3. + +:- type maybe == inner_maybe. + + % inner_maybe is not exported so the direct arg represention should be safe + % for yes/1. But when it is opt-exported, the importing module also needs + % to use the direct arg represention, without necessarily knowing the + % definition of foo. + % +:- type inner_maybe + ---> no + ; yes(foo). + +%-----------------------------------------------------------------------------% + +:- pragma inline(mk_maybe_inline/2). + +mk_maybe_inline(A, B) = yes(foo(A, B)). + +:- pragma no_inline(mk_maybe_no_inline/2). + +mk_maybe_no_inline(A, B) = mk_maybe_inline(A, B). + +:- pragma inline(write_maybe_inline/3). + +write_maybe_inline(M, !IO) :- + ( + M = no, + write_string("no\n", !IO) + ; + M = yes(Foo), + write_string("yes(", !IO), + write(Foo, !IO), + write_string(")\n", !IO) + ). + +:- pragma no_inline(write_maybe_no_inline/3). + +write_maybe_no_inline(M, !IO) :- + write_maybe_inline(M, !IO). + +%-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sts=4 sw=4 et diff --git a/tests/hard_coded/direct_arg_intermod3.m b/tests/hard_coded/direct_arg_intermod3.m new file mode 100644 index 000000000..7eefd0123 --- /dev/null +++ b/tests/hard_coded/direct_arg_intermod3.m @@ -0,0 +1,9 @@ +%-----------------------------------------------------------------------------% + +:- module direct_arg_intermod3. +:- interface. + +:- type foo ---> foo(int, int). + +%-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sts=4 sw=4 et diff --git a/tests/hard_coded/direct_arg_parent.exp b/tests/hard_coded/direct_arg_parent.exp new file mode 100644 index 000000000..54a1bc3c3 --- /dev/null +++ b/tests/hard_coded/direct_arg_parent.exp @@ -0,0 +1,2 @@ +not_possible(foo(1, 1)) +forced(foo(1, 2)) diff --git a/tests/hard_coded/direct_arg_parent.m b/tests/hard_coded/direct_arg_parent.m new file mode 100644 index 000000000..87f8d663d --- /dev/null +++ b/tests/hard_coded/direct_arg_parent.m @@ -0,0 +1,39 @@ +% Test potential problems with direct argument type representation and +% sub-modules. + +:- module direct_arg_parent. +:- interface. + +:- import_module io. + +:- pred main(io::di, io::uo) is det. + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +:- implementation. + +:- include_module direct_arg_parent.direct_arg_sub. +:- import_module direct_arg_parent.direct_arg_sub. + +:- type maybe_foo + ---> no + ; not_possible(foo) + ; forced(foo) + where direct_arg is [forced/1]. + +%-----------------------------------------------------------------------------% + +main(!IO) :- + M1 = not_possible(foo(one, 1)), + M2 = forced(foo(one, 2)), + direct_arg_sub.write_maybe_foo(M1, !IO), + direct_arg_sub.write_maybe_foo(M2, !IO). + +:- func one = int. +:- pragma no_inline(one/0). + +one = 1. + +%-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sts=4 sw=4 et diff --git a/tests/hard_coded/direct_arg_sub.m b/tests/hard_coded/direct_arg_sub.m new file mode 100644 index 000000000..a11e94aa8 --- /dev/null +++ b/tests/hard_coded/direct_arg_sub.m @@ -0,0 +1,37 @@ +%-----------------------------------------------------------------------------% + +:- module direct_arg_parent.direct_arg_sub. +:- interface. + +:- import_module io. + +:- type foo + ---> foo(int, int). + +:- pred write_maybe_foo(maybe_foo::in, io::di, io::uo) is det. + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +:- implementation. + +:- pragma no_inline(write_maybe_foo/3). + +write_maybe_foo(M, !IO) :- + ( + M = no, + write_string("no\n", !IO) + ; + M = not_possible(Foo), + write_string("not_possible(", !IO), + write(Foo, !IO), + write_string(")\n", !IO) + ; + M = forced(Foo), + write_string("forced(", !IO), + write(Foo, !IO), + write_string(")\n", !IO) + ). + +%-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sts=4 sw=4 et diff --git a/tests/invalid/Mmakefile b/tests/invalid/Mmakefile index 74e24ea91..3c2152973 100644 --- a/tests/invalid/Mmakefile +++ b/tests/invalid/Mmakefile @@ -251,6 +251,8 @@ SINGLEMODULE= \ user_eq_dummy \ uu_type \ vars_in_wrong_places \ + where_direct_arg \ + where_direct_arg2 \ with_type \ zinc2mer_lib diff --git a/tests/invalid/ee_invalid.err_exp b/tests/invalid/ee_invalid.err_exp index ca0cc7409..3a93fcc8b 100644 --- a/tests/invalid/ee_invalid.err_exp +++ b/tests/invalid/ee_invalid.err_exp @@ -5,7 +5,7 @@ ee_invalid.m:037: error: undefined type `undefined_type'/0. ee_invalid.m:041: In `pragma foreign_export_enum' declaration for ee_invalid.m:041: `ee_invalid.foo'/1: ee_invalid.m:041: error: `ee_invalid.foo'/1 is not an enumeration type. It -ee_invalid.m:041: has one more non-zero arity constructors. +ee_invalid.m:041: has one or more non-zero arity constructors. ee_invalid.m:045: In `pragma foreign_export_enum' declaration for ee_invalid.m:045: `ee_invalid.bar'/0: ee_invalid.m:045: error: `ee_invalid.bar'/0 is not an enumeration type. diff --git a/tests/invalid/where_direct_arg.err_exp b/tests/invalid/where_direct_arg.err_exp new file mode 100644 index 000000000..91e801773 --- /dev/null +++ b/tests/invalid/where_direct_arg.err_exp @@ -0,0 +1,9 @@ +where_direct_arg.m:012: Error: the `direct_arg' attribute contains a function +where_direct_arg.m:012: symbol whose arity is not 1. +where_direct_arg.m:012: Error: the `direct_arg' attribute lists the function +where_direct_arg.m:012: symbol `where_direct_arg.nonexistent'/1 which is not +where_direct_arg.m:012: in the type definition. +where_direct_arg.m:016: Error: only solver types can be defined by a `where' +where_direct_arg.m:016: block alone. +where_direct_arg.m:018: Error: solver type definitions cannot have `direct_arg' +where_direct_arg.m:018: attributes. diff --git a/tests/invalid/where_direct_arg.m b/tests/invalid/where_direct_arg.m new file mode 100644 index 000000000..c07ed95b3 --- /dev/null +++ b/tests/invalid/where_direct_arg.m @@ -0,0 +1,23 @@ +%-----------------------------------------------------------------------------% + +:- module where_direct_arg. +:- interface. + +:- type bad_example + ---> zero + ; two(int, int) + ; string(string) + ; int(int) + ; tuple({int, int}) + where direct_arg is [ + zero/0, two/2, string/1, int/1, tuple/1, nonexistent/1 + ]. + +:- type bad_example2 where direct_arg is [struct/1]. + +:- solver type bad_example3 where direct_arg is []. + +:- type dummy ---> dummy. + +%-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sts=4 sw=4 et diff --git a/tests/invalid/where_direct_arg2.err_exp b/tests/invalid/where_direct_arg2.err_exp new file mode 100644 index 000000000..abc790c8c --- /dev/null +++ b/tests/invalid/where_direct_arg2.err_exp @@ -0,0 +1,10 @@ +where_direct_arg2.m:009: Error: `where_direct_arg2.string'/1 cannot be +where_direct_arg2.m:009: represented as a direct pointer to its sole +where_direct_arg2.m:009: argument. +where_direct_arg2.m:010: Error: `where_direct_arg2.int'/1 cannot be represented +where_direct_arg2.m:010: as a direct pointer to its sole argument. +where_direct_arg2.m:014: Error: `where_direct_arg2.enum'/1 cannot be +where_direct_arg2.m:014: represented as a direct pointer to its sole +where_direct_arg2.m:014: argument. +where_direct_arg2.m:036: Error: `direct_arg' attribute is not applicable to +where_direct_arg2.m:036: foreign types. diff --git a/tests/invalid/where_direct_arg2.m b/tests/invalid/where_direct_arg2.m new file mode 100644 index 000000000..715d2fa7e --- /dev/null +++ b/tests/invalid/where_direct_arg2.m @@ -0,0 +1,39 @@ +%-----------------------------------------------------------------------------% + +:- module where_direct_arg2. +:- interface. + +:- type bad_example + ---> zero + ; two(int, int) + ; string(string) + ; int(int) + ; struct(struct) + ; eqv(eqv_struct) + ; tuple({int, int}) + ; enum(enum) + where direct_arg is [string/1, int/1, struct/1, eqv/1, tuple/1, enum/1]. + +:- type struct ---> struct(int, int). +:- type eqv_struct == struct. + +:- type enum + ---> enum1 + ; enum2 + ; enum3. + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +:- implementation. + +:- type good_example + ---> nil + ; struct(struct) + where direct_arg is [struct/1]. + +:- type foreign ---> foreign. +:- pragma foreign_type("C", foreign, "int") where direct_arg is []. + +%-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sts=4 sw=4 et