From cc88711d639c4aa464b6b0178008c71d8e3f4074 Mon Sep 17 00:00:00 2001 From: Zoltan Somogyi Date: Sun, 30 Dec 2007 08:24:23 +0000 Subject: [PATCH] Implement true multi-cons_id arm switches, i.e. switches in which we associate Estimated hours taken: 40 Branches: main Implement true multi-cons_id arm switches, i.e. switches in which we associate more than one cons_id with a switch arm. Previously, for switches like this: ( X = a, goal1 ; ( X = b ; X = c ), goal2 ) we duplicated goal2. With this diff, goal2 won't be duplicated. We still duplicate goals when that is necessary, i.e. in cases which the inner disjunction contains code other than a functor test on the switched-on var, like this: ( X = a, goal1 ; ( X = b, goalb ; X = c goalc ), goal2 ) For now, true multi-cons_id arm switches are supported only by the LLDS backend. Supporting them on the MLDS backend is trickier, because some MLDS target languages (e.g. Java) don't support the concept at all. So when compiling to MLDS, we still duplicate the goal in switch detection (although we could delay the duplication to just before code generation, if we wanted.) compiler/options.m: Add an internal option that tells switch detection whether to look for multi-cons_id switch arms. compiler/handle_options.m: Set this option based on the back end. Add a version of the "trans" dump level that doesn't print unification details. compiler/hlds_goal.m: Extend the representation of switch cases to allow more than one cons_id for a switch arm. Add a type for representing switches that also includes tag information (for use by the backends). compiler/hlds_data.m: For du types, record whether it is possible to speed up tests for one cons_id (e.g. cons) by testing for the other (nil) and negating the result. Recording this information once is faster than having unify_gen.m trying to compute it from scratch for every single tag test. Add a type for representing a cons_id together with its tag. compiler/hlds_out.m: Print out the cheaper_tag_test information for types, and possibly several cons_ids for each switch arm. Add some utility predicates for describing switch arms in terms of which cons_ids they are for. Replace some booleans with purpose-specific types. Make hlds_out honor is documentation, and not print out detailed information about unifications (e.g. uniqueness and static allocation) unless the right character ('u') is present in the control string. compiler/add_type.m: Fill in the information about cheaper tag tests when adding a du type. compiler/switch_detection.m: Extend the switch detection algorithm to detect multi-cons_id switch arms. When entering a switch arm, update the instmap to reflect that the switched-on variable can now be bound only to the cons_ids that this switch arm is for. We now need to do this, because if the arm contains another switch on the same variable, computing the can_fail field of that switch correctly requires us to know this information. (Obviously, an arm for a single cons_id is unlikely to have switch on the same variable, and for arms for several cons_ids, we previously duplicated the arm and left the unification with the cons_id in each copy, and this unification allowed the correct handling of any later switches. However, the code of a multi-cons_id switch arm obviously cannot have a unification with each cons_id in it, which is why we now need to get the binding information from the switch itself.) Replace some booleans with purpose-specific types, and give some predicates better names. compiler/instmap.m: Provide predicates for recording that a switched-on variable has one of several given cons_ids, for use at the starts of switch arms. Give some predicates better names. compiler/modes.m: Provide predicates for updating the mode_info at the start of a multi-cons_id switch arm. compiler/det_report.m: Handle multi-cons_id switch arms. Update the instmap when entering each switch arm, since this is needed to provide good (i.e. non-misleading) error messages when one switch on a variable exists inside another switch on the same variable. Since updating the instmap requires updating the module_info (since the new inst may require a new entry in an inst table), thread the det_info through as updateable state. Replace some multi-clause predicate definitions with single clauses, to make it easier to print the arguments in mdb. Fix some misleading variable names. compiler/det_analysis.m: Update the instmap when entering each switch arm and thread the det_info through as updateable state, since the predicates we call in det_report.m require this. compiler/det_util.m: Handle multi-cons_id switch arms. Rationalize the argument order of some access predicates. compiler/switch_util.m: Change the parts of this module that deal with string and tag switches to optionally convert each arm to an arbitrary representation of the arm. In the LLDS backend, the conversion process generated code for the arm, and the arm's representation is the label at the start of this code. This way, we can duplicate the label without duplicating the code. Add a new part of this module that associates each cons_id with its tag, and (during the same pass) checks whether all the cons_ids are integers, and if so what are min and max of these integers (needed for dense switches). This scan is needed because the old way of making this test had single-cons_id switch arms as one of its basic assumptions, and doing it while adding tags to each case reduces the number of traversals required. Give better names to some predicates. compiler/switch_case.m: New module to handle the tasks associated with managing multi-cons_id switch arms, including representing them for switch_util.m. compiler/ll_backend.m: Include the new module. compiler/notes/compiler_design.html: Note the new module. compiler/llds.m: Change the computed goto instruction to take a list of maybe labels instead of a list of labels, with any missing labels meaning "not reached". compiler/string_switch.m: compiler/tag_switch.m: Reorganize the way these modules work. We can't generate the code of each arm in place anymore, since it is now possible for more than one cons_id to call for the execution of the same code. Instead, in string_switch.m, we generate the codes of all the arms all at once, and construct the hash index afterwards. (This approach simplifies the code significantly.) In tag switches (unlike string switches), we can get locality benefits if the code testing for a cons_id is close to the code for that cons_id, so we still try to put them next to each other when such a locality benefit is available. In both modules, the new approach uses a utility predicate in switch_case.m to actually generate the code of each switch arm, eliminating several copies the same code in the old versions of these modules. In tag_switch.m, don't create a local label that simply jumps to the code address do_not_reached. Previously, we had to do this for positions in jump tables that corresponded to cons_ids that the switch variable could not be bound to. With the change to llds.m, we now simply generate a "no" instead. compiler/lookup_switch.m: Get the info about int switch limits from our caller; don't compute it here. Give some variables better names. compiler/dense_switch.m: Generate the codes of the cases all at once, then assemble the table, duplicate the labels as needed. This separation of concerns allows significant simplifications. Pack up all the information shared between the predicate that detects whether a dense switch is appropriate and the predicate that actually generates the dense switch. Move some utility predicates to switch_util. compiler/switch_gen.m: Delete the code for tagging cons_ids, since that functionality is now in switch_util.m. The old version of this module could call the code generator to produce (i.e. materialize) the switched-on variable repeatedly. We now produce the variable once, and do the switch on the resulting rval. compiler/unify_gen.m: Use the information about cheaper tag tests in the type constructor's entry in the HLDS type table, instead of trying to recompute it every time. Provide the predicates switch_gen.m now needs to perform tag tests on rvals, as opposed to variables, and against possible more than one cons_id. Allow the caller to provide the tag corresponding to the cons_id(s) in tag tests, since when we are generating code for switches, the required computations have already been done. Factor out some code to make all this possible. Give better names to some predicates. compiler/code_info.m: Provide some utility predicates for the new code in other modules. Give better names to some existing predicates. compiler/hlds_code_util.m: Rationalize the argument order of some predicates. Replace some multi-clause predicate definitions with single clauses, to make it easier to print the arguments in mdb. compiler/accumulator.m: compiler/add_heap_ops.m: compiler/add_pragma.m: compiler/add_trail_ops.m: compiler/assertion.m: compiler/build_mode_constraints.m: compiler/check_typeclass.m: compiler/closure_analysis.m: compiler/code_util.m: compiler/constraint.m: compiler/cse_detection.m: compiler/dead_proc_elim.m: compiler/deep_profiling.m: compiler/deforest.m: compiler/delay_construct.m: compiler/delay_partial_inst.m: compiler/dep_par_conj.m: compiler/distance_granularity.m: compiler/dupproc.m: compiler/equiv_type_hlds.m: compiler/erl_code_gen.m: compiler/exception_analysis.m: compiler/export.m: compiler/follow_code.m: compiler/follow_vars.m: compiler/foreign.m: compiler/format_call.m: compiler/frameopt.m: compiler/goal_form.m: compiler/goal_path.m: compiler/goal_util.m: compiler/granularity.m: compiler/hhf.m: compiler/higher_order.m: compiler/implicit_parallelism.m: compiler/inlining.m: compiler/inst_check.m: compiler/intermod.m: compiler/interval.m: compiler/lambda.m: compiler/lambda.m: compiler/lambda.m: compiler/lco.m: compiler/live_vars.m: compiler/livemap.m: compiler/liveness.m: compiler/llds_out.m: compiler/llds_to_x86_64.m: compiler/loop_inv.m: compiler/make_hlds_warn.m: compiler/mark_static_terms.m: compiler/middle_rec.m: compiler/ml_tag_switch.m: compiler/ml_type_gen.m: compiler/ml_unify_gen.m: compiler/mode_constraints.m: compiler/mode_errors.m: compiler/mode_util.m: compiler/opt_debug.m: compiler/opt_util.m: compiler/pd_cost.m: compiler/pd_into.m: compiler/pd_util.m: compiler/peephole.m: compiler/polymorphism.m: compiler/post_term_analysis.m: compiler/post_typecheck.m: compiler/purity.m: compiler/quantification.m: compiler/rbmm.actual_region_arguments.m: compiler/rbmm.add_rbmm_goal_infos.m: compiler/rbmm.condition_renaming.m: compiler/rbmm.execution_paths.m: compiler/rbmm.points_to_analysis.m: compiler/rbmm.region_transformation.m: compiler/recompilation.usage.m: compiler/saved_vars.m: compiler/simplify.m: compiler/size_prof.m: compiler/ssdebug.m: compiler/store_alloc.m: compiler/stratify.m: compiler/structure_reuse.direct.choose_reuse.m: compiler/structure_reuse.indirect.m: compiler/structure_reuse.lbu.m: compiler/structure_reuse.lfu.m: compiler/structure_reuse.versions.m: compiler/structure_sharing.analysis.m: compiler/table_gen.m: compiler/tabling_analysis.m: compiler/term_constr_build.m: compiler/term_norm.m: compiler/term_pass1.m: compiler/term_traversal.m: compiler/trailing_analysis.m: compiler/transform_llds.m: compiler/tupling.m: compiler/type_ctor_info.m: compiler/type_util.m: compiler/unify_proc.m: compiler/unique_modes.m: compiler/unneeded_code.m: compiler/untupling.m: compiler/unused_args.m: compiler/unused_imports.m: compiler/xml_documentation.m: Make the changes necessary to conform to the changes above, principally to handle multi-cons_id arm switches. compiler/ml_string_switch.m: Make the changes necessary to conform to the changes above, principally to handle multi-cons_id arm switches. Give some predicates better names. compiler/dependency_graph.m: Make the changes necessary to conform to the changes above, principally to handle multi-cons_id arm switches. Change the order of arguments of some predicates to make this easier. compiler/bytecode.m: compiler/bytecode_data.m: compiler/bytecode_gen.m: Make the changes necessary to conform to the changes above, principally to handle multi-cons_id arm switches. (The bytecode interpreter has not been updated.) compiler/prog_rep.m: mdbcomp/program_representation.m: Change the byte sequence representation of goals to allow switch arms with more than one cons_id. compiler/prog_rep.m now writes out the updated representation, while mdbcomp/program_representation.m reads in the updated representation. deep_profiler/mdbprof_procrep.m: Conform to the updated program representation. tools/binary: Fix a bug: if the -D option was given, the stage 2 directory wasn't being initialized. Abort if users try to give that option more than once. compiler/Mercury.options: Work around bug #32 in Mantis. --- compiler/Mercury.options | 3 + compiler/accumulator.m | 14 +- compiler/add_heap_ops.m | 4 +- compiler/add_pragma.m | 26 +- compiler/add_trail_ops.m | 13 +- compiler/add_type.m | 38 +- compiler/assertion.m | 10 +- compiler/build_mode_constraints.m | 2 +- compiler/bytecode.m | 21 +- compiler/bytecode_data.m | 13 +- compiler/bytecode_gen.m | 18 +- compiler/check_typeclass.m | 4 +- compiler/closure_analysis.m | 6 +- compiler/code_info.m | 47 +- compiler/code_util.m | 2 +- compiler/complexity.m | 4 +- compiler/constraint.m | 22 +- compiler/cse_detection.m | 14 +- compiler/dead_proc_elim.m | 4 +- compiler/deep_profiling.m | 80 +- compiler/deforest.m | 17 +- compiler/delay_construct.m | 6 +- compiler/delay_partial_inst.m | 5 +- compiler/dense_switch.m | 303 ++++--- compiler/dep_par_conj.m | 23 +- compiler/dependency_graph.m | 104 +-- compiler/det_analysis.m | 337 +++---- compiler/det_report.m | 517 ++++++----- compiler/det_util.m | 56 +- compiler/distance_granularity.m | 8 +- compiler/dupproc.m | 22 +- compiler/equiv_type_hlds.m | 24 +- compiler/erl_code_gen.m | 45 +- compiler/exception_analysis.m | 2 +- compiler/export.m | 5 +- compiler/follow_code.m | 8 +- compiler/follow_vars.m | 9 +- compiler/foreign.m | 2 +- compiler/format_call.m | 2 +- compiler/frameopt.m | 2 +- compiler/goal_form.m | 16 +- compiler/goal_path.m | 4 +- compiler/goal_util.m | 46 +- compiler/granularity.m | 4 +- compiler/handle_options.m | 4 + compiler/hhf.m | 10 +- compiler/higher_order.m | 4 +- compiler/hlds_code_util.m | 125 +-- compiler/hlds_data.m | 37 + compiler/hlds_goal.m | 87 +- compiler/hlds_out.m | 206 +++-- compiler/implicit_parallelism.m | 5 +- compiler/inlining.m | 7 +- compiler/inst_check.m | 2 +- compiler/inst_match.m | 12 +- compiler/inst_util.m | 2 +- compiler/instmap.m | 186 ++-- compiler/intermod.m | 20 +- compiler/interval.m | 10 +- compiler/jumpopt.m | 27 +- compiler/lambda.m | 5 +- compiler/lco.m | 15 +- compiler/live_vars.m | 9 +- compiler/livemap.m | 15 +- compiler/liveness.m | 43 +- compiler/ll_backend.m | 1 + compiler/llds.m | 5 +- compiler/llds_out.m | 41 +- compiler/llds_to_x86_64.m | 19 +- compiler/lookup_switch.m | 113 +-- compiler/loop_inv.m | 10 +- compiler/make_hlds_warn.m | 2 +- compiler/mark_static_terms.m | 4 +- compiler/middle_rec.m | 18 +- compiler/ml_string_switch.m | 70 +- compiler/ml_switch_gen.m | 118 +-- compiler/ml_tag_switch.m | 43 +- compiler/ml_type_gen.m | 62 +- compiler/ml_unify_gen.m | 4 +- compiler/mode_constraints.m | 4 +- compiler/mode_errors.m | 2 +- compiler/mode_util.m | 12 +- compiler/modecheck_unify.m | 2 +- compiler/modes.m | 70 +- compiler/notes/compiler_design.html | 3 +- compiler/opt_debug.m | 17 +- compiler/opt_util.m | 47 +- compiler/options.m | 12 +- compiler/pd_cost.m | 2 +- compiler/pd_info.m | 10 +- compiler/pd_util.m | 26 +- compiler/peephole.m | 9 +- compiler/polymorphism.m | 4 +- compiler/post_term_analysis.m | 2 +- compiler/post_typecheck.m | 2 +- compiler/prog_rep.m | 426 ++++----- compiler/purity.m | 6 +- compiler/quantification.m | 10 +- compiler/rbmm.actual_region_arguments.m | 2 +- compiler/rbmm.add_rbmm_goal_infos.m | 10 +- compiler/rbmm.condition_renaming.m | 10 +- compiler/rbmm.execution_path.m | 36 +- compiler/rbmm.points_to_analysis.m | 4 +- compiler/rbmm.region_transformation.m | 13 +- compiler/recompilation.usage.m | 3 +- compiler/saved_vars.m | 11 +- compiler/simplify.m | 49 +- compiler/size_prof.m | 4 +- compiler/ssdebug.m | 4 +- compiler/store_alloc.m | 7 +- compiler/stratify.m | 8 +- compiler/string_switch.m | 219 +++-- .../structure_reuse.direct.choose_reuse.m | 10 +- compiler/structure_reuse.indirect.m | 4 +- compiler/structure_reuse.lbu.m | 4 +- compiler/structure_reuse.lfu.m | 4 +- compiler/structure_reuse.versions.m | 4 +- compiler/structure_sharing.analysis.m | 2 +- compiler/switch_case.m | 141 +++ compiler/switch_detection.m | 790 +++++++++++------ compiler/switch_gen.m | 332 ++++--- compiler/switch_util.m | 597 +++++++++---- compiler/table_gen.m | 48 +- compiler/tabling_analysis.m | 6 +- compiler/tag_switch.m | 838 ++++++++---------- compiler/term_constr_build.m | 367 ++++---- compiler/term_norm.m | 2 +- compiler/term_pass1.m | 2 +- compiler/term_traversal.m | 2 +- compiler/trailing_analysis.m | 6 +- compiler/transform_llds.m | 33 +- compiler/tupling.m | 6 +- compiler/type_ctor_info.m | 7 +- compiler/type_util.m | 22 +- compiler/unify_gen.m | 178 ++-- compiler/unify_proc.m | 12 +- compiler/unique_modes.m | 10 +- compiler/unneeded_code.m | 17 +- compiler/untupling.m | 4 +- compiler/unused_args.m | 7 +- compiler/unused_imports.m | 18 +- compiler/xml_documentation.m | 4 +- deep_profiler/mdprof_procrep.m | 14 +- mdbcomp/program_representation.m | 43 +- tools/binary | 25 +- 145 files changed, 4699 insertions(+), 3159 deletions(-) create mode 100644 compiler/switch_case.m diff --git a/compiler/Mercury.options b/compiler/Mercury.options index 836ae301c..87a8c01bf 100644 --- a/compiler/Mercury.options +++ b/compiler/Mercury.options @@ -51,6 +51,9 @@ MCFLAGS-transform_hlds.smm_fixpoint_table = --no-warn-nothing-exported # Bug workarounds +# This works around bug 32 in Mantis. +MCFLAGS-check_hlds.check_typeclass = --no-loop-invariants + # This is the same bug as tests/valid/ho_and_type_spec_bug2. MCFLAGS-mode_robdd.tfeirn = -O3 MCFLAGS-mode_robdd.implications = -O0 diff --git a/compiler/accumulator.m b/compiler/accumulator.m index 2c6f84390..995295e84 100644 --- a/compiler/accumulator.m +++ b/compiler/accumulator.m @@ -450,7 +450,7 @@ identify_goal_type(PredId, ProcId, Goal, InitialInstMap, Goal = hlds_goal(GoalExpr, _GoalInfo), ( GoalExpr = switch(_Var, _CanFail, Cases), - Cases = [case(_IdA, GoalA), case(_IdB, GoalB)], + Cases = [case(_IdA, [], GoalA), case(_IdB, [], GoalB)], goal_to_conj_list(GoalA, GoalAList), goal_to_conj_list(GoalB, GoalBList) -> @@ -1686,12 +1686,12 @@ top_level(switch_base_rec, Goal, OrigBaseGoal, OrigRecGoal, NewBaseGoal, NewRecGoal, OrigGoal, NewGoal) :- ( Goal = hlds_goal(switch(Var, CanFail, Cases0), GoalInfo), - Cases0 = [case(IdA, _), case(IdB, _)] + Cases0 = [case(IdA, [], _), case(IdB, [], _)] -> - OrigCases = [case(IdA, OrigBaseGoal), case(IdB, OrigRecGoal)], + OrigCases = [case(IdA, [], OrigBaseGoal), case(IdB, [], OrigRecGoal)], OrigGoal = hlds_goal(switch(Var, CanFail, OrigCases), GoalInfo), - NewCases = [case(IdA, NewBaseGoal), case(IdB, NewRecGoal)], + NewCases = [case(IdA, [], NewBaseGoal), case(IdB, [], NewRecGoal)], NewGoal = hlds_goal(switch(Var, CanFail, NewCases), GoalInfo) ; unexpected(this_file, "top_level: not the correct top level") @@ -1700,12 +1700,12 @@ top_level(switch_rec_base, Goal, OrigBaseGoal, OrigRecGoal, NewBaseGoal, NewRecGoal, OrigGoal, NewGoal) :- ( Goal = hlds_goal(switch(Var, CanFail, Cases0), GoalInfo), - Cases0 = [case(IdA, _), case(IdB, _)] + Cases0 = [case(IdA, [], _), case(IdB, [], _)] -> - OrigCases = [case(IdA, OrigRecGoal), case(IdB, OrigBaseGoal)], + OrigCases = [case(IdA, [], OrigRecGoal), case(IdB, [], OrigBaseGoal)], OrigGoal = hlds_goal(switch(Var, CanFail, OrigCases), GoalInfo), - NewCases = [case(IdA, NewRecGoal), case(IdB, NewBaseGoal)], + NewCases = [case(IdA, [], NewRecGoal), case(IdB, [], NewBaseGoal)], NewGoal = hlds_goal(switch(Var, CanFail, NewCases), GoalInfo) ; unexpected(this_file, "top_level: not the correct top level") diff --git a/compiler/add_heap_ops.m b/compiler/add_heap_ops.m index ddf705771..bfae72e6c 100644 --- a/compiler/add_heap_ops.m +++ b/compiler/add_heap_ops.m @@ -301,9 +301,9 @@ disj_add_heap_ops([Goal0 | Goals0], IsFirstBranch, MaybeSavedHeapPointerVar, cases_add_heap_ops([], [], !Info). cases_add_heap_ops([Case0 | Cases0], [Case | Cases], !Info) :- - Case0 = case(ConsId, Goal0), - Case = case(ConsId, Goal), + Case0 = case(MainConsId, OtherConsIds, Goal0), goal_add_heap_ops(Goal0, Goal, !Info), + Case = case(MainConsId, OtherConsIds, Goal), cases_add_heap_ops(Cases0, Cases, !Info). %-----------------------------------------------------------------------------% diff --git a/compiler/add_pragma.m b/compiler/add_pragma.m index aec4c5653..32ab054b1 100644 --- a/compiler/add_pragma.m +++ b/compiler/add_pragma.m @@ -548,12 +548,13 @@ add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo, ] ; ( - TypeBody0 = hlds_du_type(Body, _CtorTags0, _IsEnum0, - MaybeUserEqComp, ReservedTag0, _ReservedAddr, IsForeign), + TypeBody0 = hlds_du_type(Body, _CtorTags0, _CheaperTagTest, + _IsEnum0, MaybeUserEqComp, ReservedTag0, _ReservedAddr, + IsForeign), ( ReservedTag0 = uses_reserved_tag, % Make doubly sure that we don't get any spurious warnings - % with intermodule optimization... + % with intermodule optimization ... TypeStatus \= status_opt_imported -> MaybeSeverity = yes(severity_warning), @@ -573,8 +574,9 @@ add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo, module_info_get_globals(!.ModuleInfo, Globals), assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor, ReservedTag, Globals, CtorTags, ReservedAddr, EnumDummy), - TypeBody = hlds_du_type(Body, CtorTags, EnumDummy, - MaybeUserEqComp, ReservedTag, ReservedAddr, IsForeign), + TypeBody = hlds_du_type(Body, CtorTags, no_cheaper_tag_test, + EnumDummy, MaybeUserEqComp, ReservedTag, ReservedAddr, + IsForeign), hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn), map.set(Types0, TypeCtor, TypeDefn, Types), module_info_set_type_table(Types, !ModuleInfo) @@ -659,8 +661,9 @@ add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes, ] ; % XXX How should we handle IsForeignType here? - TypeBody = hlds_du_type(Ctors, _TagValues, IsEnumOrDummy, - _MaybeUserEq, _ReservedTag, _ReservedAddr, _IsForeignType), + TypeBody = hlds_du_type(Ctors, _TagValues, _CheaperTagTest, + IsEnumOrDummy, _MaybeUserEq, _ReservedTag, _ReservedAddr, + _IsForeignType), ( ( IsEnumOrDummy = is_mercury_enum ; IsEnumOrDummy = is_foreign_enum(_) @@ -1006,8 +1009,9 @@ add_pragma_foreign_enum(Lang, TypeName, TypeArity, ForeignTagValues, suffix(".") ] ; - TypeBody0 = hlds_du_type(Ctors, OldTagValues, IsEnumOrDummy0, - MaybeUserEq, ReservedTag, ReservedAddr, IsForeignType), + TypeBody0 = hlds_du_type(Ctors, OldTagValues, CheaperTagTest, + IsEnumOrDummy0, MaybeUserEq, ReservedTag, ReservedAddr, + IsForeignType), % % Work out what language's foreign_enum pragma we should be % looking at for the the current compilation target language. @@ -1052,8 +1056,8 @@ add_pragma_foreign_enum(Lang, TypeName, TypeArity, ForeignTagValues, ( UnmappedCtors = [], TypeBody = hlds_du_type(Ctors, TagValues, - IsEnumOrDummy, MaybeUserEq, ReservedTag, - ReservedAddr, IsForeignType), + CheaperTagTest, IsEnumOrDummy, MaybeUserEq, + ReservedTag, ReservedAddr, IsForeignType), set_type_defn_body(TypeBody, TypeDefn0, TypeDefn), svmap.set(TypeCtor, TypeDefn, TypeTable0, TypeTable), diff --git a/compiler/add_trail_ops.m b/compiler/add_trail_ops.m index 338d07fd2..0609193f4 100644 --- a/compiler/add_trail_ops.m +++ b/compiler/add_trail_ops.m @@ -388,11 +388,10 @@ disj_add_trail_ops([Goal0 | Goals0], IsFirstBranch, CodeModel, TicketVar, ) ), goal_add_trail_ops(Goal0, Goal1, !Info), - % + % For model_semi and model_det disjunctions, once we reach the end of % the disjunct goal, we're committing to this disjunct, so we need to % prune the trail ticket. - % ( CodeModel = model_non, PruneList = [] @@ -405,14 +404,12 @@ disj_add_trail_ops([Goal0 | Goals0], IsFirstBranch, CodeModel, TicketVar, gen_prune_ticket(Context, PruneTicketGoal, !.Info), PruneList = [ResetTicketCommitGoal, PruneTicketGoal] ), - % + % Package up the stuff we built earlier. - % Goal1 = hlds_goal(_, GoalInfo1), conj_list_to_goal(UndoList ++ [Goal1] ++ PruneList, GoalInfo1, Goal), - % + % Recursively handle the remaining disjuncts. - % disj_add_trail_ops(Goals0, no, CodeModel, TicketVar, Goals, !Info). :- pred cases_add_trail_ops(list(case)::in, list(case)::out, @@ -420,9 +417,9 @@ disj_add_trail_ops([Goal0 | Goals0], IsFirstBranch, CodeModel, TicketVar, cases_add_trail_ops([], [], !Info). cases_add_trail_ops([Case0 | Cases0], [Case | Cases], !Info) :- - Case0 = case(ConsId, Goal0), - Case = case(ConsId, Goal), + Case0 = case(MainConsId, OtherConsIds, Goal0), goal_add_trail_ops(Goal0, Goal, !Info), + Case = case(MainConsId, OtherConsIds, Goal), cases_add_trail_ops(Cases0, Cases, !Info). %-----------------------------------------------------------------------------% diff --git a/compiler/add_type.m b/compiler/add_type.m index fbc0503e4..79093d720 100644 --- a/compiler/add_type.m +++ b/compiler/add_type.m @@ -72,6 +72,7 @@ :- import_module int. :- import_module map. :- import_module multi_map. +:- import_module pair. :- import_module string. :- import_module svmap. :- import_module svmulti_map. @@ -90,7 +91,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 need to treat it as abstract. The constructors @@ -365,7 +366,7 @@ 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, ReservedTag, _, _), module_info_get_cons_table(!.ModuleInfo, Ctors0), module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo), module_info_get_ctor_field_table(!.ModuleInfo, CtorFields0), @@ -495,7 +496,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), @@ -613,10 +614,35 @@ convert_type_defn(parse_tree_du_type(Body, MaybeUserEqComp), TypeCtor, Globals, % with ReservedTagPragma = uses_reserved_tag, when processing the pragma.) ReservedTagPragma = does_not_use_reserved_tag, assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor, ReservedTagPragma, - Globals, CtorTags, ReservedAddr, IsEnum), + Globals, CtorTagMap, ReservedAddr, IsEnum), IsForeign = no, - HLDSBody = hlds_du_type(Body, CtorTags, IsEnum, MaybeUserEqComp, - ReservedTagPragma, ReservedAddr, IsForeign). + ( + 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 + ) + ; + CheaperTagTest = no_cheaper_tag_test + ), + HLDSBody = hlds_du_type(Body, CtorTagMap, CheaperTagTest, IsEnum, + MaybeUserEqComp, 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/assertion.m b/compiler/assertion.m index c1c780b67..75009de66 100644 --- a/compiler/assertion.m +++ b/compiler/assertion.m @@ -619,8 +619,10 @@ equal_goals_list([GoalA | GoalAs], [GoalB | GoalBs], !Subst) :- equal_goals_cases([], [], !Subst). equal_goals_cases([CaseA | CaseAs], [CaseB | CaseBs], !Subst) :- - CaseA = case(ConsId, GoalA), - CaseB = case(ConsId, GoalB), + CaseA = case(MainConsIdA, OtherConsIdsA, GoalA), + CaseB = case(MainConsIdB, OtherConsIdsB, GoalB), + list.sort([MainConsIdA | OtherConsIdsA], SortedConsIds), + list.sort([MainConsIdB | OtherConsIdsB], SortedConsIds), equal_goals(GoalA, GoalB, !Subst), equal_goals_cases(CaseAs, CaseBs, !Subst). @@ -733,9 +735,9 @@ normalise_conj([Goal0 | Goals0], Goals) :- normalise_cases([], []). normalise_cases([Case0 | Cases0], [Case | Cases]) :- - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), normalise_goal(Goal0, Goal), - Case = case(ConsId, Goal), + Case = case(MainConsId, OtherConsIds, Goal), normalise_cases(Cases0, Cases). :- pred normalise_goals(hlds_goals::in, hlds_goals::out) is det. diff --git a/compiler/build_mode_constraints.m b/compiler/build_mode_constraints.m index 840235969..c3a63266f 100644 --- a/compiler/build_mode_constraints.m +++ b/compiler/build_mode_constraints.m @@ -314,7 +314,7 @@ add_mc_vars_for_goal(PredId, ProgVarset, hlds_goal(GoalExpr, GoalInfo), GoalExpr = generic_call(_, _, _, _) ; GoalExpr = switch(_, _, Cases), - Goals = list.map(func(case(_, Goal)) = Goal, Cases), + Goals = list.map(func(case(_, _, Goal)) = Goal, Cases), list.foldl(add_mc_vars_for_goal(PredId, ProgVarset), Goals, !VarInfo) ; GoalExpr = unify(_, _, _, _, _) diff --git a/compiler/bytecode.m b/compiler/bytecode.m index 8c044a78c..b9301e053 100644 --- a/compiler/bytecode.m +++ b/compiler/bytecode.m @@ -49,7 +49,8 @@ ; byte_endof_disjunct(byte_label_id) ; byte_enter_switch(byte_var, byte_label_id) ; byte_endof_switch - ; byte_enter_switch_arm(byte_cons_id, byte_label_id) + ; byte_enter_switch_arm(byte_cons_id, list(byte_cons_id), + byte_label_id) ; byte_endof_switch_arm(byte_label_id) ; byte_enter_if(byte_label_id, byte_label_id, byte_temp) ; byte_enter_then(byte_temp) @@ -258,8 +259,12 @@ output_args(byte_enter_switch(Var, LabelId), !IO) :- output_var(Var, !IO), output_label_id(LabelId, !IO). output_args(byte_endof_switch, !IO). -output_args(byte_enter_switch_arm(ConsId, NextLabelId), !IO) :- - output_cons_id(ConsId, !IO), +output_args(byte_enter_switch_arm(MainConsId, OtherConsIds, NextLabelId), + !IO) :- + output_cons_id(MainConsId, !IO), + % The interpreter doesn't yet implement switch arms with more than one + % function symbol. + expect(unify(OtherConsIds, []), this_file, "output_args: OtherConsIds"), output_label_id(NextLabelId, !IO). output_args(byte_endof_switch_arm(LabelId), !IO) :- output_label_id(LabelId, !IO). @@ -388,8 +393,10 @@ debug_args(byte_enter_switch(Var, LabelId), !IO) :- debug_var(Var, !IO), debug_label_id(LabelId, !IO). debug_args(byte_endof_switch, !IO). -debug_args(byte_enter_switch_arm(ConsId, NextLabelId), !IO) :- - debug_cons_id(ConsId, !IO), +debug_args(byte_enter_switch_arm(MainConsId, OtherConsIds, + NextLabelId), !IO) :- + debug_cons_id(MainConsId, !IO), + list.foldl(debug_cons_id, OtherConsIds, !IO), debug_label_id(NextLabelId, !IO). debug_args(byte_endof_switch_arm(LabelId), !IO) :- debug_label_id(LabelId, !IO). @@ -922,7 +929,7 @@ byte_code(byte_enter_disjunct(_), 7). byte_code(byte_endof_disjunct(_), 8). byte_code(byte_enter_switch(_, _), 9). byte_code(byte_endof_switch, 10). -byte_code(byte_enter_switch_arm(_, _), 11). +byte_code(byte_enter_switch_arm(_, _, _), 11). byte_code(byte_endof_switch_arm(_), 12). byte_code(byte_enter_if(_, _, _), 13). byte_code(byte_enter_then(_), 14). @@ -967,7 +974,7 @@ byte_debug(byte_enter_disjunct(_), "enter_disjunct"). byte_debug(byte_endof_disjunct(_), "endof_disjunct"). byte_debug(byte_enter_switch(_, _), "enter_switch"). byte_debug(byte_endof_switch, "endof_switch"). -byte_debug(byte_enter_switch_arm(_, _), "enter_switch_arm"). +byte_debug(byte_enter_switch_arm(_, _, _), "enter_switch_arm"). byte_debug(byte_endof_switch_arm(_), "endof_switch_arm"). byte_debug(byte_enter_if(_, _, _), "enter_if"). byte_debug(byte_enter_then(_), "enter_then"). diff --git a/compiler/bytecode_data.m b/compiler/bytecode_data.m index 7ba95e91b..43cd856a3 100644 --- a/compiler/bytecode_data.m +++ b/compiler/bytecode_data.m @@ -22,7 +22,7 @@ %---------------------------------------------------------------------------% - % XXX this assumes strings contain 8-bit characters + % XXX This assumes strings contain 8-bit characters. :- pred output_string(string::in, io::di, io::uo) is det. :- pred string_to_byte_list(string::in, list(int)::out) is det. @@ -77,12 +77,11 @@ output_string(Val, !IO) :- io.write_byte(0, !IO). string_to_byte_list(Val, List) :- - % XXX this assumes strings contain 8-bit characters - % Using char.to_int here is wrong; the output will depend - % on the Mercury implementation's representation of chars, - % so it may be different for different Mercury implementations. - % In particular, it will do the wrong thing for Mercury - % implementations which represent characters in Unicode. + % XXX This assumes strings contain 8-bit characters. + % Using char.to_int here is wrong; the output will depend on the Mercury + % implementation's representation of chars, so it may be different for + % different Mercury implementations. In particular, it will do the wrong + % thing for Mercury implementations which represent characters in Unicode. string.to_char_list(Val, Chars), ToInt = (pred(C::in, I::out) is det :- char.to_int(C, I)), list.map(ToInt, Chars, List0), diff --git a/compiler/bytecode_gen.m b/compiler/bytecode_gen.m index f4deff560..7609a7ef1 100644 --- a/compiler/bytecode_gen.m +++ b/compiler/bytecode_gen.m @@ -694,15 +694,17 @@ gen_disj([Disjunct | Disjuncts], EndLabel, !ByteInfo, Code) :- byte_info::in, byte_info::out, byte_tree::out) is det. gen_switch([], _, _, !ByteInfo, empty). -gen_switch([case(ConsId, Goal) | Cases], Var, EndLabel, - !ByteInfo, Code) :- - map_cons_id(!.ByteInfo, Var, ConsId, ByteConsId), - gen_goal(Goal, !ByteInfo, ThisCode), - gen_switch(Cases, Var, EndLabel, !ByteInfo, OtherCode), +gen_switch([Case | Cases], Var, EndLabel, !ByteInfo, Code) :- + Case = case(MainConsId, OtherConsIds, Goal), + map_cons_id(!.ByteInfo, Var, MainConsId, ByteMainConsId), + list.map(map_cons_id(!.ByteInfo, Var), OtherConsIds, ByteOtherConsIds), + gen_goal(Goal, !ByteInfo, GoalCode), + gen_switch(Cases, Var, EndLabel, !ByteInfo, CasesCode), get_next_label(NextLabel, !ByteInfo), - EnterCode = node([byte_enter_switch_arm(ByteConsId, NextLabel)]), + EnterCode = node([ + byte_enter_switch_arm(ByteMainConsId, ByteOtherConsIds, NextLabel)]), EndofCode = node([byte_endof_switch_arm(EndLabel), byte_label(NextLabel)]), - Code = tree_list([EnterCode, ThisCode, EndofCode, OtherCode]). + Code = tree_list([EnterCode, GoalCode, EndofCode, CasesCode]). %---------------------------------------------------------------------------% @@ -734,7 +736,7 @@ map_cons_id(ByteInfo, Var, ConsId, ByteConsId) :- ; Functor = qualified(ModuleName, FunctorName) ), - ConsTag = cons_id_to_tag(ConsId, Type, ModuleInfo), + ConsTag = cons_id_to_tag(ModuleInfo, Type, ConsId), map_cons_tag(ConsTag, ByteConsTag), ByteConsId = byte_cons(ModuleName, FunctorName, Arity, ByteConsTag) ) diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m index bc5187bd3..13b2b1864 100644 --- a/compiler/check_typeclass.m +++ b/compiler/check_typeclass.m @@ -1338,7 +1338,7 @@ is_valid_instance_type(MI, ClassId, InstanceDefn, is_valid_instance_type(MI, 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(_) @@ -1577,7 +1577,7 @@ check_ctor_constraints(TypeTable, TypeCtor, !ModuleInfo, !Specs) :- map.lookup(TypeTable, TypeCtor, TypeDefn), 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/closure_analysis.m b/compiler/closure_analysis.m index 1b1ff146a..081dfe6ae 100644 --- a/compiler/closure_analysis.m +++ b/compiler/closure_analysis.m @@ -268,10 +268,10 @@ process_goal(VarTypes, ModuleInfo, Goal0, Goal, !ClosureInfo) :- process_goal(VarTypes, ModuleInfo, Goal0, Goal, !ClosureInfo) :- Goal0 = hlds_goal(switch(SwitchVar, SwitchCanFail, Cases0), GoalInfo), ProcessCase = (func(Case0) = Case - CaseInfo :- - Case0 = case(ConsId, CaseGoal0), + Case0 = case(MainConsId, OtherConsIds, CaseGoal0), process_goal(VarTypes, ModuleInfo, CaseGoal0, CaseGoal, !.ClosureInfo, CaseInfo), - Case = case(ConsId, CaseGoal) + Case = case(MainConsId, OtherConsIds, CaseGoal) ), CasesAndInfos = list.map(ProcessCase, Cases0), assoc_list.keys_and_values(CasesAndInfos, Cases, CasesInfo), @@ -442,7 +442,7 @@ dump_closure_info_expr(Varset, generic_call(_,_,_,_), GoalInfo, !IO) :- dump_closure_info_expr(Varset, scope(_, Goal), _, !IO) :- dump_closure_info(Varset, Goal, !IO). dump_closure_info_expr(Varset, switch(_, _, Cases), _, !IO) :- - CaseToGoal = (func(case(_, Goal)) = Goal), + CaseToGoal = (func(case(_, _, Goal)) = Goal), Goals = list.map(CaseToGoal, Cases), list.foldl(dump_closure_info(Varset), Goals, !IO). dump_closure_info_expr(Varset, if_then_else(_, Cond, Then, Else), _, !IO) :- diff --git a/compiler/code_info.m b/compiler/code_info.m index 07905c7ae..5071eddb7 100644 --- a/compiler/code_info.m +++ b/compiler/code_info.m @@ -745,11 +745,16 @@ set_used_env_vars(UEV, CI, CI ^ code_info_persistent ^ used_env_vars := UEV). % :- func lookup_type_defn(code_info, mer_type) = hlds_type_defn. +:- func lookup_cheaper_tag_test(code_info, mer_type) = maybe_cheaper_tag_test. + :- func filter_region_vars(code_info, set(prog_var)) = set(prog_var). - % Given a constructor id, and a variable (so that we can work out the - % type of the constructor), determine correct tag (representation) - % of that constructor. + % Given a constructor id, and the type to which it belongs, determine + % the tag representing that constructor. + % +:- func cons_id_to_tag_for_type(code_info, mer_type, cons_id) = cons_tag. + + % As cons_id_to_tag_for_type, but get the type from the variable. % :- func cons_id_to_tag_for_var(code_info, prog_var, cons_id) = cons_tag. @@ -774,7 +779,7 @@ set_used_env_vars(UEV, CI, CI ^ code_info_persistent ^ used_env_vars := UEV). % :- func current_resume_point_vars(code_info) = set(prog_var). -:- func variable_to_string(code_info, prog_var) = string. +:- func variable_name(code_info, prog_var) = string. % Create a code address which holds the address of the specified % procedure. @@ -934,14 +939,28 @@ lookup_type_defn(CI, Type) = TypeDefn :- unexpected(this_file, "lookup_type_defn: type ctor has no definition") ). +lookup_cheaper_tag_test(CI, Type) = CheaperTagTest :- + ( + search_type_defn(CI, Type, TypeDefn), + get_type_defn_body(TypeDefn, TypeBody), + TypeBody = hlds_du_type(_, _, CheaperTagTestPrime, _, _, _, _, _) + -> + CheaperTagTest = CheaperTagTestPrime + ; + CheaperTagTest = no_cheaper_tag_test + ). + filter_region_vars(CI, ForwardLiveVarsBeforeGoal) = RegionVars :- VarTypes = code_info.get_var_types(CI), RegionVars = set.filter(is_region_var(VarTypes), ForwardLiveVarsBeforeGoal). -cons_id_to_tag_for_var(CI, Var, ConsId) = ConsTag :- +cons_id_to_tag_for_type(CI, Type, ConsId) = ConsTag :- get_module_info(CI, ModuleInfo), - ConsTag = cons_id_to_tag(ConsId, variable_type(CI, Var), ModuleInfo). + ConsTag = cons_id_to_tag(ModuleInfo, Type, ConsId). + +cons_id_to_tag_for_var(CI, Var, ConsId) = + cons_id_to_tag_for_type(CI, variable_type(CI, Var), ConsId). %---------------------------------------------------------------------------% @@ -974,7 +993,7 @@ current_resume_point_vars(CI) = ResumeVars :- map.keys(ResumeMap, ResumeMapVarList), set.list_to_set(ResumeMapVarList, ResumeVars). -variable_to_string(CI, Var) = Name :- +variable_name(CI, Var) = Name :- get_varset(CI, Varset), varset.lookup_name(Varset, Var, Name). @@ -1121,8 +1140,8 @@ add_vector_static_cell(Types, Vector, DataAddr, !CI) :- :- pred reset_resume_known(position_info::in, code_info::in, code_info::out) is det. -:- pred generate_branch_end(abs_store_map::in, branch_end::in, - branch_end::out, code_tree::out, code_info::in, code_info::out) is det. +:- pred generate_branch_end(abs_store_map::in, branch_end::in, branch_end::out, + code_tree::out, code_info::in, code_info::out) is det. :- pred after_all_branches(abs_store_map::in, branch_end::in, code_info::in, code_info::out) is det. @@ -1198,8 +1217,8 @@ generate_branch_end(StoreMap, MaybeEnd0, MaybeEnd, Code, !CI) :- ; MaybeEnd0 = yes(branch_end_info(EndCodeInfo0)), - % Make sure the left context we leave the branched structure - % with is valid for all branches. + % Make sure the left context we leave the branched structure with + % is valid for all branches. get_fail_info(EndCodeInfo0, FailInfo0), get_fail_info(EndCodeInfo1, FailInfo1), FailInfo0 = fail_info(_, ResumeKnown0, CurfrMaxfr0, CondEnv0, Hijack0), @@ -4420,11 +4439,11 @@ get_variable_slot(CI, Var, Slot) :- ( map.search(StackSlots, Var, SlotLocn) -> Slot = stack_slot_to_lval(SlotLocn) ; - Name = variable_to_string(CI, Var), + Name = variable_name(CI, Var), term.var_to_int(Var, Num), string.int_to_string(Num, NumStr), - string.append_list(["get_variable_slot: variable `", - Name, "' (", NumStr, ") not found"], Str), + Str = "get_variable_slot: variable `" ++ Name ++ "' " ++ + "(" ++ NumStr ++ ") not found", unexpected(this_file, Str) ). diff --git a/compiler/code_util.m b/compiler/code_util.m index 7faf41ab8..93c2dea47 100644 --- a/compiler/code_util.m +++ b/compiler/code_util.m @@ -282,7 +282,7 @@ goal_list_may_alloc_temp_frame([Goal | Goals], May) :- :- pred cases_may_alloc_temp_frame(list(case)::in, bool::out) is det. cases_may_alloc_temp_frame([], no). -cases_may_alloc_temp_frame([case(_, Goal) | Cases], May) :- +cases_may_alloc_temp_frame([case(_, _, Goal) | Cases], May) :- ( goal_may_alloc_temp_frame(Goal, yes) -> May = yes ; diff --git a/compiler/complexity.m b/compiler/complexity.m index 8874d6b38..bde10bd8a 100644 --- a/compiler/complexity.m +++ b/compiler/complexity.m @@ -359,8 +359,8 @@ process_proc(NumProcs, ProcNum, FullName, PredId, !ProcInfo, !ModuleInfo) :- TSPB = mercury_term_size_prof_builtin_module, SwitchArms = [ - case(cons(qualified(TSPB, "is_inactive"), 0), TransformedGoal), - case(cons(qualified(TSPB, "is_active"), 0), OrigGoal) + case(cons(qualified(TSPB, "is_inactive"), 0), [], TransformedGoal), + case(cons(qualified(TSPB, "is_active"), 0), [], OrigGoal) ], SwitchExpr = switch(IsActiveVar, cannot_fail, SwitchArms), diff --git a/compiler/constraint.m b/compiler/constraint.m index 7915f96fb..06ed17d2a 100644 --- a/compiler/constraint.m +++ b/compiler/constraint.m @@ -240,12 +240,14 @@ propagate_in_independent_goals([Goal0 | Goals0], Constraints, [Goal | Goals], constraint_info::in, constraint_info::out, io::di, io::uo) is det. propagate_cases(_, _, [], [], !Info, !IO). -propagate_cases(Var, Constraints, [case(ConsId, Goal0) | Cases0], - [case(ConsId, Goal) | Cases], !Info, !IO) :- +propagate_cases(Var, Constraints, [Case0 | Cases0], [Case | Cases], + !Info, !IO) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), InstMap0 = !.Info ^ instmap, - constraint_info_bind_var_to_functor(Var, ConsId, !Info), + constraint_info_bind_var_to_functors(Var, MainConsId, OtherConsIds, !Info), propagate_goal(Goal0, Constraints, Goal, !Info, !IO), !:Info = !.Info ^ instmap := InstMap0, + Case = case(MainConsId, OtherConsIds, Goal), propagate_cases(Var, Constraints, Cases0, Cases, !Info, !IO). %-----------------------------------------------------------------------------% @@ -751,16 +753,16 @@ constraint_info_update_goal(hlds_goal(_, GoalInfo), !Info) :- instmap.apply_instmap_delta(InstMap0, InstMapDelta, InstMap), !:Info = !.Info ^ instmap := InstMap. -:- pred constraint_info_bind_var_to_functor(prog_var::in, cons_id::in, - constraint_info::in, constraint_info::out) is det. +:- pred constraint_info_bind_var_to_functors(prog_var::in, cons_id::in, + list(cons_id)::in, constraint_info::in, constraint_info::out) is det. -constraint_info_bind_var_to_functor(Var, ConsId, !Info) :- +constraint_info_bind_var_to_functors(Var, MainConsId, OtherConsIds, !Info) :- InstMap0 = !.Info ^ instmap, ModuleInfo0 = !.Info ^ module_info, VarTypes = !.Info ^ vartypes, map.lookup(VarTypes, Var, Type), - instmap.bind_var_to_functor(Var, Type, ConsId, InstMap0, InstMap, - ModuleInfo0, ModuleInfo), + bind_var_to_functors(Var, Type, MainConsId, OtherConsIds, + InstMap0, InstMap, ModuleInfo0, ModuleInfo), !:Info = !.Info ^ instmap := InstMap, !:Info = !.Info ^ module_info := ModuleInfo. @@ -803,8 +805,8 @@ strip_constraint_markers_expr(disj(Goals)) = strip_constraint_markers_expr(switch(Var, CanFail, Cases0)) = switch(Var, CanFail, Cases) :- Cases = list.map( - (func(case(ConsId, Goal)) = - case(ConsId, strip_constraint_markers(Goal)) + (func(case(MainConsId, OtherConsIds, Goal)) = + case(MainConsId, OtherConsIds, strip_constraint_markers(Goal)) ), Cases0). strip_constraint_markers_expr(negation(Goal)) = negation(strip_constraint_markers(Goal)). diff --git a/compiler/cse_detection.m b/compiler/cse_detection.m index 6279559b5..e69c4383d 100644 --- a/compiler/cse_detection.m +++ b/compiler/cse_detection.m @@ -409,9 +409,9 @@ detect_cse_in_cases([Var | Vars], SwitchVar, CanFail, Cases0, GoalInfo, detect_cse_in_cases_2([], _, !CseInfo, no, []). detect_cse_in_cases_2([Case0 | Cases0], InstMap, !CseInfo, Redo, [Case | Cases]) :- - Case0 = case(Functor, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), detect_cse_in_goal(Goal0, InstMap, !CseInfo, Redo1, Goal), - Case = case(Functor, Goal), + Case = case(MainConsId, OtherConsIds, Goal), detect_cse_in_cases_2(Cases0, InstMap, !CseInfo, Redo2, Cases), bool.or(Redo1, Redo2, Redo). @@ -491,7 +491,7 @@ common_deconstruct_2([], _Var, !CseState, !CseInfo, []). common_deconstruct_2([Goal0 | Goals0], Var, !CseState, !CseInfo, [Goal | Goals]) :- find_bind_var(Var, find_bind_var_for_cse_in_deconstruct, Goal0, Goal, - !CseState, !CseInfo, yes), + !CseState, !CseInfo, did_find_deconstruct), !.CseState = have_candidate(_, _, _), common_deconstruct_2(Goals0, Var, !CseState, !CseInfo, Goals). @@ -512,10 +512,12 @@ common_deconstruct_cases(Cases0, Var, !CseInfo, Unify, list(case)::out) is semidet. common_deconstruct_cases_2([], _Var, !CseState, !CseInfo, []). -common_deconstruct_cases_2([case(ConsId, Goal0) | Cases0], Var, - !CseState, !CseInfo, [case(ConsId, Goal) | Cases]) :- +common_deconstruct_cases_2([Case0 | Cases0], Var, !CseState, !CseInfo, + [Case | Cases]) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), find_bind_var(Var, find_bind_var_for_cse_in_deconstruct, Goal0, Goal, - !CseState, !CseInfo, yes), + !CseState, !CseInfo, did_find_deconstruct), + Case = case(MainConsId, OtherConsIds, Goal), !.CseState = have_candidate(_, _, _), common_deconstruct_cases_2(Cases0, Var, !CseState, !CseInfo, Cases). diff --git a/compiler/dead_proc_elim.m b/compiler/dead_proc_elim.m index 98f73bcf2..751848d35 100644 --- a/compiler/dead_proc_elim.m +++ b/compiler/dead_proc_elim.m @@ -457,7 +457,7 @@ dead_proc_examine_goals([Goal | Goals], CurrProc, !Queue, !Needed) :- is det. dead_proc_examine_cases([], _CurrProc, !Queue, !Needed). -dead_proc_examine_cases([case(_, Goal) | Cases], CurrProc, +dead_proc_examine_cases([case(_, _, Goal) | Cases], CurrProc, !Queue, !Needed) :- dead_proc_examine_goal(Goal, CurrProc, !Queue, !Needed), dead_proc_examine_cases(Cases, CurrProc, !Queue, !Needed). @@ -1037,7 +1037,7 @@ pre_modecheck_examine_goal_expr(if_then_else(_, If, Then, Else), !DeadInfo) :- list.foldl(pre_modecheck_examine_goal, [If, Then, Else], !DeadInfo). pre_modecheck_examine_goal_expr(switch(_, _, Cases), !DeadInfo) :- ExamineCase = (pred(Case::in, Info0::in, Info::out) is det :- - Case = case(_, Goal), + Case = case(_, _, Goal), pre_modecheck_examine_goal(Goal, Info0, Info) ), list.foldl(ExamineCase, Cases, !DeadInfo). diff --git a/compiler/deep_profiling.m b/compiler/deep_profiling.m index 026ccac26..660ebd9fc 100644 --- a/compiler/deep_profiling.m +++ b/compiler/deep_profiling.m @@ -125,8 +125,8 @@ apply_tail_recursion_to_proc(PredProcId, !ModuleInfo) :- ClonePredProcId = proc(PredId, CloneProcId), ApplyInfo = apply_tail_recursion_info(!.ModuleInfo, [PredProcId - ClonePredProcId], Detism, Outputs), - apply_tail_recursion_to_goal(Goal0, ApplyInfo, Goal, no, - FoundTailCall, _), + apply_tail_recursion_to_goal(Goal0, Goal, ApplyInfo, no, FoundTailCall, + _), FoundTailCall = yes -> proc_info_set_goal(Goal, ProcInfo0, ProcInfo1), @@ -189,11 +189,11 @@ find_list_of_output_args_2([Var | Vars], [Mode | Modes], [Type | Types], outputs :: list(prog_var) ). -:- pred apply_tail_recursion_to_goal(hlds_goal::in, - apply_tail_recursion_info::in, hlds_goal::out, bool::in, bool::out, +:- pred apply_tail_recursion_to_goal(hlds_goal::in, hlds_goal::out, + apply_tail_recursion_info::in, bool::in, bool::out, maybe(list(prog_var))::out) is det. -apply_tail_recursion_to_goal(Goal0, ApplyInfo, Goal, !FoundTailCall, +apply_tail_recursion_to_goal(Goal0, Goal, ApplyInfo, !FoundTailCall, Continue) :- Goal0 = hlds_goal(GoalExpr0, GoalInfo0), ( @@ -252,7 +252,7 @@ apply_tail_recursion_to_goal(Goal0, ApplyInfo, Goal, !FoundTailCall, GoalExpr0 = conj(ConjType, Goals0), ( ConjType = plain_conj, - apply_tail_recursion_to_conj(Goals0, ApplyInfo, Goals, + apply_tail_recursion_to_conj(Goals0, Goals, ApplyInfo, !FoundTailCall, Continue), GoalExpr = conj(ConjType, Goals), Goal = hlds_goal(GoalExpr, GoalInfo0) @@ -263,22 +263,22 @@ apply_tail_recursion_to_goal(Goal0, ApplyInfo, Goal, !FoundTailCall, ) ; GoalExpr0 = disj(Goals0), - apply_tail_recursion_to_disj(Goals0, ApplyInfo, Goals, !FoundTailCall), + apply_tail_recursion_to_disj(Goals0, Goals, ApplyInfo, !FoundTailCall), GoalExpr = disj(Goals), Goal = hlds_goal(GoalExpr, GoalInfo0), Continue = no ; GoalExpr0 = switch(Var, CanFail, Cases0), - apply_tail_recursion_to_cases(Cases0, ApplyInfo, Cases, + apply_tail_recursion_to_cases(Cases0, Cases, ApplyInfo, !FoundTailCall), GoalExpr = switch(Var, CanFail, Cases), Goal = hlds_goal(GoalExpr, GoalInfo0), Continue = no ; GoalExpr0 = if_then_else(Vars, Cond, Then0, Else0), - apply_tail_recursion_to_goal(Then0, ApplyInfo, Then, + apply_tail_recursion_to_goal(Then0, Then, ApplyInfo, !FoundTailCall, _), - apply_tail_recursion_to_goal(Else0, ApplyInfo, Else, + apply_tail_recursion_to_goal(Else0, Else, ApplyInfo, !FoundTailCall, _), GoalExpr = if_then_else(Vars, Cond, Then, Else), Goal = hlds_goal(GoalExpr, GoalInfo0), @@ -310,48 +310,46 @@ apply_tail_recursion_process_assign([Output0 | Outputs0], ToVar, FromVar, apply_tail_recursion_process_assign(Outputs0, ToVar, FromVar, Outputs). :- pred apply_tail_recursion_to_conj(list(hlds_goal)::in, - apply_tail_recursion_info::in, list(hlds_goal)::out, + list(hlds_goal)::out, apply_tail_recursion_info::in, bool::in, bool::out, maybe(list(prog_var))::out) is det. -apply_tail_recursion_to_conj([], ApplyInfo, [], +apply_tail_recursion_to_conj([], [], ApplyInfo, !FoundTailCall, yes(ApplyInfo ^ outputs)). -apply_tail_recursion_to_conj([Goal0 | Goals0], ApplyInfo0, [Goal | Goals], +apply_tail_recursion_to_conj([Goal0 | Goals0], [Goal | Goals], ApplyInfo0, !FoundTailCall, Continue) :- - apply_tail_recursion_to_conj(Goals0, ApplyInfo0, Goals, - !FoundTailCall, Continue1), + apply_tail_recursion_to_conj(Goals0, Goals, ApplyInfo0, !FoundTailCall, + Continue1), ( Continue1 = yes(Outputs), - apply_tail_recursion_to_goal(Goal0, - ApplyInfo0 ^ outputs := Outputs, Goal, - !FoundTailCall, Continue) + apply_tail_recursion_to_goal(Goal0, Goal, + ApplyInfo0 ^ outputs := Outputs, !FoundTailCall, Continue) ; Continue1 = no, Goal = Goal0, Continue = no ). -:- pred apply_tail_recursion_to_disj(list(hlds_goal)::in, - apply_tail_recursion_info::in, list(hlds_goal)::out, - bool::in, bool::out) is det. +:- pred apply_tail_recursion_to_disj(list(hlds_goal)::in, list(hlds_goal)::out, + apply_tail_recursion_info::in, bool::in, bool::out) is det. -apply_tail_recursion_to_disj([], _, [], !FoundTailCall). -apply_tail_recursion_to_disj([Goal0], ApplyInfo, [Goal], - !FoundTailCall) :- - apply_tail_recursion_to_goal(Goal0, ApplyInfo, Goal, !FoundTailCall, _). -apply_tail_recursion_to_disj([Goal0 | Goals0], ApplyInfo, [Goal0 | Goals], +apply_tail_recursion_to_disj([], [], _, !FoundTailCall). +apply_tail_recursion_to_disj([Goal0], [Goal], ApplyInfo, !FoundTailCall) :- + apply_tail_recursion_to_goal(Goal0, Goal, ApplyInfo, !FoundTailCall, _). +apply_tail_recursion_to_disj([Goal0 | Goals0], [Goal0 | Goals], ApplyInfo, !FoundTailCall) :- Goals0 = [_ | _], - apply_tail_recursion_to_disj(Goals0, ApplyInfo, Goals, !FoundTailCall). + apply_tail_recursion_to_disj(Goals0, Goals, ApplyInfo, !FoundTailCall). -:- pred apply_tail_recursion_to_cases(list(case)::in, - apply_tail_recursion_info::in, list(case)::out, - bool::in, bool::out) is det. +:- pred apply_tail_recursion_to_cases(list(case)::in, list(case)::out, + apply_tail_recursion_info::in, bool::in, bool::out) is det. -apply_tail_recursion_to_cases([], _, [], !FoundTailCall). -apply_tail_recursion_to_cases([case(ConsId, Goal0) | Cases0], ApplyInfo, - [case(ConsId, Goal) | Cases], !FoundTailCall) :- - apply_tail_recursion_to_goal(Goal0, ApplyInfo, Goal, !FoundTailCall, _), - apply_tail_recursion_to_cases(Cases0, ApplyInfo, Cases, !FoundTailCall). +apply_tail_recursion_to_cases([], [], _, !FoundTailCall). +apply_tail_recursion_to_cases([Case0 | Cases0], [Case | Cases], ApplyInfo, + !FoundTailCall) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), + apply_tail_recursion_to_goal(Goal0, Goal, ApplyInfo, !FoundTailCall, _), + Case = case(MainConsId, OtherConsIds, Goal), + apply_tail_recursion_to_cases(Cases0, Cases, ApplyInfo, !FoundTailCall). %-----------------------------------------------------------------------------% @@ -375,7 +373,7 @@ figure_out_rec_call_numbers(Goal, !N, !TailCallSites) :- ; true ), - ( + ( ( BuiltinState = out_of_line_builtin ; BuiltinState = not_builtin ), @@ -426,7 +424,7 @@ figure_out_rec_call_numbers_in_goal_list([Goal|Goals], !N, !TailCallSites) :- figure_out_rec_call_numbers_in_case_list([], !N, !TailCallSites). figure_out_rec_call_numbers_in_case_list([Case|Cases], !N, !TailCallSites) :- - Case = case(_, Goal), + Case = case(_, _, Goal), figure_out_rec_call_numbers(Goal, !N, !TailCallSites), figure_out_rec_call_numbers_in_case_list(Cases, !N, !TailCallSites). @@ -1025,12 +1023,14 @@ deep_prof_transform_disj(N, Path, [Goal0 | Goals0], [Goal | Goals], deep_info::in, deep_info::out) is det. deep_prof_transform_switch(_, _, _, [], [], no, !DeepInfo). -deep_prof_transform_switch(MaybeNumCases, N, Path, [case(Id, Goal0) | Goals0], - [case(Id, Goal) | Goals], AddedImpurity, !DeepInfo) :- +deep_prof_transform_switch(MaybeNumCases, N, Path, + [Case0 | Cases0], [Case | Cases], AddedImpurity, !DeepInfo) :- N1 = N + 1, + Case0 = case(MainConsId, OtherConsIds, Goal0), deep_prof_transform_goal(cord.snoc(Path, step_switch(N1, MaybeNumCases)), Goal0, Goal, AddedImpurityFirst, !DeepInfo), - deep_prof_transform_switch(MaybeNumCases, N1, Path, Goals0, Goals, + Case = case(MainConsId, OtherConsIds, Goal), + deep_prof_transform_switch(MaybeNumCases, N1, Path, Cases0, Cases, AddedImpurityLater, !DeepInfo), bool.or(AddedImpurityFirst, AddedImpurityLater, AddedImpurity). diff --git a/compiler/deforest.m b/compiler/deforest.m index 220c4f639..133abec00 100644 --- a/compiler/deforest.m +++ b/compiler/deforest.m @@ -379,12 +379,14 @@ deforest_disj([Goal0 | Goals0], [Goal | Goals], !PDInfo, !IO) :- pd_info::in, pd_info::out, io::di, io::uo) is det. deforest_cases(_, [], [], !PDInfo, !IO). -deforest_cases(Var, [case(ConsId, Goal0) | Cases0], - [case(ConsId, Goal) | Cases], !PDInfo, !IO) :- - % Bind Var to ConsId in the instmap before processing this case. +deforest_cases(Var, [Case0 | Cases0], [Case | Cases], !PDInfo, !IO) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), + % Bind Var to MainConsId or one of the OtherConsIds in the instmap + % before processing this case. pd_info_get_instmap(!.PDInfo, InstMap0), - pd_info_bind_var_to_functor(Var, ConsId, !PDInfo), + pd_info_bind_var_to_functors(Var, MainConsId, OtherConsIds, !PDInfo), deforest_goal(Goal0, Goal, !PDInfo, !IO), + Case = case(MainConsId, OtherConsIds, Goal), pd_info_set_instmap(InstMap0, !PDInfo), deforest_cases(Var, Cases0, Cases, !PDInfo, !IO). @@ -1715,12 +1717,13 @@ append_goal_to_disjuncts(BetweenGoals, GoalToAppend, NonLocals, append_goal_to_cases(_, _, _, _, _, _, [], [], !PDInfo, !IO). append_goal_to_cases(Var, BetweenGoals, GoalToAppend, NonLocals, - CurrCase, Branches, [case(ConsId, Goal0) | Cases0], - [case(ConsId, Goal) | Cases], !PDInfo, !IO) :- + CurrCase, Branches, [Case0 | Cases0], [Case | Cases], !PDInfo, !IO) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), pd_info_get_instmap(!.PDInfo, InstMap0), - pd_info_bind_var_to_functor(Var, ConsId, !PDInfo), + pd_info_bind_var_to_functors(Var, MainConsId, OtherConsIds, !PDInfo), append_goal(Goal0, BetweenGoals, GoalToAppend, NonLocals, CurrCase, Branches, Goal, !PDInfo, !IO), + Case = case(MainConsId, OtherConsIds, Goal), NextCase = CurrCase + 1, pd_info_set_instmap(InstMap0, !PDInfo), append_goal_to_cases(Var, BetweenGoals, GoalToAppend, diff --git a/compiler/delay_construct.m b/compiler/delay_construct.m index b8fc25db1..33b6bc3ab 100644 --- a/compiler/delay_construct.m +++ b/compiler/delay_construct.m @@ -269,9 +269,11 @@ delay_construct_in_goals([Goal0 | Goals0], InstMap0, DelayInfo, delay_construct_info::in, list(case)::out) is det. delay_construct_in_cases([], _, _, []). -delay_construct_in_cases([case(Cons, Goal0) | Cases0], InstMap0, DelayInfo, - [case(Cons, Goal) | Cases]) :- +delay_construct_in_cases([Case0 | Cases0], InstMap0, DelayInfo, + [Case | Cases]) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), delay_construct_in_goal(Goal0, InstMap0, DelayInfo, Goal), + Case = case(MainConsId, OtherConsIds, Goal), delay_construct_in_cases(Cases0, InstMap0, DelayInfo, Cases). %-----------------------------------------------------------------------------% diff --git a/compiler/delay_partial_inst.m b/compiler/delay_partial_inst.m index 110932377..faea5b510 100644 --- a/compiler/delay_partial_inst.m +++ b/compiler/delay_partial_inst.m @@ -539,11 +539,12 @@ delay_partial_inst_in_goals(InstMap0, delay_partial_inst_info::in, delay_partial_inst_info::out) is det. delay_partial_inst_in_cases(_, [], [], !ConstructMap, !DelayInfo). -delay_partial_inst_in_cases(InstMap0, - [case(Cons, Goal0) | Cases0], [case(Cons, Goal) | Cases], +delay_partial_inst_in_cases(InstMap0, [Case0 | Cases0], [Case | Cases], !ConstructMap, !DelayInfo) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), delay_partial_inst_in_goal(InstMap0, Goal0, Goal, !ConstructMap, !DelayInfo), + Case = case(MainConsId, OtherConsIds, Goal), delay_partial_inst_in_cases(InstMap0, Cases0, Cases, !ConstructMap, !DelayInfo). diff --git a/compiler/dense_switch.m b/compiler/dense_switch.m index b42ece004..f9c1dbe3a 100644 --- a/compiler/dense_switch.m +++ b/compiler/dense_switch.m @@ -5,80 +5,89 @@ % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% -% +% % File: dense_switch.m. % Author: fjh. -% +% % For switches on atomic types, generate code using a dense jump table. -% +% %-----------------------------------------------------------------------------% :- module ll_backend.dense_switch. :- interface. -:- import_module backend_libs.switch_util. :- import_module hlds.code_model. :- import_module hlds.hlds_goal. :- import_module ll_backend.code_info. :- import_module ll_backend.llds. :- import_module parse_tree.prog_data. -:- import_module parse_tree.prog_type. + +:- import_module list. %-----------------------------------------------------------------------------% +:- type dense_switch_info. + % Should this switch be implemented as a dense jump table? % If so, we return the starting and ending values for the table, % and whether the switch is not covers all cases or not % (we may convert locally semidet switches into locally det % switches by adding extra cases whose body is just `fail'). % -:- pred cases_list_is_dense_switch(code_info::in, prog_var::in, - cases_list::in, can_fail::in, int::in, int::out, int::out, can_fail::out) - is semidet. +:- pred tagged_case_list_is_dense_switch(code_info::in, mer_type::in, + list(tagged_case)::in, int::in, int::in, int::in, int::in, + can_fail::in, dense_switch_info::out) is semidet. % Generate code for a switch using a dense jump table. % -:- pred generate_dense_switch(cases_list::in, int::in, int::in, prog_var::in, - code_model::in, can_fail::in, hlds_goal_info::in, label::in, - branch_end::in, branch_end::out, code_tree::out, +:- pred generate_dense_switch(list(tagged_case)::in, rval::in, string::in, + code_model::in, hlds_goal_info::in, dense_switch_info::in, + label::in, branch_end::in, branch_end::out, code_tree::out, code_info::in, code_info::out) is det. - % Also used by lookup_switch. - % -:- pred type_range(code_info::in, type_category::in, mer_type::in, int::out) - is semidet. - %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module backend_libs.builtin_ops. +:- import_module backend_libs.switch_util. :- import_module check_hlds.type_util. :- import_module hlds.hlds_data. :- import_module hlds.hlds_goal. :- import_module hlds.hlds_llds. +:- import_module hlds.hlds_out. +:- import_module libs.compiler_util. :- import_module libs.tree. :- import_module ll_backend.code_gen. :- import_module ll_backend.trace_gen. +:- import_module parse_tree.prog_type. +:- import_module assoc_list. :- import_module int. -:- import_module list. +:- import_module map. +:- import_module maybe. :- import_module pair. +:- import_module svmap. %-----------------------------------------------------------------------------% -cases_list_is_dense_switch(CI, CaseVar, TaggedCases, CanFail0, ReqDensity, - FirstVal, LastVal, CanFail) :- +:- type dense_switch_info + ---> dense_switch_info( + first_value :: int, + last_value :: int, + new_can_fail :: can_fail + ). + +tagged_case_list_is_dense_switch(CI, VarType, TaggedCases, + LowerLimit, UpperLimit, NumValues, ReqDensity, CanFail0, + DenseSwitchInfo) :- list.length(TaggedCases, NumCases), NumCases > 2, - TaggedCases = [FirstCase | _], - FirstCase = extended_case(_, int_tag(FirstCaseVal), _, _), - list.index1_det(TaggedCases, NumCases, LastCase), - LastCase = extended_case(_, int_tag(LastCaseVal), _, _), - Span = LastCaseVal - FirstCaseVal, + + Span = UpperLimit - LowerLimit, Range = Span + 1, - Density = switch_density(NumCases, Range), + Density = switch_density(NumValues, Range), Density > ReqDensity, ( CanFail0 = can_fail, @@ -86,12 +95,12 @@ cases_list_is_dense_switch(CI, CaseVar, TaggedCases, CanFail0, ReqDensity, % is in range before we index into the jump table. However, if the % range of the type is sufficiently small, we can make the jump table % large enough to hold all of the values for the type. - Type = variable_type(CI, CaseVar), get_module_info(CI, ModuleInfo), - classify_type(ModuleInfo, Type) = TypeCategory, + classify_type(ModuleInfo, VarType) = TypeCategory, ( - dense_switch.type_range(CI, TypeCategory, Type, TypeRange), - DetDensity = switch_density(NumCases, TypeRange), + type_range(ModuleInfo, TypeCategory, VarType, _Min, _Max, + TypeRange), + DetDensity = switch_density(NumValues, TypeRange), DetDensity > ReqDensity -> CanFail = cannot_fail, @@ -99,126 +108,186 @@ cases_list_is_dense_switch(CI, CaseVar, TaggedCases, CanFail0, ReqDensity, LastVal = TypeRange - 1 ; CanFail = CanFail0, - FirstVal = FirstCaseVal, - LastVal = LastCaseVal + FirstVal = LowerLimit, + LastVal = UpperLimit ) ; CanFail0 = cannot_fail, CanFail = cannot_fail, - FirstVal = FirstCaseVal, - LastVal = LastCaseVal - ). + FirstVal = LowerLimit, + LastVal = UpperLimit + ), + DenseSwitchInfo = dense_switch_info(FirstVal, LastVal, CanFail). %---------------------------------------------------------------------------% - % Determine the range of an atomic type. Fail if the type isn't the sort - % of type that has a range or if the type's range is to big to switch on - % (e.g. int). - % -type_range(CI, TypeCategory, Type, Range) :- - get_module_info(CI, ModuleInfo), - switch_util.type_range(TypeCategory, Type, ModuleInfo, Min, Max), - Range = Max - Min + 1. - -%---------------------------------------------------------------------------% - -generate_dense_switch(Cases, StartVal, EndVal, Var, CodeModel, CanFail, - SwitchGoalInfo, EndLabel, MaybeEnd0, MaybeEnd, Code, !CI) :- +generate_dense_switch(TaggedCases, VarRval, VarName, CodeModel, SwitchGoalInfo, + DenseSwitchInfo, EndLabel, MaybeEnd0, MaybeEnd, Code, !CI) :- % Evaluate the variable which we are going to be switching on. - produce_variable(Var, VarCode, Rval, !CI), % If the case values start at some number other than 0, % then subtract that number to give us a zero-based index. - ( StartVal = 0 -> - Index = Rval + DenseSwitchInfo = dense_switch_info(FirstVal, LastVal, CanFail), + ( FirstVal = 0 -> + IndexRval = VarRval ; - Index = binop(int_sub, Rval, const(llconst_int(StartVal))) + IndexRval = binop(int_sub, VarRval, const(llconst_int(FirstVal))) ), % If the switch is not locally deterministic, we need to check that % the value of the variable lies within the appropriate range. ( CanFail = can_fail, - Difference = EndVal - StartVal, + Difference = LastVal - FirstVal, fail_if_rval_is_false( - binop(unsigned_le, Index, const(llconst_int(Difference))), - RangeCheck, !CI) + binop(unsigned_le, IndexRval, const(llconst_int(Difference))), + RangeCheckCode, !CI) ; CanFail = cannot_fail, - RangeCheck = empty + RangeCheckCode = empty ), - % Now generate the jump table and the cases. - generate_dense_cases(Cases, StartVal, EndVal, CodeModel, SwitchGoalInfo, - EndLabel, MaybeEnd0, MaybeEnd, Labels, CasesCode, !CI), - % XXX We keep track of the code_info at the end of one of the non-fail - % cases. We have to do this because generating a `fail' slot last would - % yield the wrong liveness and would not unset the failure continuation + % Generate the cases. + % We keep track of the code_info at the end of the non-fail cases. + % We have to do this because generating a `fail' slot last would yield + % the wrong liveness and would not unset the failure continuation % for a nondet switch. - DoJump = node([ - llds_instr(computed_goto(Index, Labels), + list.map_foldl3(generate_dense_case(VarName, CodeModel, SwitchGoalInfo, + EndLabel), TaggedCases, CasesCodes, + map.init, IndexMap, MaybeEnd0, MaybeEnd, !CI), + CasesCode = tree_list(CasesCodes), + + % Generate the jump table. + map.to_assoc_list(IndexMap, IndexPairs), + generate_dense_jump_table(FirstVal, LastVal, IndexPairs, Targets, + no, MaybeFailLabel, !CI), + JumpCode = node([ + llds_instr(computed_goto(IndexRval, Targets), "switch (using dense jump table)") ]), - % Assemble the code fragments. - Code = tree_list([VarCode, RangeCheck, DoJump, CasesCode]). -:- pred generate_dense_cases(cases_list::in, int::in, int::in, code_model::in, - hlds_goal_info::in, label::in, branch_end::in, branch_end::out, - list(label)::out, code_tree::out, code_info::in, code_info::out) is det. - -generate_dense_cases(Cases0, NextVal, EndVal, CodeModel, SwitchGoalInfo, - EndLabel, !MaybeEnd, Labels, Code, !CI) :- - ( NextVal > EndVal -> - Labels = [], - Code = node([ - llds_instr(label(EndLabel), "End of dense switch") - ]) + % If there is no case for any index value in range, generate the failure + % code we execute for such cases. + ( + MaybeFailLabel = no, + FailCode = empty ; - get_next_label(ThisLabel, !CI), - generate_dense_case(Cases0, Cases1, NextVal, CodeModel, - SwitchGoalInfo, !MaybeEnd, ThisCode, Comment, !CI), - LabelCode = node([ - llds_instr(label(ThisLabel), Comment) + MaybeFailLabel = yes(FailLabel), + FailComment = "compiler-introduced `fail' case of dense switch", + FailLabelCode = node([ + llds_instr(label(FailLabel), FailComment) ]), - JumpCode = node([ - llds_instr(goto(code_label(EndLabel)), - "branch to end of dense switch") - ]), - % Generate the rest of the cases. - NextVal1 = NextVal + 1, - generate_dense_cases(Cases1, NextVal1, EndVal, CodeModel, - SwitchGoalInfo, EndLabel, !MaybeEnd, Labels1, OtherCasesCode, !CI), - Labels = [ThisLabel | Labels1], - Code = tree_list([LabelCode, ThisCode, JumpCode, OtherCasesCode]) + generate_failure(FailureCode, !CI), + FailCode = tree(FailLabelCode, FailureCode) + ), + + EndLabelCode = node([ + llds_instr(label(EndLabel), "end of dense switch") + ]), + + % Assemble the code fragments. + Code = tree_list([RangeCheckCode, JumpCode, CasesCode, FailCode, + EndLabelCode]). + +%---------------------------------------------------------------------------% + +:- pred generate_dense_case(string::in, code_model::in, hlds_goal_info::in, + label::in, tagged_case::in, code_tree::out, + map(int, label)::in, map(int, label)::out, + branch_end::in, branch_end::out, + code_info::in, code_info::out) is det. + +generate_dense_case(VarName, CodeModel, SwitchGoalInfo, EndLabel, + TaggedCase, Code, !IndexMap, !MaybeEnd, !CI) :- + TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal), + project_cons_name_and_tag(TaggedMainConsId, MainConsName, MainConsTag), + list.map2(project_cons_name_and_tag, TaggedOtherConsIds, + OtherConsNames, OtherConsTags), + LabelComment = case_comment(VarName, MainConsName, OtherConsNames), + get_next_label(Label, !CI), + record_dense_label_for_cons_tag(Label, MainConsTag, !IndexMap), + list.foldl(record_dense_label_for_cons_tag(Label), OtherConsTags, + !IndexMap), + LabelCode = node([ + llds_instr(label(Label), LabelComment) + ]), + % We need to save the expression cache, etc., + % and restore them when we've finished. + remember_position(!.CI, BranchStart), + maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, !CI), + code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), + BranchToEndCode = node([ + llds_instr(goto(code_label(EndLabel)), + "branch to end of dense switch") + ]), + goal_info_get_store_map(SwitchGoalInfo, StoreMap), + generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), + Code = tree_list([LabelCode, TraceCode, GoalCode, SaveCode, + BranchToEndCode]), + reset_to_position(BranchStart, !CI). + +:- pred record_dense_label_for_cons_tag(label::in, cons_tag::in, + map(int, label)::in, map(int, label)::out) is det. + +record_dense_label_for_cons_tag(Label, ConsTag, !IndexMap) :- + ( ConsTag = int_tag(Index) -> + svmap.det_insert(Index, Label, !IndexMap) + ; + unexpected(this_file, "record_label_for_index: not int_tag") + ). + +%----------------------------------------------------------------------------% + +:- pred generate_dense_jump_table(int::in, int::in, + assoc_list(int, label)::in, list(maybe(label))::out, + maybe(label)::in, maybe(label)::out, + code_info::in, code_info::out) is det. + +generate_dense_jump_table(CurVal, LastVal, IndexPairs, Targets, + !MaybeFailLabel, !CI) :- + ( CurVal > LastVal -> + expect(unify(IndexPairs, []), this_file, + "generate_dense_jump_table: NextVal > LastVal, IndexList not []"), + Targets = [] + ; + NextVal = CurVal + 1, + ( + IndexPairs = [], + get_dense_fail_label(FailLabel, !MaybeFailLabel, !CI), + generate_dense_jump_table(NextVal, LastVal, IndexPairs, + LaterTargets, !MaybeFailLabel, !CI), + Targets = [yes(FailLabel) | LaterTargets] + ; + IndexPairs = [FirstIndexPair | LaterIndexPairs], + FirstIndexPair = FirstIndex - FirstLabel, + ( FirstIndex = CurVal -> + generate_dense_jump_table(NextVal, LastVal, LaterIndexPairs, + LaterTargets, !MaybeFailLabel, !CI), + Targets = [yes(FirstLabel) | LaterTargets] + ; + get_dense_fail_label(FailLabel, !MaybeFailLabel, !CI), + generate_dense_jump_table(NextVal, LastVal, IndexPairs, + LaterTargets, !MaybeFailLabel, !CI), + Targets = [yes(FailLabel) | LaterTargets] + ) + ) + ). + +:- pred get_dense_fail_label(label::out, maybe(label)::in, maybe(label)::out, + code_info::in, code_info::out) is det. + +get_dense_fail_label(FailLabel, !MaybeFailLabel, !CI) :- + ( + !.MaybeFailLabel = no, + get_next_label(FailLabel, !CI), + !:MaybeFailLabel = yes(FailLabel) + ; + !.MaybeFailLabel = yes(FailLabel) ). %---------------------------------------------------------------------------% -:- pred generate_dense_case(cases_list::in, cases_list::out, int::in, - code_model::in, hlds_goal_info::in, branch_end::in, branch_end::out, - code_tree::out, string::out, code_info::in, code_info::out) is det. +:- func this_file = string. -generate_dense_case(!Cases, NextVal, CodeModel, SwitchGoalInfo, !MaybeEnd, - Code, Comment, !CI) :- - ( - !.Cases = [Case | !:Cases], - Case = extended_case(_, int_tag(NextVal), _, Goal) - -> - Comment = "case of dense switch", - % We need to save the expression cache, etc., - % and restore them when we've finished. - remember_position(!.CI, BranchStart), - maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, - !CI), - code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), - goal_info_get_store_map(SwitchGoalInfo, StoreMap), - generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), - Code = tree_list([TraceCode, GoalCode, SaveCode]), - reset_to_position(BranchStart, !CI) - ; - % This case didn't occur in the original case list - % - just generate a `fail' for it. - Comment = "compiler-introduced `fail' case of dense switch", - generate_failure(Code, !CI) - ). +this_file = "dense_switch.m". %----------------------------------------------------------------------------% :- end_module dense_switch. diff --git a/compiler/dep_par_conj.m b/compiler/dep_par_conj.m index 338587566..044e14e47 100644 --- a/compiler/dep_par_conj.m +++ b/compiler/dep_par_conj.m @@ -510,9 +510,9 @@ search_disj_for_par_conj([Goal0 | Goals0], [Goal | Goals], InstMap0, !Info) :- search_cases_for_par_conj([], [], _InstMap0, !Info). search_cases_for_par_conj([Case0 | Cases0], [Case | Cases], InstMap0, !Info) :- - Case0 = case(Functor, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), search_goal_for_par_conj(Goal0, Goal, InstMap0, _, !Info), - Case = case(Functor, Goal), + Case = case(MainConsId, OtherConsIds, Goal), search_cases_for_par_conj(Cases0, Cases, InstMap0, !Info). %-----------------------------------------------------------------------------% @@ -869,10 +869,10 @@ insert_wait_in_cases(_ModuleInfo, _FutureMap, _ConsumedVar, [], [], !VarSet, !VarTypes). insert_wait_in_cases(ModuleInfo, FutureMap, ConsumedVar, [Case0 | Cases0], [Case | Cases], !VarSet, !VarTypes) :- - Case0 = case(Functor, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), insert_wait_in_goal(ModuleInfo, FutureMap, ConsumedVar, Goal0, Goal, !VarSet, !VarTypes), - Case = case(Functor, Goal), + Case = case(MainConsId, OtherConsIds, Goal), insert_wait_in_cases(ModuleInfo, FutureMap, ConsumedVar, Cases0, Cases, !VarSet, !VarTypes). @@ -1017,10 +1017,10 @@ insert_signal_in_cases(_ModuleInfo, _FutureMap, _ProducedVar, [], [], !VarSet, !VarTypes). insert_signal_in_cases(ModuleInfo, FutureMap, ProducedVar, [Case0 | Cases0], [Case | Cases], !VarSet, !VarTypes) :- - Case0 = case(Functor, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), insert_signal_in_goal(ModuleInfo, FutureMap, ProducedVar, Goal0, Goal, !VarSet, !VarTypes), - Case = case(Functor, Goal), + Case = case(MainConsId, OtherConsIds, Goal), insert_signal_in_cases(ModuleInfo, FutureMap, ProducedVar, Cases0, Cases, !VarSet, !VarTypes). @@ -1142,9 +1142,9 @@ replace_sequences_in_goals([Goal0 | Goals0], [Goal | Goals], !Info) :- replace_sequences_in_cases([], [], !Info). replace_sequences_in_cases([Case0 | Cases0], [Case | Cases], !Info) :- - Case0 = case(Functor, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), replace_sequences_in_goal(Goal0, Goal, !Info), - Case = case(Functor, Goal), + Case = case(MainConsId, OtherConsIds, Goal), replace_sequences_in_cases(Cases0, Cases, !Info). :- inst call_goal_expr @@ -1531,12 +1531,11 @@ rename_apart_in_goals(ModuleInfo, rename_apart_in_cases(_ModuleInfo, [], [], _InstMap0, !VarSet, !VarTypes). rename_apart_in_cases(ModuleInfo, - [Case0 | Cases0], [Case | Cases], InstMap0, - !VarSet, !VarTypes) :- - Case0 = case(Functor, Goal0), + [Case0 | Cases0], [Case | Cases], InstMap0, !VarSet, !VarTypes) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), rename_apart_in_goal(ModuleInfo, Goal0, Goal, InstMap0, !VarSet, !VarTypes), - Case = case(Functor, Goal), + Case = case(MainConsId, OtherConsIds, Goal), rename_apart_in_cases(ModuleInfo, Cases0, Cases, InstMap0, !VarSet, !VarTypes). diff --git a/compiler/dependency_graph.m b/compiler/dependency_graph.m index 87df2acb5..39185d0b6 100644 --- a/compiler/dependency_graph.m +++ b/compiler/dependency_graph.m @@ -301,7 +301,7 @@ add_proc_arcs([ProcId | ProcIds], PredId, ModuleInfo, IncludeImported, proc_info_get_goal(ProcInfo0, Goal), digraph.lookup_key(!.DepGraph, proc(PredId, ProcId), Caller), - add_dependency_arcs_in_goal(Goal, Caller, !DepGraph) + add_dependency_arcs_in_goal(Caller, Goal, !DepGraph) ; IncludeImported = include_imported, pred_info_get_import_status(PredInfo0, ImportStatus), @@ -312,7 +312,7 @@ add_proc_arcs([ProcId | ProcIds], PredId, ModuleInfo, IncludeImported, Imported = no, proc_info_get_goal(ProcInfo0, Goal), digraph.lookup_key(!.DepGraph, proc(PredId, ProcId), Caller), - add_dependency_arcs_in_goal(Goal, Caller, !DepGraph) + add_dependency_arcs_in_goal(Caller, Goal, !DepGraph) ) ), add_proc_arcs(ProcIds, PredId, ModuleInfo, IncludeImported, !DepGraph). @@ -337,7 +337,7 @@ add_pred_arcs([PredId | PredIds], ModuleInfo, IncludeImported, !DepGraph) :- get_clause_list_any_order(ClausesRep, Clauses), Goals = list.map(func(clause(_, Goal, _, _)) = Goal, Clauses), digraph.lookup_key(!.DepGraph, PredId, Caller), - add_dependency_arcs_in_list(Goals, Caller, !DepGraph) + add_dependency_arcs_in_list(Caller, Goals, !DepGraph) ), add_pred_arcs(PredIds, ModuleInfo, IncludeImported, !DepGraph). @@ -351,29 +351,29 @@ pred_proc_id_get_pred_id(proc(PredId, _)) = PredId. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% -:- pred add_dependency_arcs_in_goal(hlds_goal::in, digraph_key(T)::in, +:- pred add_dependency_arcs_in_goal(digraph_key(T)::in, hlds_goal::in, dependency_graph(T)::in, dependency_graph(T)::out) is det <= dependency_node(T). -add_dependency_arcs_in_goal(hlds_goal(GoalExpr, _), Caller, !DepGraph) :- +add_dependency_arcs_in_goal(Caller, hlds_goal(GoalExpr, _), !DepGraph) :- ( ( GoalExpr = conj(_, Goals) ; GoalExpr = disj(Goals) ), - add_dependency_arcs_in_list(Goals, Caller, !DepGraph) + add_dependency_arcs_in_list(Caller, Goals, !DepGraph) ; GoalExpr = switch(_Var, _Det, Cases), - add_dependency_arcs_in_cases(Cases, Caller, !DepGraph) + add_dependency_arcs_in_cases(Caller, Cases, !DepGraph) ; GoalExpr = if_then_else(_Vars, Cond, Then, Else), - add_dependency_arcs_in_goal(Cond, Caller, !DepGraph), - add_dependency_arcs_in_goal(Then, Caller, !DepGraph), - add_dependency_arcs_in_goal(Else, Caller, !DepGraph) + add_dependency_arcs_in_goal(Caller, Cond, !DepGraph), + add_dependency_arcs_in_goal(Caller, Then, !DepGraph), + add_dependency_arcs_in_goal(Caller, Else, !DepGraph) ; ( GoalExpr = negation(Goal) ; GoalExpr = scope(_, Goal) ), - add_dependency_arcs_in_goal(Goal, Caller, !DepGraph) + add_dependency_arcs_in_goal(Caller, Goal, !DepGraph) ; GoalExpr = generic_call(_, _, _, _) ; @@ -402,11 +402,11 @@ add_dependency_arcs_in_goal(hlds_goal(GoalExpr, _), Caller, !DepGraph) :- ; Unify = simple_test(_, _) ; - Unify = construct(_, Cons, _, _, _, _, _), - add_dependency_arcs_in_cons(Cons, Caller, !DepGraph) + Unify = construct(_, ConsId, _, _, _, _, _), + add_dependency_arcs_in_cons(Caller, ConsId, !DepGraph) ; - Unify = deconstruct(_, Cons, _, _, _, _), - add_dependency_arcs_in_cons(Cons, Caller, !DepGraph) + Unify = deconstruct(_, ConsId, _, _, _, _), + add_dependency_arcs_in_cons(Caller, ConsId, !DepGraph) ; Unify = complicated_unify(_, _, _) ) @@ -415,63 +415,67 @@ add_dependency_arcs_in_goal(hlds_goal(GoalExpr, _), Caller, !DepGraph) :- ; GoalExpr = shorthand(ShorthandGoal), ShorthandGoal = bi_implication(LHS, RHS), - add_dependency_arcs_in_list([LHS, RHS], Caller, !DepGraph) + add_dependency_arcs_in_list(Caller, [LHS, RHS], !DepGraph) ). %-----------------------------------------------------------------------------% -:- pred add_dependency_arcs_in_list(list(hlds_goal)::in, digraph_key(T)::in, +:- pred add_dependency_arcs_in_list(digraph_key(T)::in, list(hlds_goal)::in, dependency_graph(T)::in, dependency_graph(T)::out) is det <= dependency_node(T). -add_dependency_arcs_in_list([], _Caller, !DepGraph). -add_dependency_arcs_in_list([Goal|Goals], Caller, !DepGraph) :- - add_dependency_arcs_in_goal(Goal, Caller, !DepGraph), - add_dependency_arcs_in_list(Goals, Caller, !DepGraph). +add_dependency_arcs_in_list(_Caller, [], !DepGraph). +add_dependency_arcs_in_list(Caller, [Goal | Goals], !DepGraph) :- + add_dependency_arcs_in_goal(Caller, Goal, !DepGraph), + add_dependency_arcs_in_list(Caller, Goals, !DepGraph). %-----------------------------------------------------------------------------% -:- pred add_dependency_arcs_in_cases(list(case)::in, digraph_key(T)::in, +:- pred add_dependency_arcs_in_cases(digraph_key(T)::in, list(case)::in, dependency_graph(T)::in, dependency_graph(T)::out) is det <= dependency_node(T). -add_dependency_arcs_in_cases([], _Caller, !DepGraph). -add_dependency_arcs_in_cases([case(Cons, Goal) | Goals], Caller, !DepGraph) :- - add_dependency_arcs_in_cons(Cons, Caller, !DepGraph), - add_dependency_arcs_in_goal(Goal, Caller, !DepGraph), - add_dependency_arcs_in_cases(Goals, Caller, !DepGraph). +add_dependency_arcs_in_cases(_Caller, [], !DepGraph). +add_dependency_arcs_in_cases(Caller, [Case | Cases], !DepGraph) :- + Case = case(MainConsId, OtherConsIds, Goal), + add_dependency_arcs_in_cons(Caller, MainConsId, !DepGraph), + list.foldl(add_dependency_arcs_in_cons(Caller), OtherConsIds, !DepGraph), + add_dependency_arcs_in_goal(Caller, Goal, !DepGraph), + add_dependency_arcs_in_cases(Caller, Cases, !DepGraph). %-----------------------------------------------------------------------------% -:- pred add_dependency_arcs_in_cons(cons_id::in, digraph_key(T)::in, +:- pred add_dependency_arcs_in_cons(digraph_key(T)::in, cons_id::in, dependency_graph(T)::in, dependency_graph(T)::out) is det <= dependency_node(T). -add_dependency_arcs_in_cons(cons(_, _), _Caller, !DepGraph). -add_dependency_arcs_in_cons(int_const(_), _Caller, !DepGraph). -add_dependency_arcs_in_cons(string_const(_), _Caller, !DepGraph). -add_dependency_arcs_in_cons(float_const(_), _Caller, !DepGraph). -add_dependency_arcs_in_cons(pred_const(ShroudedPredProcId, _), Caller, - !DepGraph) :- - PredProcId = unshroud_pred_proc_id(ShroudedPredProcId), +add_dependency_arcs_in_cons(Caller, ConsId, !DepGraph) :- ( - % If the node isn't in the graph, then we didn't insert it - % because it was imported, and we don't consider it. - digraph.search_key(!.DepGraph, dependency_node(PredProcId), Callee) - -> - digraph.add_edge(Caller, Callee, !DepGraph) + ConsId = pred_const(ShroudedPredProcId, _), + PredProcId = unshroud_pred_proc_id(ShroudedPredProcId), + ( + % If the node isn't in the graph, then we didn't insert it + % because it was imported, and we don't consider it. + digraph.search_key(!.DepGraph, dependency_node(PredProcId), Callee) + -> + digraph.add_edge(Caller, Callee, !DepGraph) + ; + true + ) ; - true + ( ConsId = cons(_, _) + ; ConsId = int_const(_) + ; ConsId = string_const(_) + ; ConsId = float_const(_) + ; ConsId = type_ctor_info_const(_, _, _) + ; ConsId = base_typeclass_info_const(_, _, _, _) + ; ConsId = type_info_cell_constructor(_) + ; ConsId = typeclass_info_cell_constructor + ; ConsId = tabling_info_const(_) + ; ConsId = deep_profiling_proc_layout(_) + ; ConsId = table_io_decl(_) + ) ). -add_dependency_arcs_in_cons(type_ctor_info_const(_, _, _), _, !DepGraph). -add_dependency_arcs_in_cons(base_typeclass_info_const(_, _, _, _), _, - !DepGraph). -add_dependency_arcs_in_cons(type_info_cell_constructor(_), _, !DepGraph). -add_dependency_arcs_in_cons(typeclass_info_cell_constructor, _, - !DepGraph). -add_dependency_arcs_in_cons(tabling_info_const(_), _Caller, !DepGraph). -add_dependency_arcs_in_cons(deep_profiling_proc_layout(_), _, !DepGraph). -add_dependency_arcs_in_cons(table_io_decl(_), _Caller, !DepGraph). %-----------------------------------------------------------------------------% diff --git a/compiler/det_analysis.m b/compiler/det_analysis.m index f5b3ad330..c26a41872 100644 --- a/compiler/det_analysis.m +++ b/compiler/det_analysis.m @@ -93,8 +93,9 @@ % :- pred det_infer_goal(hlds_goal::in, hlds_goal::out, instmap::in, soln_context::in, list(failing_context)::in, maybe(pess_info)::in, - det_info::in, determinism::out, list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + determinism::out, list(failing_context)::out, + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. % Work out how many solutions are needed for a given determinism. % @@ -242,7 +243,7 @@ global_final_pass(!ModuleInfo, UndeclaredProcs, DeclaredProcs, Debug, % on the undeclared procs. global_inference_single_pass(DeclaredProcs, Debug, !ModuleInfo, [], !:Specs, unchanged, _), - global_checking_pass(UndeclaredProcs ++ DeclaredProcs, !.ModuleInfo, + global_checking_pass(UndeclaredProcs ++ DeclaredProcs, !ModuleInfo, !Specs). %-----------------------------------------------------------------------------% @@ -283,9 +284,10 @@ det_infer_proc(PredId, ProcId, !ModuleInfo, OldDetism, NewDetism, !:Specs) :- proc_info_get_goal(Proc0, Goal0), proc_info_get_initial_instmap(Proc0, !.ModuleInfo, InstMap0), proc_info_get_vartypes(Proc0, VarTypes), - det_info_init(!.ModuleInfo, VarTypes, PredId, ProcId, DetInfo), - det_infer_goal(Goal0, Goal, InstMap0, SolnContext, [], no, DetInfo, - InferDetism, _, [], !:Specs), + det_info_init(!.ModuleInfo, VarTypes, PredId, ProcId, DetInfo0), + det_infer_goal(Goal0, Goal, InstMap0, SolnContext, [], no, + InferDetism, _, DetInfo0, DetInfo, [], !:Specs), + det_info_get_module_info(DetInfo, !:ModuleInfo), % Take the worst of the old and inferred detisms. This is needed to prevent % loops on p :- not(p), at least if the initial assumed detism is det. @@ -384,15 +386,15 @@ get_exported_proc_context([Proc | Procs], PredId, ProcId, Context) :- det_infer_goal(hlds_goal(GoalExpr0, GoalInfo0), hlds_goal(GoalExpr, GoalInfo), InstMap0, !.SolnContext, RightFailingContexts, - MaybePromiseEqvSolutionSets, DetInfo, Detism, GoalFailingContexts, - !Specs) :- + MaybePromiseEqvSolutionSets, Detism, GoalFailingContexts, + !DetInfo, !Specs) :- NonLocalVars = goal_info_get_nonlocals(GoalInfo0), InstmapDelta = goal_info_get_instmap_delta(GoalInfo0), % If a pure or semipure goal has no output variables, then the goal % is in a single-solution context. ( - det_no_output_vars(NonLocalVars, InstMap0, InstmapDelta, DetInfo), + det_no_output_vars(NonLocalVars, InstMap0, InstmapDelta, !.DetInfo), Purity = goal_info_get_purity(GoalInfo0), ( Purity = purity_impure @@ -432,8 +434,8 @@ det_infer_goal(hlds_goal(GoalExpr0, GoalInfo0), hlds_goal(GoalExpr, GoalInfo), ), det_infer_goal_2(GoalExpr0, GoalExpr1, GoalInfo0, InstMap0, !.SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - InternalDetism0, GoalFailingContexts, !Specs), + RightFailingContexts, MaybePromiseEqvSolutionSets, + InternalDetism0, GoalFailingContexts, !DetInfo, !Specs), determinism_components(InternalDetism0, InternalCanFail, InternalSolns0), ( @@ -540,13 +542,14 @@ promise_eqv_solutions_kind_prunes(equivalent_solution_sets_arbitrary) = yes. :- pred det_infer_goal_2(hlds_goal_expr::in, hlds_goal_expr::out, hlds_goal_info::in, instmap::in, soln_context::in, - list(failing_context)::in, maybe(pess_info)::in, det_info::in, + list(failing_context)::in, maybe(pess_info)::in, determinism::out, list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. det_infer_goal_2(GoalExpr0, GoalExpr, GoalInfo, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, Detism, - GoalFailingContexts, !Specs) :- + RightFailingContexts, MaybePromiseEqvSolutionSets, Detism, + GoalFailingContexts, !DetInfo, !Specs) :- ( GoalExpr0 = conj(ConjType, Goals0), ( @@ -554,72 +557,72 @@ det_infer_goal_2(GoalExpr0, GoalExpr, GoalInfo, InstMap0, SolnContext, % The determinism of a conjunction is the worst case of the % determinism of the goals of that conjuction. det_infer_conj(Goals0, Goals, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - Detism, [], GoalFailingContexts, !Specs) + RightFailingContexts, MaybePromiseEqvSolutionSets, + Detism, [], GoalFailingContexts, !DetInfo, !Specs) ; ConjType = parallel_conj, det_infer_par_conj(Goals0, Goals, GoalInfo, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - Detism, GoalFailingContexts, !Specs) + RightFailingContexts, MaybePromiseEqvSolutionSets, + Detism, GoalFailingContexts, !DetInfo, !Specs) ), GoalExpr = conj(ConjType, Goals) ; GoalExpr0 = disj(Goals0), det_infer_disj(Goals0, Goals, GoalInfo, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - Detism, GoalFailingContexts, !Specs), + RightFailingContexts, MaybePromiseEqvSolutionSets, + Detism, GoalFailingContexts, !DetInfo, !Specs), GoalExpr = disj(Goals) ; GoalExpr0 = switch(Var, SwitchCanFail, Cases0), det_infer_switch(Var, SwitchCanFail, Cases0, Cases, GoalInfo, InstMap0, SolnContext, RightFailingContexts, MaybePromiseEqvSolutionSets, - DetInfo, Detism, GoalFailingContexts, !Specs), + Detism, GoalFailingContexts, !DetInfo, !Specs), GoalExpr = switch(Var, SwitchCanFail, Cases) ; GoalExpr0 = plain_call(PredId, ProcId0, Args, Builtin, UnifyContext, Name), det_infer_call(PredId, ProcId0, ProcId, GoalInfo, SolnContext, - RightFailingContexts, DetInfo, - Detism, GoalFailingContexts, !Specs), + RightFailingContexts, Detism, GoalFailingContexts, + !.DetInfo, !Specs), GoalExpr = plain_call(PredId, ProcId, Args, Builtin, UnifyContext, Name) ; GoalExpr0 = generic_call(GenericCall, _ArgVars, _Modes, CallDetism), det_infer_generic_call(GenericCall, CallDetism, GoalInfo, SolnContext, - RightFailingContexts, DetInfo, - Detism, GoalFailingContexts, !Specs), + RightFailingContexts, Detism, GoalFailingContexts, + !.DetInfo, !Specs), GoalExpr = GoalExpr0 ; GoalExpr0 = unify(LHS, RHS0, Mode, Unify, UnifyContext), det_infer_unify(LHS, RHS0, Unify, UnifyContext, RHS, GoalInfo, - InstMap0, SolnContext, RightFailingContexts, DetInfo, Detism, - GoalFailingContexts, !Specs), + InstMap0, SolnContext, RightFailingContexts, Detism, + GoalFailingContexts, !DetInfo, !Specs), GoalExpr = unify(LHS, RHS, Mode, Unify, UnifyContext) ; GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0), det_infer_if_then_else(Cond0, Cond, Then0, Then, Else0, Else, InstMap0, SolnContext, RightFailingContexts, - MaybePromiseEqvSolutionSets, DetInfo, Detism, - GoalFailingContexts, !Specs), + MaybePromiseEqvSolutionSets, Detism, GoalFailingContexts, + !DetInfo, !Specs), GoalExpr = if_then_else(Vars, Cond, Then, Else) ; GoalExpr0 = negation(Goal0), det_infer_not(Goal0, Goal, GoalInfo, InstMap0, - MaybePromiseEqvSolutionSets, DetInfo, Detism, - GoalFailingContexts, !Specs), + MaybePromiseEqvSolutionSets, Detism, GoalFailingContexts, + !DetInfo, !Specs), GoalExpr = negation(Goal) ; GoalExpr0 = scope(Reason, Goal0), det_infer_scope(Reason, Goal0, Goal, GoalInfo, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - Detism, GoalFailingContexts, !Specs), + RightFailingContexts, MaybePromiseEqvSolutionSets, Detism, + GoalFailingContexts, !DetInfo, !Specs), GoalExpr = scope(Reason, Goal) ; GoalExpr0 = call_foreign_proc(Attributes, PredId, ProcId, _Args, _ExtraArgs, _MaybeTraceRuntimeCond, PragmaCode), det_infer_foreign_proc(Attributes, PredId, ProcId, PragmaCode, - GoalInfo, SolnContext, RightFailingContexts, DetInfo, Detism, - GoalFailingContexts, !Specs), + GoalInfo, SolnContext, RightFailingContexts, Detism, + GoalFailingContexts, !.DetInfo, !Specs), GoalExpr = GoalExpr0 ; GoalExpr0 = shorthand(_), @@ -631,16 +634,17 @@ det_infer_goal_2(GoalExpr0, GoalExpr, GoalInfo, InstMap0, SolnContext, :- pred det_infer_conj(list(hlds_goal)::in, list(hlds_goal)::out, instmap::in, soln_context::in, list(failing_context)::in, maybe(pess_info)::in, - det_info::in, determinism::out, + determinism::out, list(failing_context)::in, list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. det_infer_conj([], [], _InstMap0, _SolnContext, _RightFailingContexts, - _MaybePromiseEqvSolutionSets, _DetInfo, detism_det, - !ConjFailingContexts, !Specs). + _MaybePromiseEqvSolutionSets, detism_det, + !ConjFailingContexts, !DetInfo, !Specs). det_infer_conj([Goal0 | Goals0], [Goal | Goals], InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, Detism, - !ConjFailingContexts, !Specs) :- + RightFailingContexts, MaybePromiseEqvSolutionSets, Detism, + !ConjFailingContexts, !DetInfo, !Specs) :- % We should look to see when we get to a not_reached point % and optimize away the remaining elements of the conjunction. % But that optimization is done in the code generator anyway. @@ -651,8 +655,8 @@ det_infer_conj([Goal0 | Goals0], [Goal | Goals], InstMap0, SolnContext, % First, process the second and subsequent conjuncts. update_instmap(Goal0, InstMap0, InstMap1), det_infer_conj(Goals0, Goals, InstMap1, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - TailDetism, !ConjFailingContexts, !Specs), + RightFailingContexts, MaybePromiseEqvSolutionSets, + TailDetism, !ConjFailingContexts, !DetInfo, !Specs), determinism_components(TailDetism, TailCanFail, _TailMaxSolns), % Next, work out whether the first conjunct is in a first_soln context @@ -671,8 +675,8 @@ det_infer_conj([Goal0 | Goals0], [Goal | Goals], InstMap0, SolnContext, % Process the first conjunct. det_infer_goal(Goal0, Goal, InstMap0, HeadSolnContext, !.ConjFailingContexts ++ RightFailingContexts, - MaybePromiseEqvSolutionSets, DetInfo, HeadDetism, - GoalFailingContexts, !Specs), + MaybePromiseEqvSolutionSets, HeadDetism, GoalFailingContexts, + !DetInfo, !Specs), % Finally combine the results computed above. det_conjunction_detism(HeadDetism, TailDetism, Detism), @@ -680,16 +684,17 @@ det_infer_conj([Goal0 | Goals0], [Goal | Goals], InstMap0, SolnContext, :- pred det_infer_par_conj(list(hlds_goal)::in, list(hlds_goal)::out, hlds_goal_info::in, instmap::in, soln_context::in, - list(failing_context)::in, maybe(pess_info)::in, det_info::in, + list(failing_context)::in, maybe(pess_info)::in, determinism::out, list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. det_infer_par_conj(Goals0, Goals, GoalInfo, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - Detism, GoalFailingContexts, !Specs) :- + RightFailingContexts, MaybePromiseEqvSolutionSets, + Detism, GoalFailingContexts, !DetInfo, !Specs) :- det_infer_par_conj_goals(Goals0, Goals, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - Detism, [], GoalFailingContexts, !Specs), + RightFailingContexts, MaybePromiseEqvSolutionSets, + Detism, [], GoalFailingContexts, !DetInfo, !Specs), ( determinism_components(Detism, CanFail, Solns), CanFail = cannot_fail, @@ -719,7 +724,7 @@ det_infer_par_conj(Goals0, Goals, GoalInfo, InstMap0, SolnContext, Rest = "The current implementation supports only " ++ "single-solution non-failing parallel conjunctions.", Pieces = [words(First), words(Rest)], - det_diagnose_conj(Goals, detism_det, [], DetInfo, GoalMsgs), + det_diagnose_conj(Goals, InstMap0, detism_det, [], !DetInfo, GoalMsgs), sort_error_msgs(GoalMsgs, SortedGoalMsgs), Spec = error_spec(severity_error, phase_detism_check, [simple_msg(Context, [always(Pieces)])] ++ SortedGoalMsgs), @@ -728,24 +733,25 @@ det_infer_par_conj(Goals0, Goals, GoalInfo, InstMap0, SolnContext, :- pred det_infer_par_conj_goals(list(hlds_goal)::in, list(hlds_goal)::out, instmap::in, soln_context::in, list(failing_context)::in, - maybe(pess_info)::in, det_info::in, determinism::out, + maybe(pess_info)::in, determinism::out, list(failing_context)::in, list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. det_infer_par_conj_goals([], [], _InstMap0, _SolnContext, - _RightFailingContexts, _MaybePromiseEqvSolutionSets, _DetInfo, - detism_det, !ConjFailingContexts, !Specs). + _RightFailingContexts, _MaybePromiseEqvSolutionSets, + detism_det, !ConjFailingContexts, !DetInfo, !Specs). det_infer_par_conj_goals([Goal0 | Goals0], [Goal | Goals], InstMap0, SolnContext, RightFailingContexts, MaybePromiseEqvSolutionSets, - DetInfo, Detism, !ConjFailingContexts, !Specs) :- + Detism, !ConjFailingContexts, !DetInfo, !Specs) :- det_infer_goal(Goal0, Goal, InstMap0, SolnContext, RightFailingContexts, - MaybePromiseEqvSolutionSets, DetInfo, HeadDetism, GoalFailingContexts, - !Specs), + MaybePromiseEqvSolutionSets, HeadDetism, GoalFailingContexts, + !DetInfo, !Specs), determinism_components(HeadDetism, HeadCanFail, HeadMaxSolns), det_infer_par_conj_goals(Goals0, Goals, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - TailDetism, !ConjFailingContexts, !Specs), + RightFailingContexts, MaybePromiseEqvSolutionSets, + TailDetism, !ConjFailingContexts, !DetInfo, !Specs), determinism_components(TailDetism, TailCanFail, TailMaxSolns), det_conjunction_maxsoln(HeadMaxSolns, TailMaxSolns, MaxSolns), @@ -755,16 +761,18 @@ det_infer_par_conj_goals([Goal0 | Goals0], [Goal | Goals], InstMap0, :- pred det_infer_disj(list(hlds_goal)::in, list(hlds_goal)::out, hlds_goal_info::in, instmap::in, soln_context::in, - list(failing_context)::in, maybe(pess_info)::in, det_info::in, + list(failing_context)::in, maybe(pess_info)::in, determinism::out, list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. det_infer_disj(Goals0, Goals, GoalInfo, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - Detism, GoalFailingContexts, !Specs) :- + RightFailingContexts, MaybePromiseEqvSolutionSets, + Detism, GoalFailingContexts, !DetInfo, !Specs) :- det_infer_disj_goals(Goals0, Goals, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - can_fail, at_most_zero, Detism, [], GoalFailingContexts0, !Specs), + RightFailingContexts, MaybePromiseEqvSolutionSets, + can_fail, at_most_zero, Detism, [], GoalFailingContexts0, + !DetInfo, !Specs), ( Goals = [], Context = goal_info_get_context(GoalInfo), @@ -777,20 +785,22 @@ det_infer_disj(Goals0, Goals, GoalInfo, InstMap0, SolnContext, :- pred det_infer_disj_goals(list(hlds_goal)::in, list(hlds_goal)::out, instmap::in, soln_context::in, list(failing_context)::in, - maybe(pess_info)::in, det_info::in, can_fail::in, soln_count::in, + maybe(pess_info)::in, can_fail::in, soln_count::in, determinism::out, list(failing_context)::in, list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. det_infer_disj_goals([], [], _InstMap0, _SolnContext, _RightFailingContexts, - _MaybePromiseEqvSolutionSets, _DetInfo, CanFail, MaxSolns, Detism, - !DisjFailingContexts, !Specs) :- + _MaybePromiseEqvSolutionSets, CanFail, MaxSolns, Detism, + !DisjFailingContexts, !DetInfo, !Specs) :- determinism_components(Detism, CanFail, MaxSolns). det_infer_disj_goals([Goal0 | Goals0], [Goal | Goals], InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - !.CanFail, !.MaxSolns, Detism, !DisjFailingContexts, !Specs) :- + RightFailingContexts, MaybePromiseEqvSolutionSets, + !.CanFail, !.MaxSolns, Detism, !DisjFailingContexts, + !DetInfo, !Specs) :- det_infer_goal(Goal0, Goal, InstMap0, SolnContext, RightFailingContexts, - MaybePromiseEqvSolutionSets, DetInfo, FirstDetism, GoalFailingContexts, - !Specs), + MaybePromiseEqvSolutionSets, FirstDetism, GoalFailingContexts, + !DetInfo, !Specs), determinism_components(FirstDetism, FirstCanFail, FirstMaxSolns), Goal = hlds_goal(_, GoalInfo), % If a disjunct cannot succeed but is marked with the @@ -825,8 +835,8 @@ det_infer_disj_goals([Goal0 | Goals0], [Goal | Goals], InstMap0, SolnContext, true ), det_infer_disj_goals(Goals0, Goals, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - !.CanFail, !.MaxSolns, Detism, !DisjFailingContexts, !Specs), + RightFailingContexts, MaybePromiseEqvSolutionSets, + !.CanFail, !.MaxSolns, Detism, !DisjFailingContexts, !DetInfo, !Specs), !:DisjFailingContexts = GoalFailingContexts ++ !.DisjFailingContexts. %-----------------------------------------------------------------------------% @@ -834,22 +844,23 @@ det_infer_disj_goals([Goal0 | Goals0], [Goal | Goals], InstMap0, SolnContext, :- pred det_infer_switch(prog_var::in, can_fail::in, list(case)::in, list(case)::out, hlds_goal_info::in, instmap::in, soln_context::in, - list(failing_context)::in, maybe(pess_info)::in, det_info::in, + list(failing_context)::in, maybe(pess_info)::in, determinism::out, list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. det_infer_switch(Var, SwitchCanFail, Cases0, Cases, GoalInfo, InstMap0, SolnContext, RightFailingContexts, MaybePromiseEqvSolutionSets, - DetInfo, Detism, GoalFailingContexts, !Specs) :- + Detism, GoalFailingContexts, !DetInfo, !Specs) :- % The determinism of a switch is the worst of the determinism of each % of the cases. Also, if only a subset of the constructors are handled, % then it is semideterministic or worse - this is determined % in switch_detection.m and handled via the SwitchCanFail field. - det_infer_switch_cases(Cases0, Cases, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, + det_infer_switch_cases(Cases0, Cases, Var, InstMap0, SolnContext, + RightFailingContexts, MaybePromiseEqvSolutionSets, cannot_fail, at_most_zero, CasesDetism, [], GoalFailingContexts0, - !Specs), + !DetInfo, !Specs), determinism_components(CasesDetism, CasesCanFail, CasesSolns), % The switch variable tests are in a first_soln context if and only % if the switch goal as a whole was in a first_soln context and the @@ -865,7 +876,7 @@ det_infer_switch(Var, SwitchCanFail, Cases0, Cases, GoalInfo, InstMap0, ExaminesRep = yes, det_check_for_noncanonical_type(Var, ExaminesRep, SwitchCanFail, SwitchSolnContext, GoalFailingContexts0, RightFailingContexts, - GoalInfo, ccuc_switch, DetInfo, SwitchSolns, !Specs), + GoalInfo, ccuc_switch, !.DetInfo, SwitchSolns, !Specs), det_conjunction_canfail(SwitchCanFail, CasesCanFail, CanFail), det_conjunction_maxsoln(SwitchSolns, CasesSolns, NumSolns), determinism_components(Detism, CanFail, NumSolns), @@ -880,45 +891,53 @@ det_infer_switch(Var, SwitchCanFail, Cases0, Cases, GoalInfo, InstMap0, GoalFailingContexts = GoalFailingContexts0 ). -:- pred det_infer_switch_cases(list(case)::in, list(case)::out, instmap::in, - soln_context::in, list(failing_context)::in, maybe(pess_info)::in, - det_info::in, can_fail::in, soln_count::in, determinism::out, - list(failing_context)::in, list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. +:- pred det_infer_switch_cases(list(case)::in, list(case)::out, prog_var::in, + instmap::in, soln_context::in, list(failing_context)::in, + maybe(pess_info)::in, can_fail::in, soln_count::in, + determinism::out, list(failing_context)::in, list(failing_context)::out, + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. -det_infer_switch_cases([], [], _InstMap0, _SolnContext, _RightFailingContexts, - _MaybePromiseEqvSolutionSets, _DetInfo, CanFail, MaxSolns, - Detism, !SwitchFailingContexts, !Specs) :- +det_infer_switch_cases([], [], _Var, _InstMap0, _SolnContext, + _RightFailingContexts, _MaybePromiseEqvSolutionSets, + CanFail, MaxSolns, Detism, !SwitchFailingContexts, !DetInfo, !Specs) :- determinism_components(Detism, CanFail, MaxSolns). -det_infer_switch_cases([Case0 | Cases0], [Case | Cases], InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - !.CanFail, !.MaxSolns, Detism, !SwitchFailingContexts, !Specs) :- +det_infer_switch_cases([Case0 | Cases0], [Case | Cases], Var, InstMap0, + SolnContext, RightFailingContexts, MaybePromiseEqvSolutionSets, + !.CanFail, !.MaxSolns, Detism, !SwitchFailingContexts, + !DetInfo, !Specs) :- % Technically, we should update the instmap to reflect the knowledge that % the var is bound to this particular constructor, but we wouldn't use % that information here anyway, so we don't bother. - Case0 = case(ConsId, Goal0), - det_infer_goal(Goal0, Goal, InstMap0, SolnContext, RightFailingContexts, - MaybePromiseEqvSolutionSets, DetInfo, FirstDetism, GoalFailingContexts, - !Specs), - Case = case(ConsId, Goal), + Case0 = case(MainConsId, OtherConsIds, Goal0), + det_info_get_module_info(!.DetInfo, ModuleInfo0), + det_info_get_vartypes(!.DetInfo, VarTypes), + map.lookup(VarTypes, Var, VarType), + bind_var_to_functors(Var, VarType, MainConsId, OtherConsIds, + InstMap0, InstMap1, ModuleInfo0, ModuleInfo), + det_info_set_module_info(ModuleInfo, !DetInfo), + det_infer_goal(Goal0, Goal, InstMap1, SolnContext, RightFailingContexts, + MaybePromiseEqvSolutionSets, FirstDetism, GoalFailingContexts, + !DetInfo, !Specs), + Case = case(MainConsId, OtherConsIds, Goal), determinism_components(FirstDetism, FirstCanFail, FirstMaxSolns), det_switch_canfail(!.CanFail, FirstCanFail, !:CanFail), det_switch_maxsoln(!.MaxSolns, FirstMaxSolns, !:MaxSolns), - det_infer_switch_cases(Cases0, Cases, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, - !.CanFail, !.MaxSolns, Detism, !SwitchFailingContexts, !Specs), + det_infer_switch_cases(Cases0, Cases, Var, InstMap0, SolnContext, + RightFailingContexts, MaybePromiseEqvSolutionSets, + !.CanFail, !.MaxSolns, Detism, !SwitchFailingContexts, + !DetInfo, !Specs), !:SwitchFailingContexts = GoalFailingContexts ++ !.SwitchFailingContexts. %-----------------------------------------------------------------------------% :- pred det_infer_call(pred_id::in, proc_id::in, proc_id::out, hlds_goal_info::in, soln_context::in, - list(failing_context)::in, det_info::in, determinism::out, - list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + list(failing_context)::in, determinism::out, list(failing_context)::out, + det_info::in, list(error_spec)::in, list(error_spec)::out) is det. det_infer_call(PredId, ProcId0, ProcId, GoalInfo, SolnContext, - RightFailingContexts, DetInfo, Detism, GoalFailingContexts, !Specs) :- + RightFailingContexts, Detism, GoalFailingContexts, DetInfo, !Specs) :- % For calls, just look up the determinism entry associated with % the called predicate. % This is the point at which annotations start changing @@ -979,13 +998,12 @@ det_infer_call(PredId, ProcId0, ProcId, GoalInfo, SolnContext, :- pred det_infer_generic_call(generic_call::in, determinism::in, hlds_goal_info::in, soln_context::in, - list(failing_context)::in, det_info::in, determinism::out, - list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + list(failing_context)::in, determinism::out, list(failing_context)::out, + det_info::in, list(error_spec)::in, list(error_spec)::out) is det. -det_infer_generic_call(GenericCall, CallDetism, - GoalInfo, SolnContext, RightFailingContexts, DetInfo, - Detism, GoalFailingContexts, !Specs) :- +det_infer_generic_call(GenericCall, CallDetism, GoalInfo, + SolnContext, RightFailingContexts, Detism, GoalFailingContexts, + DetInfo, !Specs) :- determinism_components(CallDetism, CanFail, NumSolns), Context = goal_info_get_context(GoalInfo), ( @@ -1026,13 +1044,12 @@ det_infer_generic_call(GenericCall, CallDetism, :- pred det_infer_foreign_proc(pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in, pragma_foreign_code_impl::in, hlds_goal_info::in, soln_context::in, - list(failing_context)::in, det_info::in, determinism::out, - list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + list(failing_context)::in, determinism::out, list(failing_context)::out, + det_info::in, list(error_spec)::in, list(error_spec)::out) is det. det_infer_foreign_proc(Attributes, PredId, ProcId, PragmaCode, - GoalInfo, SolnContext, RightFailingContexts, DetInfo, - Detism, GoalFailingContexts, !Specs) :- + GoalInfo, SolnContext, RightFailingContexts, + Detism, GoalFailingContexts, DetInfo, !Specs) :- % Foreign_procs are handled in the same way as predicate calls. det_info_get_module_info(DetInfo, ModuleInfo), @@ -1127,13 +1144,13 @@ det_infer_foreign_proc(Attributes, PredId, ProcId, PragmaCode, :- pred det_infer_unify(prog_var::in, unify_rhs::in, unification::in, unify_context::in, unify_rhs::out, hlds_goal_info::in, instmap::in, soln_context::in, - list(failing_context)::in, det_info::in, determinism::out, - list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + list(failing_context)::in, determinism::out, list(failing_context)::out, + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. det_infer_unify(LHS, RHS0, Unify, UnifyContext, RHS, GoalInfo, InstMap0, - SolnContext, RightFailingContexts, DetInfo, Detism, - GoalFailingContexts, !Specs) :- + SolnContext, RightFailingContexts, Detism, GoalFailingContexts, + !DetInfo, !Specs) :- % Unifications are either deterministic or semideterministic. ( RHS0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, NonLocalVars, @@ -1143,12 +1160,12 @@ det_infer_unify(LHS, RHS0, Unify, UnifyContext, RHS, GoalInfo, InstMap0, ; LambdaSolnContext = all_solns ), - det_info_get_module_info(DetInfo, ModuleInfo), + det_info_get_module_info(!.DetInfo, ModuleInfo), instmap.pre_lambda_update(ModuleInfo, Vars, Modes, InstMap0, InstMap1), det_infer_goal(Goal0, Goal, InstMap1, LambdaSolnContext, [], - no, DetInfo, LambdaInferredDet, _LambdaFailingContexts, !Specs), + no, LambdaInferredDet, _LambdaFailingContexts, !DetInfo, !Specs), det_check_lambda(LambdaDeclaredDet, LambdaInferredDet, - Goal, GoalInfo, DetInfo, !Specs), + Goal, GoalInfo, InstMap1, !DetInfo, !Specs), RHS = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, NonLocalVars, Vars, Modes, LambdaDeclaredDet, Goal) ; @@ -1161,7 +1178,7 @@ det_infer_unify(LHS, RHS0, Unify, UnifyContext, RHS, GoalInfo, InstMap0, det_infer_unify_examines_rep(Unify, ExaminesRepresentation), det_check_for_noncanonical_type(LHS, ExaminesRepresentation, UnifyCanFail, SolnContext, RightFailingContexts, [], GoalInfo, - ccuc_unify(UnifyContext), DetInfo, UnifyNumSolns, !Specs), + ccuc_unify(UnifyContext), !.DetInfo, UnifyNumSolns, !Specs), determinism_components(Detism, UnifyCanFail, UnifyNumSolns), ( UnifyCanFail = can_fail, @@ -1205,22 +1222,22 @@ det_infer_unify(LHS, RHS0, Unify, UnifyContext, RHS, GoalInfo, InstMap0, :- pred det_infer_if_then_else(hlds_goal::in, hlds_goal::out, hlds_goal::in, hlds_goal::out, hlds_goal::in, hlds_goal::out, instmap::in, soln_context::in, list(failing_context)::in, - maybe(pess_info)::in, det_info::in, determinism::out, - list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + maybe(pess_info)::in, determinism::out, list(failing_context)::out, + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. det_infer_if_then_else(Cond0, Cond, Then0, Then, Else0, Else, InstMap0, SolnContext, RightFailingContexts, MaybePromiseEqvSolutionSets, - DetInfo, Detism, GoalFailingContexts, !Specs) :- + Detism, GoalFailingContexts, !DetInfo, !Specs) :- % We process the goal right-to-left, doing the `then' before the % condition of the if-then-else, so that we can propagate the % SolnContext correctly. - % First process the `then' part + % First process the `then' part. update_instmap(Cond0, InstMap0, InstMap1), det_infer_goal(Then0, Then, InstMap1, SolnContext, RightFailingContexts, - MaybePromiseEqvSolutionSets, DetInfo, ThenDetism, ThenFailingContexts, - !Specs), + MaybePromiseEqvSolutionSets, ThenDetism, ThenFailingContexts, + !DetInfo, !Specs), determinism_components(ThenDetism, ThenCanFail, ThenMaxSoln), % Next, work out the right soln_context to use for the condition. @@ -1237,14 +1254,14 @@ det_infer_if_then_else(Cond0, Cond, Then0, Then, Else0, Else, InstMap0, % Process the `condition' part det_infer_goal(Cond0, Cond, InstMap0, CondSolnContext, ThenFailingContexts ++ RightFailingContexts, - MaybePromiseEqvSolutionSets, DetInfo, - CondDetism, _CondFailingContexts, !Specs), + MaybePromiseEqvSolutionSets, CondDetism, _CondFailingContexts, + !DetInfo, !Specs), determinism_components(CondDetism, CondCanFail, CondMaxSoln), % Process the `else' part det_infer_goal(Else0, Else, InstMap0, SolnContext, RightFailingContexts, - MaybePromiseEqvSolutionSets, DetInfo, ElseDetism, ElseFailingContexts, - !Specs), + MaybePromiseEqvSolutionSets, ElseDetism, ElseFailingContexts, + !DetInfo, !Specs), determinism_components(ElseDetism, ElseCanFail, ElseMaxSoln), % Finally combine the results from the three parts. @@ -1283,12 +1300,13 @@ det_infer_if_then_else(Cond0, Cond, Then0, Then, Else0, Else, InstMap0, GoalFailingContexts = ThenFailingContexts ++ ElseFailingContexts. :- pred det_infer_not(hlds_goal::in, hlds_goal::out, hlds_goal_info::in, - instmap::in, maybe(pess_info)::in, det_info::in, determinism::out, - list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + instmap::in, maybe(pess_info)::in, + determinism::out, list(failing_context)::out, + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. det_infer_not(Goal0, Goal, GoalInfo, InstMap0, MaybePromiseEqvSolutionSets, - DetInfo, Detism, GoalFailingContexts, !Specs) :- + Detism, GoalFailingContexts, !DetInfo, !Specs) :- % Negations are almost always semideterministic. It is an error for % a negation to further instantiate any non-local variable. Such errors % will be reported by the mode analysis. @@ -1297,8 +1315,8 @@ det_infer_not(Goal0, Goal, GoalInfo, InstMap0, MaybePromiseEqvSolutionSets, % cannot succeed or cannot fail? % Answer: yes, probably, but it's not a high priority. det_infer_goal(Goal0, Goal, InstMap0, first_soln, [], - MaybePromiseEqvSolutionSets, DetInfo, NegDetism, _NegatedGoalCanFail, - !Specs), + MaybePromiseEqvSolutionSets, NegDetism, _NegatedGoalCanFail, + !DetInfo, !Specs), det_negation_det(NegDetism, MaybeDetism), ( MaybeDetism = no, @@ -1321,19 +1339,20 @@ det_infer_not(Goal0, Goal, GoalInfo, InstMap0, MaybePromiseEqvSolutionSets, :- pred det_infer_scope(scope_reason::in, hlds_goal::in, hlds_goal::out, hlds_goal_info::in, instmap::in, soln_context::in, - list(failing_context)::in, maybe(pess_info)::in, det_info::in, + list(failing_context)::in, maybe(pess_info)::in, determinism::out, list(failing_context)::out, - list(error_spec)::in, list(error_spec)::out) is det. + det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) + is det. det_infer_scope(Reason, Goal0, Goal, GoalInfo, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets0, DetInfo, Detism, - GoalFailingContexts, !Specs) :- + RightFailingContexts, MaybePromiseEqvSolutionSets0, Detism, + GoalFailingContexts, !DetInfo, !Specs) :- % Existential quantification may require a cut to throw away solutions, % but we cannot rely on explicit quantification to detect this. % Therefore cuts are handled in det_infer_goal. ( Reason = promise_solutions(Vars, Kind), - det_get_proc_info(DetInfo, ProcInfo), + det_get_proc_info(!.DetInfo, ProcInfo), proc_info_get_varset(ProcInfo, VarSet), Context = goal_info_get_context(GoalInfo), @@ -1423,7 +1442,7 @@ det_infer_scope(Reason, Goal0, Goal, GoalInfo, InstMap0, SolnContext, ), InstmapDelta = goal_info_get_instmap_delta(GoalInfo), instmap_delta_changed_vars(InstmapDelta, ChangedVars), - det_info_get_module_info(DetInfo, ModuleInfo), + det_info_get_module_info(!.DetInfo, ModuleInfo), % BoundVars must include both vars whose inst has changed and vars % with inst any which may have been further constrained by the goal. set.divide(var_is_ground_in_instmap(ModuleInfo, InstMap0), @@ -1496,13 +1515,13 @@ det_infer_scope(Reason, Goal0, Goal, GoalInfo, InstMap0, SolnContext, !:Specs = [ExtraSpec | !.Specs] ), det_infer_goal(Goal0, Goal, InstMap0, SolnContextToUse, - RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo, Detism, - GoalFailingContexts, !Specs) + RightFailingContexts, MaybePromiseEqvSolutionSets, Detism, + GoalFailingContexts, !DetInfo, !Specs) ; Reason = trace_goal(_, _, _, _, _), det_infer_goal(Goal0, Goal, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets0, DetInfo, - Detism, GoalFailingContexts, !Specs), + RightFailingContexts, MaybePromiseEqvSolutionSets0, + Detism, GoalFailingContexts, !DetInfo, !Specs), ( ( Detism = detism_det ; Detism = detism_cc_multi @@ -1527,8 +1546,8 @@ det_infer_scope(Reason, Goal0, Goal, GoalInfo, InstMap0, SolnContext, ; Reason = from_ground_term(_) ), det_infer_goal(Goal0, Goal, InstMap0, SolnContext, - RightFailingContexts, MaybePromiseEqvSolutionSets0, DetInfo, - Detism, GoalFailingContexts, !Specs) + RightFailingContexts, MaybePromiseEqvSolutionSets0, + Detism, GoalFailingContexts, !DetInfo, !Specs) ). %-----------------------------------------------------------------------------% @@ -1642,8 +1661,8 @@ det_check_for_noncanonical_type(Var, ExaminesRepresentation, CanFail, suffix(":"), nl] ; GoalContext = ccuc_unify(UnifyContext), - unify_context_first_to_pieces(yes, _, UnifyContext, [], - Pieces0) + unify_context_first_to_pieces(is_first, _, + UnifyContext, [], Pieces0) ), ( Pieces0 = [], diff --git a/compiler/det_report.m b/compiler/det_report.m index 9d9506525..947580263 100644 --- a/compiler/det_report.m +++ b/compiler/det_report.m @@ -23,6 +23,7 @@ :- import_module hlds.hlds_goal. :- import_module hlds.hlds_module. :- import_module hlds.hlds_pred. +:- import_module hlds.instmap. :- import_module libs.globals. :- import_module parse_tree. :- import_module parse_tree.error_util. @@ -65,26 +66,30 @@ % Check all the determinism declarations in this module. % This is the main predicate exported by this module. % -:- pred global_checking_pass(pred_proc_list::in, module_info::in, +:- pred global_checking_pass(pred_proc_list::in, + module_info::in, module_info::out, list(error_spec)::in, list(error_spec)::out) is det. % Check a lambda goal with the specified declared and inferred % determinisms. % :- pred det_check_lambda(determinism::in, determinism::in, hlds_goal::in, - hlds_goal_info::in, det_info::in, + hlds_goal_info::in, instmap::in, det_info::in, det_info::out, list(error_spec)::in, list(error_spec)::out) is det. - % det_diagnose_conj(Goals, Desired, FailingContexts, DetInfo, Msgs): + % det_diagnose_conj(Goals, InstMap0, Desired, FailingContexts, DetInfo, + % Msgs): % - % The conjunction Goals should have determinism Desired, but doesn't. - % Find out what is wrong, and return a list of messages giving the causes. + % The conjunction Goals with initial instmap InstMap0 should have + % determinism Desired, but doesn't. Find out what is wrong, and return + % a list of messages giving the causes. % % det_diagnose_conj is used for both normal [sequential] conjunctions % and parallel conjunctions. % -:- pred det_diagnose_conj(list(hlds_goal)::in, determinism::in, - list(switch_context)::in, det_info::in, list(error_msg)::out) is det. +:- pred det_diagnose_conj(list(hlds_goal)::in, instmap::in, determinism::in, + list(switch_context)::in, det_info::in, det_info::out, + list(error_msg)::out) is det. % Return a printable representation of the given promise_solutions_kind. % @@ -132,7 +137,9 @@ :- implementation. +:- import_module check_hlds.inst_match. :- import_module check_hlds.mode_util. +:- import_module hlds.goal_util. :- import_module hlds.hlds_data. :- import_module hlds.hlds_error_util. :- import_module hlds.hlds_out. @@ -143,6 +150,7 @@ :- import_module mdbcomp.prim_data. :- import_module mdbcomp.prim_data. :- import_module parse_tree.mercury_to_mercury. +:- import_module parse_tree.prog_mode. :- import_module parse_tree.prog_out. :- import_module parse_tree.prog_util. @@ -153,6 +161,7 @@ :- import_module map. :- import_module maybe. :- import_module pair. +:- import_module set_tree234. :- import_module solutions. :- import_module string. :- import_module term. @@ -160,22 +169,22 @@ %-----------------------------------------------------------------------------% -global_checking_pass([], _, !Specs). -global_checking_pass([proc(PredId, ProcId) | Rest], ModuleInfo, !Specs) :- - module_info_pred_proc_info(ModuleInfo, PredId, ProcId, +global_checking_pass([], !ModuleInfo, !Specs). +global_checking_pass([Proc | Procs], !ModuleInfo, !Specs) :- + Proc = proc(PredId, ProcId), + module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId, PredInfo, ProcInfo), - check_determinism(PredId, ProcId, PredInfo, ProcInfo, ModuleInfo, !Specs), - check_determinism_of_main(PredId, ProcId, PredInfo, ProcInfo, + check_determinism(PredId, ProcId, PredInfo, ProcInfo, !ModuleInfo, !Specs), + check_determinism_of_main(PredId, ProcId, PredInfo, ProcInfo, !Specs), + check_for_multisoln_func(PredId, ProcId, PredInfo, ProcInfo, !.ModuleInfo, !Specs), - check_for_multisoln_func(PredId, ProcId, PredInfo, ProcInfo, ModuleInfo, - !Specs), - global_checking_pass(Rest, ModuleInfo, !Specs). + global_checking_pass(Procs, !ModuleInfo, !Specs). :- pred check_determinism(pred_id::in, proc_id::in, pred_info::in, - proc_info::in, module_info::in, + proc_info::in, module_info::in, module_info::out, list(error_spec)::in, list(error_spec)::out) is det. -check_determinism(PredId, ProcId, PredInfo0, ProcInfo0, ModuleInfo, !Specs) :- +check_determinism(PredId, ProcId, PredInfo0, ProcInfo0, !ModuleInfo, !Specs) :- proc_info_get_declared_determinism(ProcInfo0, MaybeDetism), proc_info_get_inferred_determinism(ProcInfo0, InferredDetism), ( @@ -187,7 +196,7 @@ check_determinism(PredId, ProcId, PredInfo0, ProcInfo0, ModuleInfo, !Specs) :- Cmp = sameas ; Cmp = looser, - module_info_get_globals(ModuleInfo, Globals), + module_info_get_globals(!.ModuleInfo, Globals), globals.lookup_bool_option(Globals, warn_det_decls_too_lax, ShouldIssueWarning), globals.lookup_bool_option(Globals, warn_inferred_erroneous, @@ -230,7 +239,7 @@ check_determinism(PredId, ProcId, PredInfo0, ProcInfo0, ModuleInfo, !Specs) :- -> Message = "warning: determinism declaration " ++ "could be tighter.\n", - report_determinism_problem(PredId, ProcId, ModuleInfo, + report_determinism_problem(PredId, ProcId, !.ModuleInfo, Message, DeclaredDetism, InferredDetism, ReportMsgs), ReportSpec = error_spec(severity_warning, phase_detism_check, ReportMsgs), @@ -241,12 +250,15 @@ check_determinism(PredId, ProcId, PredInfo0, ProcInfo0, ModuleInfo, !Specs) :- ; Cmp = tighter, Message = "error: determinism declaration not satisfied.\n", - report_determinism_problem(PredId, ProcId, ModuleInfo, Message, + report_determinism_problem(PredId, ProcId, !.ModuleInfo, Message, DeclaredDetism, InferredDetism, ReportMsgs), proc_info_get_goal(ProcInfo0, Goal), proc_info_get_vartypes(ProcInfo0, VarTypes), - det_info_init(ModuleInfo, VarTypes, PredId, ProcId, DetInfo), - det_diagnose_goal(Goal, DeclaredDetism, [], DetInfo, GoalMsgs0), + proc_info_get_initial_instmap(ProcInfo0, !.ModuleInfo, InstMap0), + det_info_init(!.ModuleInfo, VarTypes, PredId, ProcId, DetInfo0), + det_diagnose_goal(Goal, InstMap0, DeclaredDetism, [], + DetInfo0, DetInfo, GoalMsgs0), + det_info_get_module_info(DetInfo, !:ModuleInfo), sort_error_msgs(GoalMsgs0, GoalMsgs), ReportSpec = error_spec(severity_error, phase_detism_check, ReportMsgs ++ GoalMsgs), @@ -391,15 +403,15 @@ func_primary_mode_det_msg = [ words("Most likely, this procedure should be a predicate, not a function.") ]. -det_check_lambda(DeclaredDetism, InferredDetism, Goal, GoalInfo, DetInfo, - !Specs) :- +det_check_lambda(DeclaredDetism, InferredDetism, Goal, GoalInfo, InstMap0, + !DetInfo, !Specs) :- compare_determinisms(DeclaredDetism, InferredDetism, Cmp), ( Cmp = tighter, - det_info_get_pred_id(DetInfo, PredId), - det_info_get_proc_id(DetInfo, ProcId), + det_info_get_pred_id(!.DetInfo, PredId), + det_info_get_proc_id(!.DetInfo, ProcId), Context = goal_info_get_context(GoalInfo), - det_info_get_module_info(DetInfo, ModuleInfo), + det_info_get_module_info(!.DetInfo, ModuleInfo), PredPieces = describe_one_proc_name_mode(ModuleInfo, should_not_module_qualify, proc(PredId, ProcId)), Pieces = @@ -409,7 +421,8 @@ det_check_lambda(DeclaredDetism, InferredDetism, Goal, GoalInfo, DetInfo, quote(determinism_to_string(DeclaredDetism)), suffix(","), words("inferred"), quote(determinism_to_string(InferredDetism)), suffix("'.")], - det_diagnose_goal(Goal, DeclaredDetism, [], DetInfo, GoalMsgs), + det_diagnose_goal(Goal, InstMap0, DeclaredDetism, [], !DetInfo, + GoalMsgs), sort_error_msgs(GoalMsgs, SortedGoalMsgs), Spec = error_spec(severity_error, phase_detism_check, [simple_msg(Context, [always(Pieces)])] ++ SortedGoalMsgs), @@ -496,173 +509,187 @@ compare_solncounts(at_most_many, at_most_many, sameas). % The given goal should have determinism Desired, but doesn't. % Find out what is wrong, and return a list of messages giving the causes. % -:- pred det_diagnose_goal(hlds_goal::in, determinism::in, - list(switch_context)::in, det_info::in, list(error_msg)::out) is det. +:- pred det_diagnose_goal(hlds_goal::in, instmap::in, determinism::in, + list(switch_context)::in, det_info::in, det_info::out, + list(error_msg)::out) is det. -det_diagnose_goal(hlds_goal(GoalExpr, GoalInfo), Desired, SwitchContext, - DetInfo, Msgs) :- +det_diagnose_goal(Goal, InstMap0, Desired, SwitchContexts, !DetInfo, Msgs) :- + Goal = hlds_goal(GoalExpr, GoalInfo), Actual = goal_info_get_determinism(GoalInfo), ( compare_determinisms(Desired, Actual, tighter) -> - det_diagnose_goal_2(GoalExpr, GoalInfo, Desired, Actual, SwitchContext, - DetInfo, Msgs) + det_diagnose_goal_expr(GoalExpr, GoalInfo, InstMap0, Desired, Actual, + SwitchContexts, !DetInfo, Msgs) ; Msgs = [] ). %-----------------------------------------------------------------------------% -:- pred det_diagnose_goal_2(hlds_goal_expr::in, hlds_goal_info::in, - determinism::in, determinism::in, list(switch_context)::in, - det_info::in, list(error_msg)::out) is det. +:- pred det_diagnose_goal_expr(hlds_goal_expr::in, hlds_goal_info::in, + instmap::in, determinism::in, determinism::in, list(switch_context)::in, + det_info::in, det_info::out, list(error_msg)::out) is det. -det_diagnose_goal_2(conj(_, Goals), _GoalInfo, Desired, _Actual, Context, - DetInfo, Msgs) :- - det_diagnose_conj(Goals, Desired, Context, DetInfo, Msgs). - -det_diagnose_goal_2(disj(Goals), GoalInfo, Desired, Actual, SwitchContext, - DetInfo, Msgs) :- - det_diagnose_disj(Goals, Desired, Actual, SwitchContext, DetInfo, 0, - ClausesWithSoln, Msgs1), - determinism_components(Desired, _, DesSolns), +det_diagnose_goal_expr(GoalExpr, GoalInfo, InstMap0, Desired, Actual, + SwitchContexts, !DetInfo, Msgs) :- ( - DesSolns \= at_most_many, - DesSolns \= at_most_many_cc, - ClausesWithSoln > 1 - -> - Context = goal_info_get_context(GoalInfo), - Pieces = [words("Disjunction has multiple clauses with solutions.")], - Msg = simple_msg(Context, [always(Pieces)]), - Msgs = [Msg] ++ Msgs1 + GoalExpr = conj(_, Goals), + det_diagnose_conj(Goals, InstMap0, Desired, SwitchContexts, !DetInfo, + Msgs) ; - Msgs = Msgs1 - ). - - % The determinism of a switch is the worst of the determinism of each of - % the cases. Also, if only a subset of the constructors are handled, - % then it is semideterministic or worse - this is determined - % in switch_detection.m and handled via the CanFail field. - % -det_diagnose_goal_2(switch(Var, SwitchCanFail, Cases), GoalInfo, - Desired, _Actual, SwitchContext, DetInfo, Msgs) :- - ( - SwitchCanFail = can_fail, - determinism_components(Desired, cannot_fail, _) - -> - Context = goal_info_get_context(GoalInfo), - det_diagnose_switch_context(SwitchContext, DetInfo, NestingPieces), - det_get_proc_info(DetInfo, ProcInfo), - proc_info_get_varset(ProcInfo, VarSet), - det_info_get_module_info(DetInfo, ModuleInfo), - VarStr = mercury_var_to_string(VarSet, no, Var), + GoalExpr = disj(Goals), + det_diagnose_disj(Goals, InstMap0, Desired, Actual, SwitchContexts, + !DetInfo, 0, ClausesWithSoln, Msgs1), + determinism_components(Desired, _, DesSolns), ( - det_lookup_var_type(ModuleInfo, ProcInfo, Var, TypeDefn), - hlds_data.get_type_defn_body(TypeDefn, TypeBody), - ConsTable = TypeBody ^ du_type_cons_tag_values + DesSolns \= at_most_many, + DesSolns \= at_most_many_cc, + ClausesWithSoln > 1 -> - map.keys(ConsTable, ConsIds), - det_diagnose_missing_consids(ConsIds, Cases, Missing), - cons_id_list_to_pieces(Missing, MissingPieces), - Pieces = [words("The switch on "), fixed(VarStr), - words("does not cover") | MissingPieces] + Context = goal_info_get_context(GoalInfo), + Pieces = + [words("Disjunction has multiple clauses with solutions.")], + Msg = simple_msg(Context, [always(Pieces)]), + Msgs = [Msg] ++ Msgs1 ; - Pieces = [words("The switch on "), fixed(VarStr), - words("can fail.")] + Msgs = Msgs1 + ) + ; + GoalExpr = switch(Var, SwitchCanFail, Cases), + % The determinism of a switch is the worst of the determinism of each + % of the cases. Also, if only a subset of the constructors are handled, + % then it is semideterministic or worse - this is determined + % in switch_detection.m and handled via the CanFail field. + ( + SwitchCanFail = can_fail, + determinism_components(Desired, cannot_fail, _) + -> + Context = goal_info_get_context(GoalInfo), + det_diagnose_switch_context(SwitchContexts, !.DetInfo, + NestingPieces), + det_get_proc_info(!.DetInfo, ProcInfo), + proc_info_get_varset(ProcInfo, VarSet), + VarStr = mercury_var_to_string(VarSet, no, Var), + det_info_get_module_info(!.DetInfo, ModuleInfo), + ( + ( + instmap.lookup_var(InstMap0, Var, VarInst), + inst_is_bound_to_functors(ModuleInfo, VarInst, Functors) + -> + functors_to_cons_ids(Functors, ConsIds) + ; + det_lookup_var_type(ModuleInfo, ProcInfo, Var, TypeDefn), + hlds_data.get_type_defn_body(TypeDefn, TypeBody), + ConsTable = TypeBody ^ du_type_cons_tag_values, + map.keys(ConsTable, ConsIds) + ) + -> + % XXX If the current instmap has an entry giving the set of + % possible bindings for Var, we should restrict ConsIds + % to the functors that appear in it. + det_diagnose_missing_consids(ConsIds, Cases, MissingConsIds), + cons_id_list_to_pieces(MissingConsIds, MissingPieces), + Pieces = [words("The switch on"), fixed(VarStr), + words("does not cover") | MissingPieces] + ; + Pieces = [words("The switch on"), fixed(VarStr), + words("can fail.")] + ), + Msgs1 = [simple_msg(Context, [always(NestingPieces ++ Pieces)])] + ; + Msgs1 = [] ), - Msgs1 = [simple_msg(Context, [always(NestingPieces ++ Pieces)])] + det_diagnose_switch_arms(Var, Cases, InstMap0, Desired, SwitchContexts, + !DetInfo, Msgs2), + Msgs = Msgs1 ++ Msgs2 ; - Msgs1 = [] - ), - det_diagnose_switch(Var, Cases, Desired, SwitchContext, DetInfo, Msgs2), - Msgs = Msgs1 ++ Msgs2. - -det_diagnose_goal_2(plain_call(PredId, ProcId, _, _, CallContext, _), GoalInfo, - Desired, Actual, _, DetInfo, Msgs) :- - Context = goal_info_get_context(GoalInfo), - det_report_call_context(Context, CallContext, DetInfo, PredId, ProcId, - InitMsgs, StartingPieces), - det_diagnose_atomic_goal(Desired, Actual, Context, StartingPieces, - AtomicMsgs), - Msgs = InitMsgs ++ AtomicMsgs. - -det_diagnose_goal_2(generic_call(GenericCall, _, _, _), GoalInfo, - Desired, Actual, _, _DetInfo, Msgs) :- - Context = goal_info_get_context(GoalInfo), - report_generic_call_context(GenericCall, StartingPieces), - det_diagnose_atomic_goal(Desired, Actual, Context, StartingPieces, Msgs). - -det_diagnose_goal_2(unify(LHS, RHS, _, _, UnifyContext), GoalInfo, - Desired, Actual, _, DetInfo, Msgs) :- - Context = goal_info_get_context(GoalInfo), - First = yes, - Last = yes, - det_report_unify_context(First, Last, Context, UnifyContext, - DetInfo, LHS, RHS, StartingPieces), - det_diagnose_atomic_goal(Desired, Actual, Context, StartingPieces, Msgs). - -det_diagnose_goal_2(if_then_else(_Vars, Cond, Then, Else), _GoalInfo, - Desired, _Actual, SwitchContext, DetInfo, Msgs) :- - determinism_components(Desired, _DesiredCanFail, DesiredSolns), - Cond = hlds_goal(_CondGoal, CondInfo), - CondDetism = goal_info_get_determinism(CondInfo), - determinism_components(CondDetism, _CondCanFail, CondSolns), - ( - CondSolns = at_most_many, - DesiredSolns \= at_most_many - -> - determinism_components(DesiredCond, can_fail, DesiredSolns), - det_diagnose_goal(Cond, DesiredCond, SwitchContext, DetInfo, Msgs1) - ; - Msgs1 = [] - ), - det_diagnose_goal(Then, Desired, SwitchContext, DetInfo, Msgs2), - det_diagnose_goal(Else, Desired, SwitchContext, DetInfo, Msgs3), - Msgs = Msgs1 ++ Msgs2 ++ Msgs3. - -det_diagnose_goal_2(negation(_), GoalInfo, Desired, Actual, _, _, Msgs) :- - determinism_components(Desired, DesiredCanFail, DesiredSolns), - determinism_components(Actual, ActualCanFail, ActualSolns), - ( - DesiredCanFail = cannot_fail, - ActualCanFail = can_fail - -> + GoalExpr = plain_call(PredId, ProcId, _, _, CallContext, _), Context = goal_info_get_context(GoalInfo), - Pieces = [words("Negated goal can succeed.")], + det_report_call_context(Context, CallContext, !.DetInfo, + PredId, ProcId, InitMsgs, StartingPieces), + det_diagnose_atomic_goal(Desired, Actual, Context, StartingPieces, + AtomicMsgs), + Msgs = InitMsgs ++ AtomicMsgs + ; + GoalExpr = generic_call(GenericCall, _, _, _), + Context = goal_info_get_context(GoalInfo), + report_generic_call_context(GenericCall, StartingPieces), + det_diagnose_atomic_goal(Desired, Actual, Context, StartingPieces, + Msgs) + ; + GoalExpr = unify(LHS, RHS, _, _, UnifyContext), + Context = goal_info_get_context(GoalInfo), + det_report_unify_context(is_first, is_last, Context, UnifyContext, + !.DetInfo, LHS, RHS, StartingPieces), + det_diagnose_atomic_goal(Desired, Actual, Context, StartingPieces, + Msgs) + ; + GoalExpr = if_then_else(_Vars, Cond, Then, Else), + determinism_components(Desired, _DesiredCanFail, DesiredSolns), + Cond = hlds_goal(_CondGoal, CondInfo), + CondDetism = goal_info_get_determinism(CondInfo), + determinism_components(CondDetism, _CondCanFail, CondSolns), + ( + CondSolns = at_most_many, + DesiredSolns \= at_most_many + -> + determinism_components(DesiredCond, can_fail, DesiredSolns), + det_diagnose_goal(Cond, InstMap0, DesiredCond, SwitchContexts, + !DetInfo, MsgsCond) + ; + MsgsCond = [] + ), + update_instmap(Cond, InstMap0, InstMap1), + det_diagnose_goal(Then, InstMap1, Desired, SwitchContexts, !DetInfo, + MsgsThen), + det_diagnose_goal(Else, InstMap0, Desired, SwitchContexts, !DetInfo, + MsgsElse), + Msgs = MsgsCond ++ MsgsThen ++ MsgsElse + ; + GoalExpr = negation(_), + determinism_components(Desired, DesiredCanFail, DesiredSolns), + determinism_components(Actual, ActualCanFail, ActualSolns), + ( + DesiredCanFail = cannot_fail, + ActualCanFail = can_fail + -> + Context = goal_info_get_context(GoalInfo), + Pieces = [words("Negated goal can succeed.")], + Msgs = [simple_msg(Context, [always(Pieces)])] + ; + DesiredSolns = at_most_zero, + ActualSolns \= at_most_zero + -> + Context = goal_info_get_context(GoalInfo), + Pieces = [words("Negated goal can fail.")], + Msgs = [simple_msg(Context, [always(Pieces)])] + ; + Msgs = [] + ) + ; + GoalExpr = scope(_, SubGoal), + SubGoal = hlds_goal(_, SubGoalInfo), + Internal = goal_info_get_determinism(SubGoalInfo), + ( Actual = Internal -> + InternalDesired = Desired + ; + determinism_components(Desired, CanFail, _), + determinism_components(InternalDesired, CanFail, at_most_many) + ), + det_diagnose_goal(SubGoal, InstMap0, InternalDesired, SwitchContexts, + !DetInfo, Msgs) + ; + GoalExpr = call_foreign_proc(_, _, _, _, _, _, _), + Context = goal_info_get_context(GoalInfo), + DesiredStr = determinism_to_string(Desired), + Pieces = [words("Determinism declaration not satisfied."), + words("Desired determinism is " ++ DesiredStr ++ ".")], Msgs = [simple_msg(Context, [always(Pieces)])] ; - DesiredSolns = at_most_zero, - ActualSolns \= at_most_zero - -> - Context = goal_info_get_context(GoalInfo), - Pieces = [words("Negated goal can fail.")], - Msgs = [simple_msg(Context, [always(Pieces)])] - ; - Msgs = [] + GoalExpr = shorthand(_), + % These should have been expanded out by now. + unexpected(this_file, "det_diagnose_goal_expr: unexpected shorthand") ). -det_diagnose_goal_2(scope(_, Goal), _, Desired, Actual, SwitchContext, DetInfo, - Msgs) :- - Goal = hlds_goal(_, GoalInfo), - Internal = goal_info_get_determinism(GoalInfo), - ( Actual = Internal -> - InternalDesired = Desired - ; - determinism_components(Desired, CanFail, _), - determinism_components(InternalDesired, CanFail, at_most_many) - ), - det_diagnose_goal(Goal, InternalDesired, SwitchContext, DetInfo, Msgs). - -det_diagnose_goal_2(call_foreign_proc(_, _, _, _, _, _, _), GoalInfo, Desired, - _, _, _, Msgs) :- - Context = goal_info_get_context(GoalInfo), - DesiredStr = determinism_to_string(Desired), - Pieces = [words("Determinism declaration not satisfied."), - words("Desired determinism is " ++ DesiredStr ++ ".")], - Msgs = [simple_msg(Context, [always(Pieces)])]. - -det_diagnose_goal_2(shorthand(_), _, _, _, _, _, []) :- - % These should have been expanded out by now. - unexpected(this_file, "det_diagnose_goal_2: unexpected shorthand"). - %-----------------------------------------------------------------------------% :- pred report_generic_call_context(generic_call::in, @@ -731,20 +758,25 @@ det_diagnose_atomic_goal(Desired, Actual, Context, StartingPieces, Msgs) :- ), Msgs = [simple_msg(Context, [always(StartingPieces ++ Pieces)])]. -det_diagnose_conj([], _Desired, _SwitchContext, _DetInfo, []). -det_diagnose_conj([Goal | Goals], Desired, SwitchContext, DetInfo, Msgs) :- - det_diagnose_goal(Goal, Desired, SwitchContext, DetInfo, Msgs1), - det_diagnose_conj(Goals, Desired, SwitchContext, DetInfo, Msgs2), +det_diagnose_conj([], _InstMap0, _Desired, _SwitchContexts, !DetInfo, []). +det_diagnose_conj([Goal | Goals], InstMap0, Desired, SwitchContexts, !DetInfo, + Msgs) :- + det_diagnose_goal(Goal, InstMap0, Desired, SwitchContexts, !DetInfo, + Msgs1), + update_instmap(Goal, InstMap0, InstMap1), + det_diagnose_conj(Goals, InstMap1, Desired, SwitchContexts, !DetInfo, + Msgs2), Msgs = Msgs1 ++ Msgs2. -:- pred det_diagnose_disj(list(hlds_goal)::in, +:- pred det_diagnose_disj(list(hlds_goal)::in, instmap::in, determinism::in, determinism::in, list(switch_context)::in, - det_info::in, int::in, int::out, list(error_msg)::out) is det. + det_info::in, det_info::out, int::in, int::out, list(error_msg)::out) + is det. -det_diagnose_disj([], _Desired, _Actual, _SwitchContext, _DetInfo, - !ClausesWithSoln, []). -det_diagnose_disj([Goal | Goals], Desired, Actual, SwitchContext, DetInfo, - !ClausesWithSoln, Msgs) :- +det_diagnose_disj([], _InstMap0, _Desired, _Actual, _SwitchContexts, + !DetInfo, !ClausesWithSoln, []). +det_diagnose_disj([Goal | Goals], InstMap0, Desired, Actual, SwitchContexts, + !DetInfo, !ClausesWithSoln, Msgs) :- determinism_components(Actual, ActualCanFail, _), determinism_components(Desired, DesiredCanFail, DesiredSolns), ( @@ -762,7 +794,8 @@ det_diagnose_disj([Goal | Goals], Desired, Actual, SwitchContext, DetInfo, ClauseCanFail = can_fail ), determinism_components(ClauseDesired, ClauseCanFail, DesiredSolns), - det_diagnose_goal(Goal, ClauseDesired, SwitchContext, DetInfo, Msgs1), + det_diagnose_goal(Goal, InstMap0, ClauseDesired, SwitchContexts, !DetInfo, + Msgs1), ( Goal = hlds_goal(_, GoalInfo), GoalDetism = goal_info_get_determinism(GoalInfo), @@ -772,19 +805,30 @@ det_diagnose_disj([Goal | Goals], Desired, Actual, SwitchContext, DetInfo, ; !:ClausesWithSoln = !.ClausesWithSoln + 1 ), - det_diagnose_disj(Goals, Desired, Actual, SwitchContext, DetInfo, - !ClausesWithSoln, Msgs2), + det_diagnose_disj(Goals, InstMap0, Desired, Actual, SwitchContexts, + !DetInfo, !ClausesWithSoln, Msgs2), Msgs = Msgs1 ++ Msgs2. -:- pred det_diagnose_switch(prog_var::in, list(case)::in, determinism::in, - list(switch_context)::in, det_info::in, list(error_msg)::out) is det. +:- pred det_diagnose_switch_arms(prog_var::in, list(case)::in, instmap::in, + determinism::in, list(switch_context)::in, det_info::in, det_info::out, + list(error_msg)::out) is det. -det_diagnose_switch(_Var, [], _Desired, _SwitchContext, _DetInfo, []). -det_diagnose_switch(Var, [case(ConsId, Goal) | Cases], Desired, - SwitchContext0, DetInfo, Msgs) :- - SwitchContext1 = [switch_context(Var, ConsId) | SwitchContext0], - det_diagnose_goal(Goal, Desired, SwitchContext1, DetInfo, Msgs1), - det_diagnose_switch(Var, Cases, Desired, SwitchContext0, DetInfo, Msgs2), +det_diagnose_switch_arms(_Var, [], _, _Desired, _SwitchContexts, !DetInfo, []). +det_diagnose_switch_arms(Var, [Case | Cases], InstMap0, Desired, + SwitchContexts0, !DetInfo, Msgs) :- + Case = case(MainConsId, OtherConsIds, Goal), + NewSwitchContext = switch_context(Var, MainConsId, OtherConsIds), + SwitchContexts1 = [NewSwitchContext | SwitchContexts0], + det_info_get_vartypes(!.DetInfo, VarTypes), + map.lookup(VarTypes, Var, VarType), + det_info_get_module_info(!.DetInfo, ModuleInfo0), + bind_var_to_functors(Var, VarType, MainConsId, OtherConsIds, + InstMap0, InstMap1, ModuleInfo0, ModuleInfo), + det_info_set_module_info(ModuleInfo, !DetInfo), + det_diagnose_goal(Goal, InstMap1, Desired, SwitchContexts1, + !DetInfo, Msgs1), + det_diagnose_switch_arms(Var, Cases, InstMap0, Desired, SwitchContexts0, + !DetInfo, Msgs2), Msgs = Msgs1 ++ Msgs2. %-----------------------------------------------------------------------------% @@ -792,17 +836,33 @@ det_diagnose_switch(Var, [case(ConsId, Goal) | Cases], Desired, :- pred det_diagnose_missing_consids(list(cons_id)::in, list(case)::in, list(cons_id)::out) is det. -det_diagnose_missing_consids([], _, []). -det_diagnose_missing_consids([ConsId | ConsIds], Cases, Missing) :- - det_diagnose_missing_consids(ConsIds, Cases, Missing0), - ( - list.member(Case, Cases), - Case = case(ConsId, _) - -> - Missing = Missing0 +det_diagnose_missing_consids(ConsIds, Cases, MissingConsIds) :- + compute_covered_cons_ids(Cases, set_tree234.init, CoveredConsIds), + find_uncovered_consids(ConsIds, CoveredConsIds, [], RevMissingConsIds), + list.reverse(RevMissingConsIds, MissingConsIds). + +:- pred find_uncovered_consids(list(cons_id)::in, set_tree234(cons_id)::in, + list(cons_id)::in, list(cons_id)::out) is det. + +find_uncovered_consids([], _, !RevMissingConsIds). +find_uncovered_consids([ConsId | ConsIds], CoveredConsIds, + !RevMissingConsIds) :- + ( set_tree234.member(CoveredConsIds, ConsId) -> + true ; - Missing = [ConsId | Missing0] - ). + !:RevMissingConsIds = [ConsId | !.RevMissingConsIds] + ), + find_uncovered_consids(ConsIds, CoveredConsIds, !RevMissingConsIds). + +:- pred compute_covered_cons_ids(list(case)::in, + set_tree234(cons_id)::in, set_tree234(cons_id)::out) is det. + +compute_covered_cons_ids([], !CoveredConsIds). +compute_covered_cons_ids([Case | Cases], !CoveredConsIds) :- + Case = case(MainConsId, OtherConsIds, _Goal), + set_tree234.insert(MainConsId, !CoveredConsIds), + set_tree234.insert_list(OtherConsIds, !CoveredConsIds), + compute_covered_cons_ids(Cases, !CoveredConsIds). :- pred cons_id_list_to_pieces(list(cons_id)::in, list(format_component)::out) is det. @@ -826,7 +886,11 @@ cons_id_list_to_pieces([ConsId | ConsIds], Pieces) :- %-----------------------------------------------------------------------------% :- type switch_context - ---> switch_context(prog_var, cons_id). + ---> switch_context( + prog_var, % The variable being switched on. + cons_id, % The first cons_id of this case. + list(cons_id) % Any other cons_ids of this case. + ). :- pred det_diagnose_switch_context(list(switch_context)::in, det_info::in, list(format_component)::out) is det. @@ -836,10 +900,12 @@ det_diagnose_switch_context([SwitchContext | SwitchContexts], DetInfo, HeadPieces ++ TailPieces) :- det_get_proc_info(DetInfo, ProcInfo), proc_info_get_varset(ProcInfo, VarSet), - SwitchContext = switch_context(Var, ConsId), - ConsIdStr = cons_id_to_string(ConsId), + SwitchContext = switch_context(Var, MainConsId, OtherConsIds), + MainConsIdStr = cons_id_to_string(MainConsId), + OtherConsIdStrs = list.map(cons_id_to_string, OtherConsIds), + ConsIdsStr = string.join_list(", ", [MainConsIdStr | OtherConsIdStrs]), VarStr = mercury_var_to_string(VarSet, no, Var), - HeadPieces = [words("Inside the case"), fixed(ConsIdStr), + HeadPieces = [words("Inside the case"), words(ConsIdsStr), words("of the switch on"), fixed(VarStr), suffix(":"), nl], det_diagnose_switch_context(SwitchContexts, DetInfo, TailPieces). @@ -865,9 +931,7 @@ det_report_call_context(Context, CallUnifyContext, DetInfo, PredId, ProcId, InitMsgs = [], ( CallUnifyContext = yes(call_unify_context(LHS, RHS, UC)), - First = yes, - Last = yes, - det_report_unify_context(First, Last, Context, UC, DetInfo, + det_report_unify_context(is_first, is_last, Context, UC, DetInfo, LHS, RHS, StartingPieces) ; % This shouldn't happen; every call to a compiler generated @@ -879,10 +943,8 @@ det_report_call_context(Context, CallUnifyContext, DetInfo, PredId, ProcId, ; ( CallUnifyContext = yes(call_unify_context(LHS, RHS, UC)), - First = yes, - Last = no, - det_report_unify_context(First, Last, Context, UC, DetInfo, - LHS, RHS, UnifyPieces0), + det_report_unify_context(is_first, is_not_last, Context, UC, + DetInfo, LHS, RHS, UnifyPieces0), UnifyPieces = UnifyPieces0 ++ [suffix(":")], UnifyMsg = simple_msg(Context, [always(UnifyPieces)]), InitMsgs = [UnifyMsg] @@ -909,7 +971,7 @@ det_report_call_context(Context, CallUnifyContext, DetInfo, PredId, ProcId, % with a capital letter) and whether it is the last part (in which case we % omit the word "in" on the final "... in unification ..."). % -:- pred det_report_unify_context(bool::in, bool::in, prog_context::in, +:- pred det_report_unify_context(is_first::in, is_last::in, prog_context::in, unify_context::in, det_info::in, prog_var::in, unify_rhs::in, list(format_component)::out) is det. @@ -920,21 +982,21 @@ det_report_unify_context(!.First, Last, _Context, UnifyContext, DetInfo, proc_info_get_varset(ProcInfo, VarSet), det_info_get_module_info(DetInfo, ModuleInfo), ( - !.First = yes, + !.First = is_first, ( - Last = yes, + Last = is_last, StartWords = "Unification" ; - Last = no, + Last = is_not_last, StartWords = "In unification" ) ; - !.First = no, + !.First = is_not_first, ( - Last = yes, + Last = is_last, StartWords = "unification" ; - Last = no, + Last = is_not_last, StartWords = "in unification" ) ), @@ -1031,18 +1093,19 @@ det_report_seen_call_id(ModuleInfo, SeenCall) = Pieces :- :- func det_report_context_lines(list(prog_context)) = string. -det_report_context_lines(Contexts) = det_report_context_lines_2(Contexts, yes). +det_report_context_lines(Contexts) = + det_report_context_lines_2(Contexts, is_first). -:- func det_report_context_lines_2(list(prog_context), bool) = string. +:- func det_report_context_lines_2(list(prog_context), is_first) = string. det_report_context_lines_2([], _) = "". det_report_context_lines_2([Context | Contexts], First) = Str :- term.context_line(Context, Line), ( - First = yes, + First = is_first, Punct = "" ; - First = no, + First = is_not_first, ( Contexts = [_ | _], Punct = ", " @@ -1052,7 +1115,7 @@ det_report_context_lines_2([Context | Contexts], First) = Str :- ) ), int_to_string(Line, This), - Later = det_report_context_lines_2(Contexts, no), + Later = det_report_context_lines_2(Contexts, is_not_first), Str = Punct ++ This ++ Later. %-----------------------------------------------------------------------------% diff --git a/compiler/det_util.m b/compiler/det_util.m index 864a46860..437b7740b 100644 --- a/compiler/det_util.m +++ b/compiler/det_util.m @@ -1,7 +1,7 @@ %-----------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et %-----------------------------------------------------------------------------% -% Copyright (C) 1996-2000,2002-2006 The University of Melbourne. +% Copyright (C) 1996-2000,2002-2007 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. %-----------------------------------------------------------------------------% @@ -41,9 +41,7 @@ % Given a list of cases, and a list of the possible cons_ids % that the switch variable could be bound to, select out only - % those cases whose cons_id occurs in the list of cases - % We assume that the list of cases and the list of cons_ids - % are sorted, so that we can do this using a simple sorted merge. + % those cases whose cons_id occurs in the list of possible cons_ids. % :- pred delete_unreachable_cases(list(case)::in, list(cons_id)::in, list(case)::out) is det. @@ -78,9 +76,9 @@ :- pred det_info_get_fully_strict(det_info::in, bool::out) is det. :- pred det_info_get_vartypes(det_info::in, vartypes::out) is det. -:- pred det_info_set_module_info(det_info::in, module_info::in, det_info::out) +:- pred det_info_set_module_info(module_info::in, det_info::in, det_info::out) is det. -:- pred det_info_set_vartypes(det_info::in, vartypes::in, det_info::out) +:- pred det_info_set_vartypes(vartypes::in, det_info::in, det_info::out) is det. %-----------------------------------------------------------------------------% @@ -96,22 +94,42 @@ :- import_module parse_tree.prog_util. :- import_module map. +:- import_module set_tree234. :- import_module term. %-----------------------------------------------------------------------------% -delete_unreachable_cases([], _, []). -delete_unreachable_cases([_ | _], [], []). -delete_unreachable_cases([Case | Cases0], [ConsId | ConsIds], Cases) :- - Case = case(CaseConsId, _DisjList), - ( CaseConsId = ConsId -> - Cases = [Case | Cases1], - delete_unreachable_cases(Cases0, ConsIds, Cases1) - ; compare(<, CaseConsId, ConsId) -> - delete_unreachable_cases(Cases0, [ConsId | ConsIds], Cases) +delete_unreachable_cases(Cases0, PossibleConsIds, Cases) :- + PossibleConsIdSet = set_tree234.list_to_set(PossibleConsIds), + % We use a reverse list accumulator because we want to avoid requiring + % O(n) stack space. + delete_unreachable_cases_2(Cases0, PossibleConsIdSet, [], RevCases), + list.reverse(RevCases, Cases). + +:- pred delete_unreachable_cases_2(list(case)::in, set_tree234(cons_id)::in, + list(case)::in, list(case)::out) is det. + +delete_unreachable_cases_2([], _PossibleConsIdSet, !RevCases). +delete_unreachable_cases_2([Case0 | Cases0], PossibleConsIdSet, !RevCases) :- + Case0 = case(MainConsId0, OtherConsIds0, Goal), + ( set_tree234.member(PossibleConsIdSet, MainConsId0) -> + list.filter(set_tree234.contains(PossibleConsIdSet), + OtherConsIds0, OtherConsIds), + Case = case(MainConsId0, OtherConsIds, Goal), + !:RevCases = [Case | !.RevCases] ; - delete_unreachable_cases([Case | Cases0], ConsIds, Cases) - ). + list.filter(set_tree234.contains(PossibleConsIdSet), + OtherConsIds0, OtherConsIds1), + ( + OtherConsIds1 = [] + % We don't add Case to !RevCases, effectively deleting it. + ; + OtherConsIds1 = [MainConsId | OtherConsIds], + Case = case(MainConsId, OtherConsIds, Goal), + !:RevCases = [Case | !.RevCases] + ) + ), + delete_unreachable_cases_2(Cases0, PossibleConsIdSet, !RevCases). interpret_unify(X, rhs_var(Y), !Subst) :- unify_term(variable(X, context_init), variable(Y, context_init), !Subst). @@ -185,8 +203,8 @@ det_info_get_reorder_disj(DI, DI ^ di_reorder_disj). det_info_get_fully_strict(DI, DI ^ di_fully_strict). det_info_get_vartypes(DI, DI ^ di_vartypes). -det_info_set_module_info(DI, ModuleInfo, DI ^ di_module_info := ModuleInfo). -det_info_set_vartypes(DI, VarTypes, DI ^ di_vartypes := VarTypes). +det_info_set_module_info(ModuleInfo, DI, DI ^ di_module_info := ModuleInfo). +det_info_set_vartypes(VarTypes, DI, DI ^ di_vartypes := VarTypes). %-----------------------------------------------------------------------------% diff --git a/compiler/distance_granularity.m b/compiler/distance_granularity.m index 669f28e26..129585aa9 100644 --- a/compiler/distance_granularity.m +++ b/compiler/distance_granularity.m @@ -796,11 +796,11 @@ apply_dg_to_switch([], !CasesAcc, _CallerPredId, _CallerProcId, apply_dg_to_switch([Case | Cases], !CasesAcc, CallerPredId, CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance, !MaybeGranularityVar) :- - Case = case(Functor, Goal0), + Case = case(MainConsId, OtherConsIds, Goal0), apply_dg_to_goal(Goal0, Goal, CallerPredId, CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance, no, !MaybeGranularityVar, _), - !:CasesAcc = [case(Functor, Goal) | !.CasesAcc], + !:CasesAcc = [case(MainConsId, OtherConsIds, Goal) | !.CasesAcc], apply_dg_to_switch(Cases, !CasesAcc, CallerPredId, CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance, !MaybeGranularityVar). @@ -1022,10 +1022,10 @@ update_original_predicate_switch([], !CasesAcc, _CallerPredId, _CallerProcId, update_original_predicate_switch([Case | Cases], !CasesAcc, CallerPredId, CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance) :- - Case = case(Functor, Goal0), + Case = case(MainConsId, OtherConsIds, Goal0), update_original_predicate_goal(Goal0, Goal, CallerPredId, CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance), - !:CasesAcc = [ case(Functor, Goal) | !.CasesAcc ], + !:CasesAcc = [case(MainConsId, OtherConsIds, Goal) | !.CasesAcc], update_original_predicate_switch(Cases, !CasesAcc, CallerPredId, CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance). diff --git a/compiler/dupproc.m b/compiler/dupproc.m index e15977b1b..a8e178f22 100644 --- a/compiler/dupproc.m +++ b/compiler/dupproc.m @@ -211,7 +211,7 @@ standardize_instr(Instr, StdInstr, DupProcMap) :- StdInstr = goto(StdTarget) ; Instr = computed_goto(Rval, Targets), - standardize_labels(Targets, StdTargets, DupProcMap), + standardize_maybe_labels(Targets, StdTargets, DupProcMap), StdInstr = computed_goto(Rval, StdTargets) ; Instr = if_val(Rval, Target), @@ -293,13 +293,21 @@ standardize_label(Label, StdLabel, DupProcMap) :- % Compute the standard form of a list(label). % -:- pred standardize_labels(list(label)::in, list(label)::out, - map(proc_label, proc_label)::in) is det. +:- pred standardize_maybe_labels(list(maybe(label))::in, + list(maybe(label))::out, map(proc_label, proc_label)::in) is det. -standardize_labels([], [], _DupProcMap). -standardize_labels([Label | Labels], [StdLabel | StdLabels], DupProcMap) :- - standardize_label(Label, StdLabel, DupProcMap), - standardize_labels(Labels, StdLabels, DupProcMap). +standardize_maybe_labels([], [], _DupProcMap). +standardize_maybe_labels([MaybeLabel | MaybeLabels], + [StdMaybeLabel | StdMaybeLabels], DupProcMap) :- + ( + MaybeLabel = yes(Label), + standardize_label(Label, StdLabel, DupProcMap), + StdMaybeLabel = yes(StdLabel) + ; + MaybeLabel = no, + StdMaybeLabel = no + ), + standardize_maybe_labels(MaybeLabels, StdMaybeLabels, DupProcMap). % Compute the standard form of a code_addr. % diff --git a/compiler/equiv_type_hlds.m b/compiler/equiv_type_hlds.m index 0f22caf0d..add493a5e 100644 --- a/compiler/equiv_type_hlds.m +++ b/compiler/equiv_type_hlds.m @@ -104,7 +104,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(_) @@ -148,7 +148,7 @@ replace_in_type_defn(ModuleName, EqvMap, TypeCtor, !Defn, !MaybeRecompInfo) :- equiv_type.maybe_record_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 @@ -735,6 +735,17 @@ replace_in_goal(EqvMap, Goal0 @ hlds_goal(GoalExpr0, GoalInfo0), Goal, Goal = Goal0 ). +:- pred replace_in_case(eqv_map::in) + `with_type` replacer(case, replace_info) + `with_inst` replacer. + +replace_in_case(EqvMap, Case0, Case, Changed, !Info) :- + Case0 = case(MainConsId, OtherConsIds, CaseGoal0), + replace_in_goal(EqvMap, CaseGoal0, CaseGoal, Changed, !Info), + ( Changed = yes, Case = case(MainConsId, OtherConsIds, CaseGoal) + ; Changed = no, Case = Case0 + ). + :- pred replace_in_goal_expr(eqv_map::in) `with_type` replacer(hlds_goal_expr, replace_info) `with_inst` replacer. @@ -755,14 +766,7 @@ replace_in_goal_expr(EqvMap, GoalExpr0 @ disj(Goals0), GoalExpr, ). replace_in_goal_expr(EqvMap, GoalExpr0 @ switch(A, B, Cases0), GoalExpr, Changed, !Info) :- - replace_in_list( - (pred((Case0 @ case(ConsId, CaseGoal0))::in, Case::out, - CaseChanged::out, !.Info::in, !:Info::out) is det :- - replace_in_goal(EqvMap, CaseGoal0, CaseGoal, CaseChanged, !Info), - ( CaseChanged = yes, Case = case(ConsId, CaseGoal) - ; CaseChanged = no, Case = Case0 - ) - ), Cases0, Cases, Changed, !Info), + replace_in_list(replace_in_case(EqvMap), Cases0, Cases, Changed, !Info), ( Changed = yes, GoalExpr = switch(A, B, Cases) ; Changed = no, GoalExpr = GoalExpr0 ). diff --git a/compiler/erl_code_gen.m b/compiler/erl_code_gen.m index 9ad7536f2..4e0ff7750 100644 --- a/compiler/erl_code_gen.m +++ b/compiler/erl_code_gen.m @@ -771,7 +771,7 @@ erl_gen_switch(Var, CanFail, CasesList, CodeModel, InstMap0, _Context, % % Get the union of all nonlocal variables bound in all cases. - CasesGoals = list.map((func(case(_, Goal)) = Goal), CasesList), + CasesGoals = list.map((func(case(_, _, Goal)) = Goal), CasesList), union_bound_nonlocals_in_goals(!.Info, InstMap0, CasesGoals, NonLocalsBoundInCases), @@ -805,7 +805,14 @@ erl_gen_switch(Var, CanFail, CasesList, CodeModel, InstMap0, _Context, % less, so we don't use the workaround if any cases are longer than % that. all [String] ( - list.member(case(string_const(String), _), CasesList) + ( + list.member(case(MainConsId, OtherConsIds, _), CasesList), + ( + MainConsId = string_const(String) + ; + list.member(string_const(String), OtherConsIds) + ) + ) => string.length(String) =< 255 ) @@ -849,11 +856,14 @@ erl_gen_switch(Var, CanFail, CasesList, CodeModel, InstMap0, _Context, erl_gen_info::in, erl_gen_info::out) is det. erl_gen_case(Type, CodeModel, InstMap, MustBindNonLocals, MaybeSuccessExpr, - case(ConsId, Goal), ELDSCase, !Info) :- + Case, ELDSCase, !Info) :- + Case = case(MainConsId, OtherConsIds, Goal), + expect(unify(OtherConsIds, []), this_file, + "erl_gen_case: multi-cons-id switch arms NYI"), erl_gen_info_get_module_info(!.Info, ModuleInfo), - Size = cons_id_size(ModuleInfo, Type, ConsId), + Size = cons_id_size(ModuleInfo, Type, MainConsId), erl_gen_info_new_anonymous_vars(Size, DummyVars, !Info), - ( cons_id_to_term(ConsId, DummyVars, elds_anon_var, Pattern0, !Info) -> + ( cons_id_to_term(MainConsId, DummyVars, elds_anon_var, Pattern0, !Info) -> Pattern = Pattern0 ; unexpected(this_file, "erl_gen_case: cannot pattern match on object") @@ -862,16 +872,15 @@ erl_gen_case(Type, CodeModel, InstMap, MustBindNonLocals, MaybeSuccessExpr, MaybeSuccessExprForCase, !Info), erl_gen_goal(CodeModel, InstMap, Goal, MaybeSuccessExprForCase, Statement0, !Info), - % + % To prevent warnings from the Erlang compiler we must make sure all cases % bind the same set of variables. This might not be true if the Mercury % compiler knows that a case calls a procedure which throws an exception. - % + erl_bind_unbound_vars(!.Info, MustBindNonLocals, Goal, InstMap, Statement0, Statement), ELDSCase = elds_case(Pattern, Statement). - % % cons_id_size(ModuleInfo, Type, ConsId) % % Returns the size - 1 of the tuple which represents the @@ -885,11 +894,10 @@ cons_id_size(ModuleInfo, Type, ConsId) = Size :- get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn) -> - % - % There will be a cell for each existential type variable - % which isn't mentioned in a typeclass constraint and - % a cell for each constraint and for each arg. - % + % There will be a cell for each existential type variable + % which isn't mentioned in a typeclass constraint and + % a cell for each constraint and for each arg. + Constraints = ConsDefn ^ cons_constraints, constraint_list_get_tvars(Constraints, ConstrainedTVars), ExistTVars = ConsDefn ^ cons_exist_tvars, @@ -906,8 +914,11 @@ cons_id_size(ModuleInfo, Type, ConsId) = Size :- erl_gen_info::in, erl_gen_info::out) is det. erl_gen_case_on_atom(CodeModel, InstMap, MustBindNonLocals, MaybeSuccessExpr, - case(ConsId, Goal), ELDSCase, !Info) :- - ( ConsId = string_const(String0) -> + Case, ELDSCase, !Info) :- + Case = case(MainConsId, OtherConsIds, Goal), + expect(unify(OtherConsIds, []), this_file, + "erl_gen_case_on_atom: multi-cons-id switch arms NYI"), + ( MainConsId = string_const(String0) -> String = String0 ; unexpected(this_file, "erl_gen_case_on_atom: non-string const") @@ -916,11 +927,11 @@ erl_gen_case_on_atom(CodeModel, InstMap, MustBindNonLocals, MaybeSuccessExpr, MaybeSuccessExprForCase, !Info), erl_gen_goal(CodeModel, InstMap, Goal, MaybeSuccessExprForCase, Statement0, !Info), - % + % To prevent warnings from the Erlang compiler we must make sure all cases % bind the same set of variables. This might not be true if the Mercury % compiler knows that a case calls a procedure which throws an exception. - % + erl_bind_unbound_vars(!.Info, MustBindNonLocals, Goal, InstMap, Statement0, Statement), ELDSCase = elds_case(elds_atom_raw(String), Statement). diff --git a/compiler/exception_analysis.m b/compiler/exception_analysis.m index 83b9e9784..b0d6a1f75 100644 --- a/compiler/exception_analysis.m +++ b/compiler/exception_analysis.m @@ -519,7 +519,7 @@ check_goal_for_exceptions_2(_, _, shorthand(_), _, _, _, _, _, _, _) :- check_goal_for_exceptions_2(SCC, VarTypes, Goal, _, !Result, !ModuleInfo, !IO) :- Goal = switch(_, _, Cases), - CaseGoals = list.map((func(case(_, CaseGoal)) = CaseGoal), Cases), + CaseGoals = list.map((func(case(_, _, CaseGoal)) = CaseGoal), Cases), check_goals_for_exceptions(SCC, VarTypes, CaseGoals, !Result, !ModuleInfo, !IO). check_goal_for_exceptions_2(SCC, VarTypes, Goal, _, !Result, diff --git a/compiler/export.m b/compiler/export.m index 76edec063..e2f15e8d0 100644 --- a/compiler/export.m +++ b/compiler/export.m @@ -811,8 +811,9 @@ output_exported_enum(ModuleInfo, ExportedEnumInfo, !IO) :- ), unexpected(this_file, "invalid type for foreign_export_enum") ; - TypeBody = hlds_du_type(Ctors, TagValues, IsEnumOrDummy, - _MaybeUserEq, _ReservedTag, _ReservedAddr, _IsForeignType), + TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest, + IsEnumOrDummy, _MaybeUserEq, _ReservedTag, _ReservedAddr, + _IsForeignType), ( IsEnumOrDummy = not_enum_or_dummy, unexpected(this_file, "d.u. is not an enumeration.") diff --git a/compiler/follow_code.m b/compiler/follow_code.m index cb7e96fed..0fa93e3b3 100644 --- a/compiler/follow_code.m +++ b/compiler/follow_code.m @@ -182,9 +182,9 @@ move_follow_code_in_independent_goals([Goal0 | Goals0], [Goal | Goals], move_follow_code_in_cases([], [], !Changed). move_follow_code_in_cases([Case0 | Cases0], [Case | Cases], !Changed) :- - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), move_follow_code_in_goal(Goal0, Goal, !Changed), - Case = case(ConsId, Goal), + Case = case(MainConsId, OtherConsIds, Goal), move_follow_code_in_cases(Cases0, Cases, !Changed). %-----------------------------------------------------------------------------% @@ -304,10 +304,10 @@ move_follow_code_move_goals(Goal0, FollowGoals, FollowPurity, Goal) :- move_follow_code_move_goals_cases([], _FollowGoals, _FollowPurity, []). move_follow_code_move_goals_cases([Case0 | Cases0], FollowGoals, FollowPurity, [Case | Cases]) :- - Case0 = case(Cons, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), follow_code_conjoin_goal_and_goal_list(Goal0, FollowGoals, FollowPurity, Goal), - Case = case(Cons, Goal), + Case = case(MainConsId, OtherConsIds, Goal), move_follow_code_move_goals_cases(Cases0, FollowGoals, FollowPurity, Cases). diff --git a/compiler/follow_vars.m b/compiler/follow_vars.m index 163023df6..39f1d2bba 100644 --- a/compiler/follow_vars.m +++ b/compiler/follow_vars.m @@ -387,16 +387,17 @@ find_follow_vars_in_independent_goals([Goal0 | Goals0], [Goal | Goals], int::in, int::out) is det. find_follow_vars_in_cases([], [], _, _, !FollowVarsMap, !NextNonReserved). -find_follow_vars_in_cases([case(Cons, Goal0) | Goals0], - [case(Cons, Goal) | Goals], VarTypes, ModuleInfo, - FollowVarsMap0, FollowVarsMap, +find_follow_vars_in_cases([Case0 | Cases0], [Case | Cases], + VarTypes, ModuleInfo, FollowVarsMap0, FollowVarsMap, NextNonReserved0, NextNonReserved) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), find_follow_vars_in_goal(Goal0, Goal1, VarTypes, ModuleInfo, FollowVarsMap0, FollowVarsMap, NextNonReserved0, NextNonReserved), FollowVars = abs_follow_vars(FollowVarsMap, NextNonReserved), goal_set_follow_vars(yes(FollowVars), Goal1, Goal), - find_follow_vars_in_cases(Goals0, Goals, VarTypes, ModuleInfo, + Case = case(MainConsId, OtherConsIds, Goal), + find_follow_vars_in_cases(Cases0, Cases, VarTypes, ModuleInfo, FollowVarsMap0, _FollowVarsMap, NextNonReserved, _NextNonReserved). diff --git a/compiler/foreign.m b/compiler/foreign.m index be9028ea5..f65a576ef 100644 --- a/compiler/foreign.m +++ b/compiler/foreign.m @@ -551,7 +551,7 @@ to_exported_type(ModuleInfo, Type) = ExportType :- ForeignTypeName, _, Assertions), ExportType = exported_type_foreign(ForeignTypeName, Assertions) ; - ( Body = hlds_du_type(_, _, _, _, _, _, _) + ( Body = hlds_du_type(_, _, _, _, _, _, _, _) ; Body = hlds_eqv_type(_) ; Body = hlds_solver_type(_, _) ; Body = hlds_abstract_type(_) diff --git a/compiler/format_call.m b/compiler/format_call.m index 263be73e7..b1c6fd677 100644 --- a/compiler/format_call.m +++ b/compiler/format_call.m @@ -562,7 +562,7 @@ traverse_unify(Unification, CurId, !ConjMaps, !PredMap, !RelevantVars) :- :- func project_case_goal(case) = hlds_goal. -project_case_goal(case(_, Goal)) = Goal. +project_case_goal(case(_, _, Goal)) = Goal. :- pred traverse_disj(list(hlds_goal)::in, conj_id::in, list(format_call_site)::in, list(format_call_site)::out, diff --git a/compiler/frameopt.m b/compiler/frameopt.m index 0a7984b2d..e2254d258 100644 --- a/compiler/frameopt.m +++ b/compiler/frameopt.m @@ -1219,7 +1219,7 @@ analyze_block(Label, FollowingLabels, FirstLabel, ProcLabel, ; LastUinstr0 = computed_goto(Rval, GotoTargets0) -> - replace_labels_label_list(GotoTargets0, GotoTargets, + replace_labels_maybe_label_list(GotoTargets0, GotoTargets, PreExitDummyLabelMap), LastUinstr = computed_goto(Rval, GotoTargets), LastInstr = llds_instr(LastUinstr, Comment), diff --git a/compiler/goal_form.m b/compiler/goal_form.m index e59a2a1fb..6d77593d6 100644 --- a/compiler/goal_form.m +++ b/compiler/goal_form.m @@ -290,7 +290,7 @@ goals_can_throw([Goal | Goals], Result, !ModuleInfo, !IO) :- cases_can_throw([], cannot_throw, !ModuleInfo, !IO). cases_can_throw([Case | Cases], Result, !ModuleInfo, !IO) :- - Case = case(_, Goal), + Case = case(_, _, Goal), goal_can_throw(Goal, Result0, !ModuleInfo, !IO), ( Result0 = cannot_throw, @@ -301,8 +301,8 @@ cases_can_throw([Case | Cases], Result, !ModuleInfo, !IO) :- ). goal_can_loop_or_throw(Goal, Result, !ModuleInfo, !IO) :- - % XXX this will need to change after the termination analyses are - % converted to use the intermodule-analysis framework. + % XXX This will need to change after the termination analyses are converted + % to use the intermodule-analysis framework. ( goal_cannot_loop(!.ModuleInfo, Goal) -> goal_can_throw(Goal, ThrowResult, !ModuleInfo, !IO), ( @@ -442,7 +442,7 @@ goal_list_can_loop(MaybeModuleInfo, [Goal | Goals]) = :- func case_list_can_loop(maybe(module_info), list(case)) = bool. case_list_can_loop(_, []) = no. -case_list_can_loop(MaybeModuleInfo, [case(_, Goal) | Cases]) = +case_list_can_loop(MaybeModuleInfo, [case(_, _, Goal) | Cases]) = ( goal_can_loop_func(MaybeModuleInfo, Goal) = yes -> yes ; @@ -550,7 +550,7 @@ goal_list_can_throw(MaybeModuleInfo, [Goal | Goals]) = :- func case_list_can_throw(maybe(module_info), list(case)) = bool. case_list_can_throw(_, []) = no. -case_list_can_throw(MaybeModuleInfo, [case(_, Goal) | Cases]) = +case_list_can_throw(MaybeModuleInfo, [case(_, _, Goal) | Cases]) = ( goal_can_throw_func(MaybeModuleInfo, Goal) = yes -> yes ; @@ -683,7 +683,7 @@ goal_list_may_allocate_heap([Goal | Goals], May) :- :- pred cases_may_allocate_heap(list(case)::in, bool::out) is det. cases_may_allocate_heap([], no). -cases_may_allocate_heap([case(_, Goal) | Cases], May) :- +cases_may_allocate_heap([case(_, _, Goal) | Cases], May) :- ( goal_may_allocate_heap(Goal, yes) -> May = yes ; @@ -719,7 +719,7 @@ cannot_stack_flush_goals([Goal | Goals]) :- :- pred cannot_stack_flush_cases(list(case)::in) is semidet. cannot_stack_flush_cases([]). -cannot_stack_flush_cases([case(_, Goal) | Cases]) :- +cannot_stack_flush_cases([case(_, _, Goal) | Cases]) :- cannot_stack_flush(Goal), cannot_stack_flush_cases(Cases). @@ -841,7 +841,7 @@ count_recursive_calls_disj([Goal | Goals], PredId, ProcId, Min, Max) :- count_recursive_calls_cases([], _, _, _, _) :- unexpected(this_file, "empty cases in count_recursive_calls_cases"). -count_recursive_calls_cases([case(_, Goal) | Cases], PredId, ProcId, +count_recursive_calls_cases([case(_, _, Goal) | Cases], PredId, ProcId, Min, Max) :- ( Cases = [], diff --git a/compiler/goal_path.m b/compiler/goal_path.m index 55e0e8429..7d62c33ae 100644 --- a/compiler/goal_path.m +++ b/compiler/goal_path.m @@ -240,10 +240,12 @@ fill_disj_slots(Path0, N0, SlotInfo, [Goal0 | Goals0], [Goal | Goals]) :- fill_switch_slots(_, _, _, _, [], []). fill_switch_slots(Path0, N0, MaybeNumFunctors, SlotInfo, - [case(ConsId, Goal0) | Cases0], [case(ConsId, Goal) | Cases]) :- + [Case0 | Cases0], [Case | Cases]) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), N1 = N0 + 1, fill_goal_slots(cord.snoc(Path0, step_switch(N1, MaybeNumFunctors)), SlotInfo, Goal0, Goal), + Case = case(MainConsId, OtherConsIds, Goal), fill_switch_slots(Path0, N1, MaybeNumFunctors, SlotInfo, Cases0, Cases). %-----------------------------------------------------------------------------% diff --git a/compiler/goal_util.m b/compiler/goal_util.m index 042c90837..a4076a77b 100644 --- a/compiler/goal_util.m +++ b/compiler/goal_util.m @@ -214,8 +214,8 @@ % (deconstruction unification) to the case goal. % This aborts if the constructor is existentially typed. % -:- pred case_to_disjunct(prog_var::in, cons_id::in, hlds_goal::in, - instmap::in, hlds_goal::out, prog_varset::in, prog_varset::out, +:- pred case_to_disjunct(prog_var::in, hlds_goal::in, instmap::in, + cons_id::in, hlds_goal::out, prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, module_info::in, module_info::out) is det. % Transform an if-then-else into ( Cond, Then ; \+ Cond, Else ), @@ -552,7 +552,7 @@ goals_goal_vars([Goal | Goals], !Set) :- set(prog_var)::in, set(prog_var)::out) is det. cases_goal_vars([], !Set). -cases_goal_vars([case(_, Goal) | Cases], !Set) :- +cases_goal_vars([case(_, _, Goal) | Cases], !Set) :- goal_vars_2(Goal ^ hlds_goal_expr, !Set), cases_goal_vars(Cases, !Set). @@ -587,8 +587,10 @@ attach_features_to_all_goals(Features, Goal0, Goal) :- :- pred attach_features_to_case(list(goal_feature)::in, case::in, case::out) is det. -attach_features_to_case(Features, case(ConsId, Goal0), case(ConsId, Goal)) :- - attach_features_to_all_goals(Features, Goal0, Goal). +attach_features_to_case(Features, Case0, Case) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), + attach_features_to_all_goals(Features, Goal0, Goal), + Case = case(MainConsId, OtherConsIds, Goal). :- pred attach_features_goal_expr(list(goal_feature)::in, hlds_goal_expr::in, hlds_goal_expr::out) is det. @@ -759,7 +761,7 @@ proc_body_is_leaf_goals([Goal | Goals]) = IsLeaf :- proc_body_is_leaf_cases([]) = is_leaf. proc_body_is_leaf_cases([Case | Cases]) = IsLeaf :- - Case = case(_, Goal), + Case = case(_, _, Goal), ( proc_body_is_leaf(Goal) = is_leaf, proc_body_is_leaf_cases(Cases) = is_leaf @@ -805,7 +807,7 @@ clause_size_increment(Clause, Size0, Size) :- :- pred cases_size(list(case)::in, int::out) is det. cases_size([], 0). -cases_size([case(_, Goal) | Cases], Size) :- +cases_size([case(_, _, Goal) | Cases], Size) :- goal_size(Goal, Size1), cases_size(Cases, Size2), Size = Size1 + Size2. @@ -879,7 +881,7 @@ goals_calls([Goal | Goals], PredProcId) :- :- mode cases_calls(in, in) is semidet. :- mode cases_calls(in, out) is nondet. -cases_calls([case(_, Goal) | Cases], PredProcId) :- +cases_calls([case(_, _, Goal) | Cases], PredProcId) :- ( goal_calls(Goal, PredProcId) ; @@ -937,7 +939,7 @@ goals_calls_pred_id([Goal | Goals], PredId) :- :- mode cases_calls_pred_id(in, in) is semidet. :- mode cases_calls_pred_id(in, out) is nondet. -cases_calls_pred_id([case(_, Goal) | Cases], PredId) :- +cases_calls_pred_id([case(_, _, Goal) | Cases], PredId) :- ( goal_calls_pred_id(Goal, PredId) ; @@ -1035,7 +1037,7 @@ goal_list_calls_proc_in_list_2([Goal | Goals], PredProcIds, !CalledSet) :- case_list_calls_proc_in_list([], _, !CalledSet). case_list_calls_proc_in_list([Case | Cases], PredProcIds, !CalledSet) :- - Case = case(_, Goal), + Case = case(_, _, Goal), goal_calls_proc_in_list_2(Goal, PredProcIds, !CalledSet), case_list_calls_proc_in_list(Cases, PredProcIds, !CalledSet). @@ -1054,7 +1056,7 @@ goal_expr_contains_reconstruction(disj(Goals)) :- goals_contain_reconstruction(Goals). goal_expr_contains_reconstruction(switch(_, _, Cases)) :- list.member(Case, Cases), - Case = case(_, Goal), + Case = case(_, _, Goal), goal_contains_reconstruction(Goal). goal_expr_contains_reconstruction(if_then_else(_, Cond, Then, Else)) :- goals_contain_reconstruction([Cond, Then, Else]). @@ -1092,19 +1094,23 @@ direct_subgoal(disj(DisjList), Goal) :- list.member(Goal, DisjList). direct_subgoal(switch(_, _, CaseList), Goal) :- list.member(Case, CaseList), - Case = case(_, Goal). + Case = case(_, _, Goal). %-----------------------------------------------------------------------------% switch_to_disjunction(_, [], _, [], !VarSet, !VarTypes, !ModuleInfo). -switch_to_disjunction(Var, [case(ConsId, Goal0) | Cases], InstMap, - [Goal | Goals], !VarSet, !VarTypes, !ModuleInfo) :- - case_to_disjunct(Var, ConsId, Goal0, InstMap, Goal, !VarSet, !VarTypes, +switch_to_disjunction(Var, [Case | Cases], InstMap, Goals, + !VarSet, !VarTypes, !ModuleInfo) :- + Case = case(MainConsId, OtherConsIds, CaseGoal), + case_to_disjunct(Var, CaseGoal, InstMap, MainConsId, MainDisjunctGoal, + !VarSet, !VarTypes, !ModuleInfo), + list.map_foldl3(case_to_disjunct(Var, CaseGoal, InstMap), + OtherConsIds, OtherDisjunctGoals, !VarSet, !VarTypes, !ModuleInfo), + switch_to_disjunction(Var, Cases, InstMap, CasesGoals, !VarSet, !VarTypes, !ModuleInfo), - switch_to_disjunction(Var, Cases, InstMap, Goals, !VarSet, !VarTypes, - !ModuleInfo). + Goals = [MainDisjunctGoal | OtherDisjunctGoals] ++ CasesGoals. -case_to_disjunct(Var, ConsId, CaseGoal, InstMap, Disjunct, !VarSet, !VarTypes, +case_to_disjunct(Var, CaseGoal, InstMap, ConsId, Disjunct, !VarSet, !VarTypes, !ModuleInfo) :- ConsArity = cons_id_arity(ConsId), svvarset.new_vars(ConsArity, ArgVars, !VarSet), @@ -1630,9 +1636,9 @@ maybe_strip_equality_pretest(Goal0) = Goal :- :- func maybe_strip_equality_pretest_case(case) = case. maybe_strip_equality_pretest_case(Case0) = Case :- - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), Goal = maybe_strip_equality_pretest(Goal0), - Case = case(ConsId, Goal). + Case = case(MainConsId, OtherConsIds, Goal). %-----------------------------------------------------------------------------% diff --git a/compiler/granularity.m b/compiler/granularity.m index dcdb3498e..1e9bd1e11 100644 --- a/compiler/granularity.m +++ b/compiler/granularity.m @@ -225,9 +225,9 @@ runtime_granularity_test_in_goals([Goal0 | Goals0], [Goal | Goals], !Changed, runtime_granularity_test_in_cases([], [], !Changed, _, _). runtime_granularity_test_in_cases([Case0 | Cases0], [Case | Cases], !Changed, SCC, ModuleInfo) :- - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), runtime_granularity_test_in_goal(Goal0, Goal, !Changed, SCC, ModuleInfo), - Case = case(ConsId, Goal), + Case = case(MainConsId, OtherConsIds, Goal), runtime_granularity_test_in_cases(Cases0, Cases, !Changed, SCC, ModuleInfo). diff --git a/compiler/handle_options.m b/compiler/handle_options.m index 61b629a15..fa0e6fa6a 100644 --- a/compiler/handle_options.m +++ b/compiler/handle_options.m @@ -1076,6 +1076,9 @@ postprocess_options_2(OptionTable0, Target, GC_Method, TagsMethod0, option_implies(highlevel_code, mutable_always_boxed, bool(no), !Globals), + option_implies(highlevel_code, allow_multi_arm_switches, bool(no), + !Globals), + option_implies(target_debug, strip, bool(no), !Globals), % Inlining happens before the deep profiling transformation, so if @@ -2752,6 +2755,7 @@ convert_dump_alias("allD", "abcdfgilmnprstuvzBCDMPT"). convert_dump_alias("all", "abcdfgilmnprstuvzBCMPSTZ"). convert_dump_alias("most", "bcdfgilmnprstuvzP"). convert_dump_alias("trans", "bcdglmnstuvz"). +convert_dump_alias("mintrans", "bcdglmnstvz"). convert_dump_alias("codegen", "dfnprsu"). convert_dump_alias("vanessa", "ltuCIU"). convert_dump_alias("min", "ilv"). diff --git a/compiler/hhf.m b/compiler/hhf.m index 81070b0f2..2966e72d3 100644 --- a/compiler/hhf.m +++ b/compiler/hhf.m @@ -390,10 +390,10 @@ complete_inst_graph_node(ModuleInfo, BaseVars, Var, !HI) :- VarTypes0 = !.HI ^ vartypes, ( map.search(VarTypes0, Var, Type), - type_constructors(Type, ModuleInfo, Constructors), - type_to_ctor_and_args(Type, TypeId, _) + type_constructors(ModuleInfo, Type, Constructors), + type_to_ctor_and_args(Type, TypeCtor, _) -> - list.foldl(maybe_add_cons_id(Var, ModuleInfo, BaseVars, TypeId), + list.foldl(maybe_add_cons_id(Var, ModuleInfo, BaseVars, TypeCtor), Constructors, !HI) ; true @@ -402,9 +402,9 @@ complete_inst_graph_node(ModuleInfo, BaseVars, Var, !HI) :- :- pred maybe_add_cons_id(prog_var::in, module_info::in, list(prog_var)::in, type_ctor::in, constructor::in, hhf_info::in, hhf_info::out) is det. -maybe_add_cons_id(Var, ModuleInfo, BaseVars, TypeId, Ctor, !HI) :- +maybe_add_cons_id(Var, ModuleInfo, BaseVars, TypeCtor, Ctor, !HI) :- Ctor = ctor(_, _, Name, Args, _), - ConsId = make_cons_id(Name, Args, TypeId), + ConsId = make_cons_id(Name, Args, TypeCtor), map.lookup(!.HI ^ inst_graph, Var, node(Functors0, MaybeParent)), ( map.contains(Functors0, ConsId) -> true diff --git a/compiler/higher_order.m b/compiler/higher_order.m index 731998970..9ddf1fafa 100644 --- a/compiler/higher_order.m +++ b/compiler/higher_order.m @@ -692,9 +692,9 @@ traverse_cases_2(_, [], [], !PostInfos, !Info). traverse_cases_2(PreInfo, [Case0 | Cases0], [Case | Cases], !PostInfos, !Info) :- set_pre_branch_info(PreInfo, !Info), - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), traverse_goal_2(Goal0, Goal, !Info), - Case = case(ConsId, Goal), + Case = case(MainConsId, OtherConsIds, Goal), get_post_branch_info(!.Info, GoalPostInfo), !:PostInfos = [GoalPostInfo | !.PostInfos], traverse_cases_2(PreInfo, Cases0, Cases, !PostInfos, !Info). diff --git a/compiler/hlds_code_util.m b/compiler/hlds_code_util.m index 02ac637df..bea84d3e4 100644 --- a/compiler/hlds_code_util.m +++ b/compiler/hlds_code_util.m @@ -31,7 +31,7 @@ % Find out how a function symbol (constructor) is represented % in the given type. % -:- func cons_id_to_tag(cons_id, mer_type, module_info) = cons_tag. +:- func cons_id_to_tag(module_info, mer_type, cons_id) = cons_tag. % Given a list of types, mangle the names so into a string which % identifies them. The types must all have their top level functor @@ -76,63 +76,82 @@ are_equivalence_types_expanded(ModuleInfo) :- %-----------------------------------------------------------------------------% -cons_id_to_tag(int_const(I), _, _) = int_tag(I). -cons_id_to_tag(float_const(F), _, _) = float_tag(F). -cons_id_to_tag(string_const(S), _, _) = string_tag(S). -cons_id_to_tag(pred_const(ShroudedPredProcId, EvalMethod), _, _) = - pred_closure_tag(PredId, ProcId, EvalMethod) :- - proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId). -cons_id_to_tag(type_ctor_info_const(M,T,A), _, _) = - type_ctor_info_tag(M,T,A). -cons_id_to_tag(base_typeclass_info_const(M,C,_,N), _, _) = - base_typeclass_info_tag(M,C,N). -cons_id_to_tag(type_info_cell_constructor(_), _, _) = unshared_tag(0). -cons_id_to_tag(typeclass_info_cell_constructor, _, _) = unshared_tag(0). -cons_id_to_tag(tabling_info_const(ShroudedPredProcId), _, _) = - tabling_info_tag(PredId, ProcId) :- - proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId). -cons_id_to_tag(deep_profiling_proc_layout(ShroudedPredProcId), _, _) = - deep_profiling_proc_layout_tag(PredId, ProcId) :- - proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId). -cons_id_to_tag(table_io_decl(ShroudedPredProcId), _, _) = - table_io_decl_tag(PredId, ProcId) :- - proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId). -cons_id_to_tag(cons(Name, Arity), Type, ModuleInfo) = Tag :- +cons_id_to_tag(ModuleInfo, Type, ConsId) = Tag:- ( - % Handle the `character' type specially. - Type = builtin_type(builtin_type_character), - Name = unqualified(ConsName), - string.char_to_string(Char, ConsName) - -> - char.to_int(Char, CharCode), - Tag = int_tag(CharCode) + ConsId = int_const(I), + Tag = int_tag(I) ; - % Tuples do not need a tag. Note that unary tuples are not treated - % as no_tag types. There's no reason why they couldn't be, it's just - % not worth the effort. - type_is_tuple(Type, _) - -> - Tag = single_functor_tag + ConsId = float_const(F), + Tag = float_tag(F) ; - type_to_ctor_det(Type, TypeCtor), - % Given the type_ctor, lookup up the constructor tag table - % for that type. - module_info_get_type_table(ModuleInfo, TypeTable), - map.lookup(TypeTable, TypeCtor, TypeDefn), - hlds_data.get_type_defn_body(TypeDefn, TypeBody), - ( - TypeBody = hlds_du_type(_, ConsTagTable, _, _, _, _, _) - ; - ( TypeBody = hlds_eqv_type(_) - ; TypeBody = hlds_foreign_type(_) - ; TypeBody = hlds_solver_type(_, _) - ; TypeBody = hlds_abstract_type(_) - ), - unexpected(this_file, "cons_id_to_tag: type is not d.u. type?") + ConsId = string_const(S), + Tag = string_tag(S) + ; + ConsId = pred_const(ShroudedPredProcId, EvalMethod), + proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId), + Tag = pred_closure_tag(PredId, ProcId, EvalMethod) + ; + ConsId = type_ctor_info_const(ModuleName, TypeName, Arity), + Tag = type_ctor_info_tag(ModuleName, TypeName, Arity) + ; + ConsId = base_typeclass_info_const(ModuleName, ClassName, _Instance, + EncodedArgs), + Tag = base_typeclass_info_tag(ModuleName, ClassName, EncodedArgs) + ; + ( ConsId = type_info_cell_constructor(_) + ; ConsId = typeclass_info_cell_constructor ), + Tag = unshared_tag(0) + ; + ConsId = tabling_info_const(ShroudedPredProcId), + proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId), + Tag = tabling_info_tag(PredId, ProcId) + ; + ConsId = deep_profiling_proc_layout(ShroudedPredProcId), + proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId), + Tag = deep_profiling_proc_layout_tag(PredId, ProcId) + ; + ConsId = table_io_decl(ShroudedPredProcId), + proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId), + Tag = table_io_decl_tag(PredId, ProcId) + ; + ConsId = cons(Name, Arity), + ( + % Handle the `character' type specially. + Type = builtin_type(builtin_type_character), + Name = unqualified(ConsName), + string.char_to_string(Char, ConsName) + -> + char.to_int(Char, CharCode), + Tag = int_tag(CharCode) + ; + % Tuples do not need a tag. Note that unary tuples are not treated + % as no_tag types. There's no reason why they couldn't be, it is + % just not worth the effort. + type_is_tuple(Type, _) + -> + Tag = single_functor_tag + ; + type_to_ctor_det(Type, TypeCtor), + % Given the type_ctor, lookup up the constructor tag table + % for that type. + module_info_get_type_table(ModuleInfo, TypeTable), + map.lookup(TypeTable, TypeCtor, TypeDefn), + hlds_data.get_type_defn_body(TypeDefn, TypeBody), + ( + TypeBody = hlds_du_type(_, ConsTagTable, _, _, _, _, _, _) + ; + ( TypeBody = hlds_eqv_type(_) + ; TypeBody = hlds_foreign_type(_) + ; TypeBody = hlds_solver_type(_, _) + ; TypeBody = hlds_abstract_type(_) + ), + unexpected(this_file, "cons_id_to_tag: type is not d.u. type?") + ), - % Finally look up the cons_id in the table. - map.lookup(ConsTagTable, cons(Name, Arity), Tag) + % Finally look up the cons_id in the table. + map.lookup(ConsTagTable, cons(Name, Arity), Tag) + ) ). %-----------------------------------------------------------------------------% diff --git a/compiler/hlds_data.m b/compiler/hlds_data.m index 2e28def65..64b4a7311 100644 --- a/compiler/hlds_data.m +++ b/compiler/hlds_data.m @@ -167,6 +167,8 @@ % Their tag values. du_type_cons_tag_values :: cons_tag_values, + du_type_chaper_tag_test :: maybe_cheaper_tag_test, + % Is this type an enumeration? du_type_is_enum :: enum_or_dummy, @@ -188,6 +190,15 @@ ; hlds_solver_type(solver_type_details, maybe(unify_compare)) ; hlds_abstract_type(is_solver_type). +:- type maybe_cheaper_tag_test + ---> no_cheaper_tag_test + ; cheaper_tag_test( + more_expensive_cons_id :: cons_id, + more_expensive_cons_tag :: cons_tag, + less_expensive_cons_id :: cons_id, + less_expensive_cons_tag :: cons_tag + ). + :- type enum_or_dummy ---> is_mercury_enum ; is_foreign_enum(foreign_language) @@ -221,6 +232,15 @@ % :- type cons_tag_values == map(cons_id, cons_tag). + % A cons_id together with its tag. + % +:- type tagged_cons_id + ---> tagged_cons_id(cons_id, cons_tag). + + % Return the tag inside a tagged_cons_id. + % +:- func project_tagged_cons_id_tag(tagged_cons_id) = cons_tag. + % A `cons_tag' specifies how a functor and its arguments (if any) are % represented. Currently all values are represented as a single word; % values which do not fit into a word are represented by a (possibly @@ -359,6 +379,8 @@ :- type no_tag_type_table == map(type_ctor, no_tag_type). +:- func get_maybe_cheaper_tag_test(hlds_type_body) = maybe_cheaper_tag_test. + % Return the primary tag, if any, for a cons_tag. % A return value of `no' means the primary tag is unknown. % A return value of `yes(N)' means the primary tag is N. @@ -386,6 +408,21 @@ :- implementation. +project_tagged_cons_id_tag(TaggedConsId) = Tag :- + TaggedConsId = tagged_cons_id(_, Tag). + +get_maybe_cheaper_tag_test(TypeBody) = CheaperTagTest :- + ( + TypeBody = hlds_du_type(_, _, CheaperTagTest, _, _, _, _, _) + ; + ( TypeBody = hlds_eqv_type(_) + ; TypeBody = hlds_foreign_type(_) + ; TypeBody = hlds_solver_type(_, _) + ; TypeBody = hlds_abstract_type(_) + ), + CheaperTagTest = no_cheaper_tag_test + ). + % In some of the cases where we return `no' here, % it would probably be OK to return `yes(0)'. % But it's safe to be conservative... diff --git a/compiler/hlds_goal.m b/compiler/hlds_goal.m index 5f3cdf6c2..b69f10555 100644 --- a/compiler/hlds_goal.m +++ b/compiler/hlds_goal.m @@ -19,6 +19,7 @@ :- import_module hlds.hlds_llds. :- import_module hlds.hlds_pred. +:- import_module hlds.hlds_data. :- import_module hlds.instmap. :- import_module mdbcomp.prim_data. :- import_module mdbcomp.program_representation. @@ -825,14 +826,28 @@ %-----------------------------------------------------------------------------% % -% Information for switches +% Information for switches. % :- type case ---> case( - case_functor :: cons_id, % functor to match with, - case_goal :: hlds_goal % goal to execute if match - % succeeds. + % The list of functors for which this case arm is applicable. + case_first_functor :: cons_id, + case_later_functors :: list(cons_id), + + % The code of the switch arm. + case_goal :: hlds_goal + ). + +:- type tagged_case + ---> tagged_case( + % The list of functors, and their tags, for which + % this case arm is applicable. + tagged_case_first_functor :: tagged_cons_id, + tagged_case_later_functors :: list(tagged_cons_id), + + % The code of the switch arm. + tagged_case_goal :: hlds_goal ). %-----------------------------------------------------------------------------% @@ -1564,7 +1579,7 @@ simple_call_id_pred_or_func(simple_call_id(PredOrFunc, _, _)) = PredOrFunc. %-----------------------------------------------------------------------------% % -% Information stored with all kinds of goals +% Information stored with all kinds of goals. % % This type has eight fields, which means that the Boehm collector @@ -2201,10 +2216,11 @@ rename_arg(Must, Subn, Arg0, Arg) :- list(case)::in, list(case)::out) is det. rename_vars_in_cases(_Must, _Subn, [], []). -rename_vars_in_cases(Must, Subn, - [case(Cons, G0) | Gs0], [case(Cons, G) | Gs]) :- - rename_vars_in_goal(Must, Subn, G0, G), - rename_vars_in_cases(Must, Subn, Gs0, Gs). +rename_vars_in_cases(Must, Subn, [Case0 | Cases0], [Case | Cases]) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), + rename_vars_in_goal(Must, Subn, Goal0, Goal), + Case = case(MainConsId, OtherConsIds, Goal), + rename_vars_in_cases(Must, Subn, Cases0, Cases). :- pred rename_unify_rhs(must_rename::in, prog_var_renaming::in, unify_rhs::in, unify_rhs::out) is det. @@ -2690,50 +2706,55 @@ goal_list_purity(Goals, GoalsPurity) :- %-----------------------------------------------------------------------------% -set_goal_contexts(Context, hlds_goal(GoalExpr0, GoalInfo0), - hlds_goal(GoalExpr, GoalInfo)) :- +set_goal_contexts(Context, Goal0, Goal) :- + Goal0 = hlds_goal(GoalExpr0, GoalInfo0), goal_info_set_context(Context, GoalInfo0, GoalInfo), - set_goal_contexts_2(Context, GoalExpr0, GoalExpr). + set_goal_contexts_expr(Context, GoalExpr0, GoalExpr), + Goal = hlds_goal(GoalExpr, GoalInfo). -:- pred set_goal_contexts_2(prog_context::in, hlds_goal_expr::in, +:- pred set_goal_contexts_case(prog_context::in, case::in, case::out) is det. + +set_goal_contexts_case(Context, Case0, Case) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), + set_goal_contexts(Context, Goal0, Goal), + Case = case(MainConsId, OtherConsIds, Goal). + +:- pred set_goal_contexts_expr(prog_context::in, hlds_goal_expr::in, hlds_goal_expr::out) is det. -set_goal_contexts_2(Context, conj(ConjType, Goals0), conj(ConjType, Goals)) :- +set_goal_contexts_expr(Context, conj(ConjType, Goals0), conj(ConjType, Goals)) :- list.map(set_goal_contexts(Context), Goals0, Goals). -set_goal_contexts_2(Context, disj(Goals0), disj(Goals)) :- +set_goal_contexts_expr(Context, disj(Goals0), disj(Goals)) :- list.map(set_goal_contexts(Context), Goals0, Goals). -set_goal_contexts_2(Context, if_then_else(Vars, Cond0, Then0, Else0), +set_goal_contexts_expr(Context, if_then_else(Vars, Cond0, Then0, Else0), if_then_else(Vars, Cond, Then, Else)) :- set_goal_contexts(Context, Cond0, Cond), set_goal_contexts(Context, Then0, Then), set_goal_contexts(Context, Else0, Else). -set_goal_contexts_2(Context, switch(Var, CanFail, Cases0), +set_goal_contexts_expr(Context, switch(Var, CanFail, Cases0), switch(Var, CanFail, Cases)) :- - list.map( - (pred(case(ConsId, Goal0)::in, case(ConsId, Goal)::out) is det :- - set_goal_contexts(Context, Goal0, Goal) - ), Cases0, Cases). -set_goal_contexts_2(Context, scope(Reason, Goal0), scope(Reason, Goal)) :- + list.map(set_goal_contexts_case(Context), Cases0, Cases). +set_goal_contexts_expr(Context, scope(Reason, Goal0), scope(Reason, Goal)) :- set_goal_contexts(Context, Goal0, Goal). -set_goal_contexts_2(Context, negation(Goal0), negation(Goal)) :- +set_goal_contexts_expr(Context, negation(Goal0), negation(Goal)) :- set_goal_contexts(Context, Goal0, Goal). -set_goal_contexts_2(_, Goal, Goal) :- +set_goal_contexts_expr(_, Goal, Goal) :- Goal = plain_call(_, _, _, _, _, _). -set_goal_contexts_2(_, Goal, Goal) :- +set_goal_contexts_expr(_, Goal, Goal) :- Goal = generic_call(_, _, _, _). -set_goal_contexts_2(_, Goal, Goal) :- +set_goal_contexts_expr(_, Goal, Goal) :- Goal = unify(_, _, _, _, _). -set_goal_contexts_2(_, Goal, Goal) :- +set_goal_contexts_expr(_, Goal, Goal) :- Goal = call_foreign_proc(_, _, _, _, _, _, _). -set_goal_contexts_2(Context, shorthand(ShorthandGoal0), - shorthand(ShorthandGoal)) :- - set_goal_contexts_2_shorthand(Context, ShorthandGoal0, ShorthandGoal). +set_goal_contexts_expr(Context, + shorthand(ShorthandGoal0), shorthand(ShorthandGoal)) :- + set_goal_contexts_shorthand(Context, ShorthandGoal0, ShorthandGoal). -:- pred set_goal_contexts_2_shorthand(prog_context::in, +:- pred set_goal_contexts_shorthand(prog_context::in, shorthand_goal_expr::in, shorthand_goal_expr::out) is det. -set_goal_contexts_2_shorthand(Context, bi_implication(LHS0, RHS0), - bi_implication(LHS, RHS)) :- +set_goal_contexts_shorthand(Context, + bi_implication(LHS0, RHS0), bi_implication(LHS, RHS)) :- set_goal_contexts(Context, LHS0, LHS), set_goal_contexts(Context, RHS0, RHS). diff --git a/compiler/hlds_out.m b/compiler/hlds_out.m index eb20ad23f..eea12bcb5 100644 --- a/compiler/hlds_out.m +++ b/compiler/hlds_out.m @@ -35,6 +35,7 @@ :- import_module hlds.hlds_args. :- import_module hlds.hlds_clauses. +:- import_module hlds.hlds_data. :- import_module hlds.hlds_goal. :- import_module hlds.hlds_module. :- import_module hlds.hlds_pred. @@ -85,6 +86,14 @@ % :- func call_arg_id_to_string(call_id, int, pred_markers) = string. +:- type is_first + ---> is_first + ; is_not_first. + +:- type is_last + ---> is_last + ; is_not_last. + % unify_context_to_pieces generates a message such as % foo.m:123: in argument 3 of functor `foo/5': % foo.m:123: in unification of `X' and `blah': @@ -103,7 +112,8 @@ % The bool returned as the second argument will be `no' unless nothing % was generated, in which case it will be the same as the first arg. % -:- pred unify_context_first_to_pieces(bool::in, bool::out, unify_context::in, +:- pred unify_context_first_to_pieces(is_first::in, is_first::out, + unify_context::in, list(format_component)::in, list(format_component)::out) is det. :- func determinism_to_string(determinism) = string. @@ -246,6 +256,20 @@ :- func mercury_expanded_inst_to_string(mer_inst, inst_varset, module_info) = string. +%-----------------------------------------------------------------------------% + + % Given a tagged cons_id, return the name of the cons_id and the tag. + % +:- pred project_cons_name_and_tag(tagged_cons_id::in, string::out, + cons_tag::out) is det. + + % case_comment(VarName, MainConsName, OtherConsNames) = Comment: + % + % Create a comment describing the arm of the switch on VarName that covers + % MainConsName and OtherConsNames. + % +:- func case_comment(string, string, list(string)) = string. + %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -514,7 +538,7 @@ arg_number_to_string(generic_call_id(gcid_cast(_)), ArgNum) = %-----------------------------------------------------------------------------% unify_context_to_pieces(UnifyContext, !Pieces) :- - unify_context_first_to_pieces(no, _, UnifyContext, !Pieces). + unify_context_first_to_pieces(is_not_first, _, UnifyContext, !Pieces). unify_context_first_to_pieces(!First, UnifyContext, !Pieces) :- UnifyContext = unify_context(MainContext, RevSubContexts), @@ -522,25 +546,25 @@ unify_context_first_to_pieces(!First, UnifyContext, !Pieces) :- unify_main_context_to_pieces(!First, MainContext, !Pieces), unify_sub_contexts_to_pieces(!First, SubContexts, !Pieces). -:- pred unify_main_context_to_pieces(bool::in, bool::out, +:- pred unify_main_context_to_pieces(is_first::in, is_first::out, unify_main_context::in, list(format_component)::in, list(format_component)::out) is det. unify_main_context_to_pieces(!First, umc_explicit, !Pieces). unify_main_context_to_pieces(!First, umc_head(ArgNum), !Pieces) :- start_in_message_to_pieces(!.First, !Pieces), - !:First = no, + !:First = is_not_first, ArgNumStr = int_to_string(ArgNum), !:Pieces = !.Pieces ++ [words("argument"), fixed(ArgNumStr), words("of clause head:"), nl]. unify_main_context_to_pieces(!First, umc_head_result, !Pieces) :- start_in_message_to_pieces(!.First, !Pieces), - !:First = no, + !:First = is_not_first, !:Pieces = !.Pieces ++ [words("function result term of clause head:"), nl]. unify_main_context_to_pieces(!First, umc_call(CallId, ArgNum), !Pieces) :- start_in_message_to_pieces(!.First, !Pieces), - !:First = no, + !:First = is_not_first, % The markers argument below is used only for type class method % implementations defined using the named syntax rather than % the clause syntax, and the bodies of such procedures should @@ -556,7 +580,7 @@ unify_main_context_to_pieces(!First, umc_implicit(Source), !Pieces) :- string.format("implicit %s unification:\n", [s(Source)], Msg), !:Pieces = !.Pieces ++ [words(Msg), nl]. -:- pred unify_sub_contexts_to_pieces(bool::in, bool::out, +:- pred unify_sub_contexts_to_pieces(is_first::in, is_first::out, unify_sub_contexts::in, list(format_component)::in, list(format_component)::out) is det. @@ -567,11 +591,11 @@ unify_sub_contexts_to_pieces(!First, [SubContext | SubContexts], !Pieces) :- 0, ElementNum, AfterContexts) -> in_element_to_pieces(!.First, ElementNum, !Pieces), - !:First = no, + !:First = is_not_first, unify_sub_contexts_to_pieces(!First, AfterContexts, !Pieces) ; in_argument_to_pieces(!.First, SubContext, !Pieces), - !:First = no, + !:First = is_not_first, unify_sub_contexts_to_pieces(!First, SubContexts, !Pieces) ). @@ -598,7 +622,7 @@ contexts_describe_list_element([SubContext | SubContexts], NumElementsBefore + 1, ElementNum, AfterContexts) ). -:- pred in_argument_to_pieces(bool::in, pair(cons_id, int)::in, +:- pred in_argument_to_pieces(is_first::in, pair(cons_id, int)::in, list(format_component)::in, list(format_component)::out) is det. in_argument_to_pieces(First, SubContext, !Pieces) :- @@ -609,7 +633,7 @@ in_argument_to_pieces(First, SubContext, !Pieces) :- words("of functor"), prefix("`"), fixed(cons_id_to_string(ConsId)), suffix("':"), nl]. -:- pred in_element_to_pieces(bool::in, int::in, +:- pred in_element_to_pieces(is_first::in, int::in, list(format_component)::in, list(format_component)::out) is det. in_element_to_pieces(First, ElementNum, !Pieces) :- @@ -618,17 +642,17 @@ in_element_to_pieces(First, ElementNum, !Pieces) :- !:Pieces = !.Pieces ++ [words("list element"), prefix("#"), fixed(ElementNumStr), suffix(":"), nl]. -:- pred start_in_message_to_pieces(bool::in, +:- pred start_in_message_to_pieces(is_first::in, list(format_component)::in, list(format_component)::out) is det. start_in_message_to_pieces(First, !Pieces) :- ( - First = yes, + First = is_first, % It is possible for First to be yes and !.Pieces to be nonempty, % since !.Pieces may contain stuff from before the unify context. !:Pieces = !.Pieces ++ [words("In")] ; - First = no, + First = is_not_first, !:Pieces = !.Pieces ++ [words("in")] ). @@ -2383,66 +2407,72 @@ write_unification(construct(Var, ConsId, ArgVars, ArgModes, ConstructHow, io.write_string(" := ", !IO), write_functor_and_submodes(ConsId, ArgVars, ArgModes, ModuleInfo, ProgVarSet, InstVarSet, AppendVarNums, Indent, !IO), - ( - Uniqueness = cell_is_unique, - write_indent(Indent, !IO), - io.write_string("% cell_is_unique\n", !IO) - ; - Uniqueness = cell_is_shared - ), - ( - SubInfo = no_construct_sub_info - ; - SubInfo = construct_sub_info(MaybeTakeAddr, MaybeSize), + + globals.io_lookup_string_option(dump_hlds_options, Verbose, !IO), + ( string.contains_char(Verbose, 'u') -> ( - MaybeTakeAddr = yes(TakeAddressFields), + Uniqueness = cell_is_unique, write_indent(Indent, !IO), - io.write_string("% take address fields: ", !IO), - write_intlist(TakeAddressFields, !IO), - io.write_string("\n", !IO) + io.write_string("% cell_is_unique\n", !IO) ; - MaybeTakeAddr = no + Uniqueness = cell_is_shared ), ( - MaybeSize = yes(SizeSource), - write_indent(Indent, !IO), - io.write_string("% term size ", !IO), + SubInfo = no_construct_sub_info + ; + SubInfo = construct_sub_info(MaybeTakeAddr, MaybeSize), ( - SizeSource = known_size(KnownSize), - io.write_string("const ", !IO), - io.write_int(KnownSize, !IO), + MaybeTakeAddr = yes(TakeAddressFields), + write_indent(Indent, !IO), + io.write_string("% take address fields: ", !IO), + write_intlist(TakeAddressFields, !IO), io.write_string("\n", !IO) ; - SizeSource = dynamic_size(SizeVar), - io.write_string("var ", !IO), - mercury_output_var(ProgVarSet, AppendVarNums, SizeVar, !IO), - io.write_string("\n", !IO) + MaybeTakeAddr = no + ), + ( + MaybeSize = yes(SizeSource), + write_indent(Indent, !IO), + io.write_string("% term size ", !IO), + ( + SizeSource = known_size(KnownSize), + io.write_string("const ", !IO), + io.write_int(KnownSize, !IO), + io.write_string("\n", !IO) + ; + SizeSource = dynamic_size(SizeVar), + io.write_string("var ", !IO), + mercury_output_var(ProgVarSet, AppendVarNums, SizeVar, !IO), + io.write_string("\n", !IO) + ) + ; + MaybeSize = no ) + ), + ( + ConstructHow = construct_dynamically ; - MaybeSize = no + ConstructHow = construct_statically(StaticConsList), + write_indent(Indent, !IO), + io.write_string("% construct statically\n", !IO), + list.foldl(write_static_cons(Indent, 1, ProgVarSet, AppendVarNums), + StaticConsList, !IO) + ; + ConstructHow = reuse_cell(CellToReuse), + CellToReuse = cell_to_reuse(ReuseVar, _ReuseConsIds, _FieldAssigns), + write_indent(Indent, !IO), + io.write_string("% reuse cell: ", !IO), + mercury_output_var(ProgVarSet, AppendVarNums, ReuseVar, !IO), + io.write_string("\n", !IO) + ; + ConstructHow = construct_in_region(RegVar), + write_indent(Indent, !IO), + io.write_string("% construct in region: ", !IO), + mercury_output_var(ProgVarSet, AppendVarNums, RegVar, !IO), + io.write_string("\n", !IO) ) - ), - ( - ConstructHow = construct_dynamically ; - ConstructHow = construct_statically(StaticConsList), - write_indent(Indent, !IO), - io.write_string("% construct statically\n", !IO), - list.foldl(write_static_cons(Indent, 1, ProgVarSet, AppendVarNums), - StaticConsList, !IO) - ; - ConstructHow = reuse_cell(CellToReuse), - CellToReuse = cell_to_reuse(ReuseVar, _ReuseConsIds, _FieldAssigns), - write_indent(Indent, !IO), - io.write_string("% reuse cell: ", !IO), - mercury_output_var(ProgVarSet, AppendVarNums, ReuseVar, !IO), - io.write_string("\n", !IO) - ; - ConstructHow = construct_in_region(RegVar), - write_indent(Indent, !IO), - io.write_string("% construct in region: ", !IO), - mercury_output_var(ProgVarSet, AppendVarNums, RegVar, !IO), - io.write_string("\n", !IO) + true ). write_unification(deconstruct(Var, ConsId, ArgVars, ArgModes, CanFail, CanCGC), @@ -2903,13 +2933,14 @@ write_goal_list(GoalList, ModuleInfo, VarSet, AppendVarNums, Indent, Separator, :- pred write_case(case::in, prog_var::in, module_info::in, prog_varset::in, bool::in, int::in, maybe_vartypes::in, io::di, io::uo) is det. -write_case(case(ConsId, Goal), Var, ModuleInfo, VarSet, AppendVarNums, Indent, - VarTypes, !IO) :- +write_case(case(MainConsId, OtherConsIds, Goal), Var, ModuleInfo, + VarSet, AppendVarNums, Indent, VarTypes, !IO) :- write_indent(Indent, !IO), io.write_string("% ", !IO), mercury_output_var(VarSet, AppendVarNums, Var, !IO), io.write_string(" has functor ", !IO), - write_cons_id(ConsId, !IO), + write_cons_id(MainConsId, !IO), + list.foldl(write_alternative_cons_id, OtherConsIds, !IO), io.write_string("\n", !IO), % XXX if the output of this is to be used, e.g. in % inter-module optimization, output a unification to bind the @@ -2919,6 +2950,12 @@ write_case(case(ConsId, Goal), Var, ModuleInfo, VarSet, AppendVarNums, Indent, write_goal_a(Goal, ModuleInfo, VarSet, AppendVarNums, Indent, "\n", VarTypes, !IO). +:- pred write_alternative_cons_id(cons_id::in, io::di, io::uo) is det. + +write_alternative_cons_id(ConsId, !IO) :- + io.write_string(" or ", !IO), + write_cons_id(ConsId, !IO). + :- pred write_cases(list(case)::in, prog_var::in, module_info::in, prog_varset::in, bool::in, int::in, maybe_vartypes::in, io::di, io::uo) is det. @@ -3318,9 +3355,25 @@ write_type_params_2(TVarSet, [P | Ps], !IO) :- :- pred write_type_body(int::in, tvarset::in, hlds_type_body::in, io::di, io::uo) is det. -write_type_body(Indent, TVarSet, hlds_du_type(Ctors, Tags, EnumDummy, - MaybeUserEqComp, ReservedTag, ReservedAddr, Foreign), !IO) :- +write_type_body(Indent, TVarSet, DuType, !IO) :- + DuType = hlds_du_type(Ctors, ConsTagMap, CheaperTagTest, EnumDummy, + MaybeUserEqComp, ReservedTag, ReservedAddr, Foreign), io.write_string(" --->\n", !IO), + ( + CheaperTagTest = no_cheaper_tag_test + ; + CheaperTagTest = cheaper_tag_test(ExpConsId, ExpConsTag, + CheapConsId, CheapConsTag), + io.write_string("/* cheaper tag test: ", !IO), + write_cons_id(ExpConsId, !IO), + io.write_string(" tag ", !IO), + io.print(ExpConsTag, !IO), + io.write_string(" -> ", !IO), + write_cons_id(CheapConsId, !IO), + io.write_string(" tag ", !IO), + io.print(CheapConsTag, !IO), + io.write_string(" */\n", !IO) + ), ( EnumDummy = is_mercury_enum, write_indent(Indent, !IO), @@ -3352,7 +3405,7 @@ write_type_body(Indent, TVarSet, hlds_du_type(Ctors, Tags, EnumDummy, ; ReservedAddr = does_not_use_reserved_address ), - write_constructors(Indent, TVarSet, Ctors, Tags, !IO), + write_constructors(Indent, TVarSet, Ctors, ConsTagMap, !IO), mercury_output_where_attributes(TVarSet, no, MaybeUserEqComp, !IO), ( Foreign = yes(_), @@ -4549,6 +4602,23 @@ write_is_conditional(IsConditional, !IO) :- IsConditional = unconditional_reuse, io.write_string("always safe", !IO) ). + +%-----------------------------------------------------------------------------% + +project_cons_name_and_tag(TaggedConsId, ConsName, ConsTag) :- + TaggedConsId = tagged_cons_id(ConsId, ConsTag), + ConsName = hlds_out.cons_id_to_string(ConsId). + +case_comment(VarName, MainConsName, OtherConsNames) = Comment :- + ( + OtherConsNames = [], + Comment = VarName ++ " has the functor " ++ MainConsName + ; + OtherConsNames = [_ | _], + Comment = VarName ++ " has one of the functors " ++ + string.join_list(", ", [MainConsName | OtherConsNames]) + ). + %-----------------------------------------------------------------------------% :- func this_file = string. diff --git a/compiler/implicit_parallelism.m b/compiler/implicit_parallelism.m index 569f9910f..9d235d806 100644 --- a/compiler/implicit_parallelism.m +++ b/compiler/implicit_parallelism.m @@ -836,10 +836,11 @@ process_switch_cases_for_implicit_parallelism([], !CasesAcc, _ProcInfo, !ModuleInfo, !CalleeListToBeParallelized, !SiteNumCounter). process_switch_cases_for_implicit_parallelism([Case0 | Cases], !CasesAcc, ProcInfo, !ModuleInfo, !CalleeListToBeParallelized, !SiteNumCounter) :- - Case0 = case(Functor, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), process_goal_for_implicit_parallelism(Goal0, Goal, ProcInfo, !ModuleInfo, no, _, 0, _, !CalleeListToBeParallelized, !SiteNumCounter), - !:CasesAcc = !.CasesAcc ++ [case(Functor, Goal)], + Case = case(MainConsId, OtherConsIds, Goal), + !:CasesAcc = !.CasesAcc ++ [Case], process_switch_cases_for_implicit_parallelism(Cases, !CasesAcc, ProcInfo, !ModuleInfo, !CalleeListToBeParallelized, !SiteNumCounter). diff --git a/compiler/inlining.m b/compiler/inlining.m index 49f5c1b1b..4f173bdb2 100644 --- a/compiler/inlining.m +++ b/compiler/inlining.m @@ -835,10 +835,11 @@ inlining_in_goals([Goal0 | Goals0], [Goal | Goals], !Info) :- inline_info::in, inline_info::out) is det. inlining_in_cases([], [], !Info). -inlining_in_cases([case(Cons, Goal0) | Goals0], [case(Cons, Goal) | Goals], - !Info) :- +inlining_in_cases([Case0 | Cases0], [Case | Cases], !Info) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), inlining_in_goal(Goal0, Goal, !Info), - inlining_in_cases(Goals0, Goals, !Info). + Case = case(MainConsId, OtherConsIds, Goal), + inlining_in_cases(Cases0, Cases, !Info). %-----------------------------------------------------------------------------% diff --git a/compiler/inst_check.m b/compiler/inst_check.m index a0454990f..cf467cf3e 100644 --- a/compiler/inst_check.m +++ b/compiler/inst_check.m @@ -291,7 +291,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/inst_match.m b/compiler/inst_match.m index a633bf66a..20c01614f 100644 --- a/compiler/inst_match.m +++ b/compiler/inst_match.m @@ -2018,16 +2018,12 @@ mode_contains_inst_var(Mode, InstVar) :- maybe_any_to_bound(yes(Type), ModuleInfo, Uniq, Inst) :- \+ type_util.is_solver_type(ModuleInfo, Type), - ( - type_constructors(Type, ModuleInfo, Constructors) - -> + ( type_constructors(ModuleInfo, Type, Constructors) -> constructors_to_bound_any_insts(ModuleInfo, Uniq, Constructors, BoundInsts0), list.sort_and_remove_dups(BoundInsts0, BoundInsts), Inst = bound(Uniq, BoundInsts) - ; - type_may_contain_solver_type(Type, ModuleInfo) - -> + ; type_may_contain_solver_type(ModuleInfo, Type) -> % For a type for which constructors are not available (e.g. an % abstract type) and which may contain solver types, we fail, meaning % that we will use `any' for this type. @@ -2036,9 +2032,9 @@ maybe_any_to_bound(yes(Type), ModuleInfo, Uniq, Inst) :- Inst = ground(Uniq, none) ). -:- pred type_may_contain_solver_type(mer_type::in, module_info::in) is semidet. +:- pred type_may_contain_solver_type(module_info::in, mer_type::in) is semidet. -type_may_contain_solver_type(Type, ModuleInfo) :- +type_may_contain_solver_type(ModuleInfo, Type) :- type_may_contain_solver_type_2(classify_type(ModuleInfo, Type)) = yes. :- func type_may_contain_solver_type_2(type_category) = bool. diff --git a/compiler/inst_util.m b/compiler/inst_util.m index 600ce7aea..4409b3b24 100644 --- a/compiler/inst_util.m +++ b/compiler/inst_util.m @@ -1625,7 +1625,7 @@ inst_merge_bound_ground(UniqA, ListA, UniqB, MaybeType, Result, !ModuleInfo) :- % just "any". ( MaybeType = yes(Type), - type_constructors(Type, !.ModuleInfo, Constructors), + type_constructors(!.ModuleInfo, Type, Constructors), constructors_to_bound_insts(!.ModuleInfo, UniqB, Constructors, ListB0), list.sort_and_remove_dups(ListB0, ListB), diff --git a/compiler/instmap.m b/compiler/instmap.m index 7777bfbed..e201fb696 100644 --- a/compiler/instmap.m +++ b/compiler/instmap.m @@ -149,8 +149,7 @@ % Set an entry in an instmap. % -:- pred set(prog_var::in, mer_inst::in, instmap::in, instmap::out) - is det. +:- pred set(prog_var::in, mer_inst::in, instmap::in, instmap::out) is det. % Set multiple entries in an instmap. % @@ -167,9 +166,18 @@ cons_id::in, instmap::in, instmap_delta::in, instmap_delta::out, module_info::in, module_info::out) is det. +:- pred instmap_delta_bind_var_to_functors(prog_var::in, mer_type::in, + cons_id::in, list(cons_id)::in, instmap::in, + instmap_delta::in, instmap_delta::out, + module_info::in, module_info::out) is det. + :- pred bind_var_to_functor(prog_var::in, mer_type::in, cons_id::in, instmap::in, instmap::out, module_info::in, module_info::out) is det. +:- pred bind_var_to_functors(prog_var::in, mer_type::in, + cons_id::in, list(cons_id)::in, instmap::in, instmap::out, + module_info::in, module_info::out) is det. + % Update the given instmap to include the initial insts of the % lambda variables. % @@ -538,7 +546,7 @@ instmap_delta_bind_var_to_functor(Var, Type, ConsId, InstMap, !InstmapDelta, ; !.InstmapDelta = reachable(InstmappingDelta0), - % Get the initial inst from the InstMap + % Get the initial inst from the InstMap. lookup_var(InstMap, Var, OldInst), % Compute the new inst by taking the old inst, applying the instmap @@ -558,11 +566,46 @@ instmap_delta_bind_var_to_functor(Var, Type, ConsId, InstMap, !InstmapDelta, ) ). +instmap_delta_bind_var_to_functors(Var, Type, MainConsId, OtherConsIds, + InstMap, !InstmapDelta, !ModuleInfo) :- + ( + !.InstmapDelta = unreachable + ; + !.InstmapDelta = reachable(InstmappingDelta0), + + % Get the initial inst from the InstMap. + lookup_var(InstMap, Var, OldInst), + + % Compute the new inst by taking the old inst, applying the instmap + % delta to it, and then unifying with bound(MainConsId, ...). + ( map.search(InstmappingDelta0, Var, NewInst0) -> + NewInst1 = NewInst0 + ; + NewInst1 = OldInst + ), + bind_inst_to_functors(Type, MainConsId, OtherConsIds, + NewInst1, NewInst, !ModuleInfo), + + % Add `Var :: OldInst -> NewInst' to the instmap delta. + ( NewInst \= OldInst -> + instmap_delta_set(Var, NewInst, !InstmapDelta) + ; + true + ) + ). + bind_var_to_functor(Var, Type, ConsId, !InstMap, !ModuleInfo) :- lookup_var(!.InstMap, Var, Inst0), bind_inst_to_functor(Type, ConsId, Inst0, Inst, !ModuleInfo), set(Var, Inst, !InstMap). +bind_var_to_functors(Var, Type, MainConsId, OtherConsIds, + !InstMap, !ModuleInfo) :- + lookup_var(!.InstMap, Var, Inst0), + bind_inst_to_functors(Type, MainConsId, OtherConsIds, Inst0, Inst, + !ModuleInfo), + set(Var, Inst, !InstMap). + :- pred bind_inst_to_functor(mer_type::in, cons_id::in, mer_inst::in, mer_inst::out, module_info::in, module_info::out) is det. @@ -579,6 +622,41 @@ bind_inst_to_functor(Type, ConsId, !Inst, !ModuleInfo) :- unexpected(this_file, "bind_inst_to_functor: mode error") ). +:- pred bind_inst_to_functors(mer_type::in, cons_id::in, list(cons_id)::in, + mer_inst::in, mer_inst::out, module_info::in, module_info::out) is det. + +bind_inst_to_functors(Type, MainConsId, OtherConsIds, InitInst, FinalInst, + !ModuleInfo) :- + bind_inst_to_functor(Type, MainConsId, InitInst, + MainFinalInst, !ModuleInfo), + bind_inst_to_functors_others(Type, OtherConsIds, InitInst, + OtherFinalInsts, !ModuleInfo), + merge_var_insts([MainFinalInst | OtherFinalInsts], Type, !ModuleInfo, + MaybeMergedInst), + ( + MaybeMergedInst = yes(FinalInst) + ; + MaybeMergedInst = no, + % bind_inst_to_functors should be called only when multi-cons-id + % switches are being or have been introduced into the HLDS, which + % should come only after mode checking has been done without finding + % any errors. Finding an error now would mean that some compiler pass + % executed between mode checking and how has screwed up. + unexpected(this_file, + "bind_inst_to_functors: no MaybeMergedInst") + ). + +:- pred bind_inst_to_functors_others(mer_type::in, list(cons_id)::in, + mer_inst::in, list(mer_inst)::out, module_info::in, module_info::out) + is det. + +bind_inst_to_functors_others(_Type, [], _InitInst, [], !ModuleInfo). +bind_inst_to_functors_others(Type, [ConsId | ConsIds], InitInst, + [FinalInst | FinalInsts], !ModuleInfo) :- + bind_inst_to_functor(Type, ConsId, InitInst, FinalInst, !ModuleInfo), + bind_inst_to_functors_others(Type, ConsIds, InitInst, FinalInsts, + !ModuleInfo). + %-----------------------------------------------------------------------------% pre_lambda_update(ModuleInfo, Vars, Modes, InstMap0, InstMap) :- @@ -662,7 +740,7 @@ instmap_merge(NonLocals, InstMapList, MergeContext, !ModeInfo) :- -> set.to_sorted_list(NonLocals, NonLocalsList), mode_info_get_var_types(!.ModeInfo, VarTypes), - merge_2(NonLocalsList, InstMapList, VarTypes, + merge_insts_of_vars(NonLocalsList, InstMapList, VarTypes, InstMapping0, InstMapping, ModuleInfo0, ModuleInfo, ErrorList), mode_info_set_module_info(ModuleInfo, !ModeInfo), ( @@ -696,8 +774,8 @@ get_reachable_instmaps([InstMap | InstMaps], Reachables) :- %-----------------------------------------------------------------------------% - % merge_2(Vars, InstMapList, VarTypes, !InstMapping, !ModuleInfo, - % Errors): + % merge_insts_of_vars(Vars, InstMapList, VarTypes, !InstMapping, + % !ModuleInfo, Errors): % % Given Vars, a list of variables, and InstMapList, a list of instmaps % giving the insts of those variables (and possibly others) at the ends of @@ -713,18 +791,18 @@ get_reachable_instmaps([InstMap | InstMaps], Reachables) :- % If some variables in Vars have incompatible insts in two or more instmaps % in InstMapList, return them in `Errors'. % -:- pred merge_2(list(prog_var)::in, list(instmap)::in, vartypes::in, - instmapping::in, instmapping::out, module_info::in, module_info::out, - merge_errors::out) is det. +:- pred merge_insts_of_vars(list(prog_var)::in, list(instmap)::in, + vartypes::in, instmapping::in, instmapping::out, + module_info::in, module_info::out, merge_errors::out) is det. -merge_2([], _, _, !InstMap, !ModuleInfo, []). -merge_2([Var | Vars], InstMapList, VarTypes, !InstMapping, +merge_insts_of_vars([], _, _, !InstMap, !ModuleInfo, []). +merge_insts_of_vars([Var | Vars], InstMapList, VarTypes, !InstMapping, !ModuleInfo, !:ErrorList) :- - merge_2(Vars, InstMapList, VarTypes, !InstMapping, !ModuleInfo, - !:ErrorList), + merge_insts_of_vars(Vars, InstMapList, VarTypes, !InstMapping, + !ModuleInfo, !:ErrorList), map.lookup(VarTypes, Var, VarType), list.map(lookup_var_in_instmap(Var), InstMapList, InstList), - merge_var(InstList, Var, VarType, !ModuleInfo, MaybeInst), + merge_var_insts(InstList, VarType, !ModuleInfo, MaybeInst), ( MaybeInst = no, !:ErrorList = [merge_error(Var, InstList) | !.ErrorList], @@ -739,22 +817,21 @@ merge_2([Var | Vars], InstMapList, VarTypes, !InstMapping, lookup_var_in_instmap(Var, InstMap, Inst) :- lookup_var(InstMap, Var, Inst). - % merge_var(Insts, Var, Type, Inst, !ModuleInfo, !Error): + % merge_var_insts:(Insts, Type, !ModuleInfo, MaybeMergedInst): % - % Given a list of insts of the given variable that reflect the inst of that + % Given a list of insts of a given variable that reflect the inst of that % variable at the ends of a branched control structure such as a - % disjunction or if-then-else, return the final inst of that variable - % after the branched control structure as a whole. - % - % Set !:Error to yes if two insts of the variable are incompatible. + % disjunction or if-then-else, return either `yes(MergedInst)' where + % MergedInst is the final inst of that variable after the branched control + % structure as a whole, or `no' if some of the insts are not compatible. % % We used to use a straightforward algorithm that, given a list of N insts, % merged the tail N-1 insts, and merged the result with the head inst. % While this is simple and efficient for small N, it has very bad % performance for large N. The reason is that its complexity can be N^2, % since in many cases each arm of the branched control structure binds - % Var to a different function symbol, and this means that the inst of Var - % evolves like this: + % the variable to a different function symbol, and this means that the + % merged inst evolves like this: % % bound(f) % bound(f; g) @@ -765,13 +842,13 @@ lookup_var_in_instmap(Var, InstMap, Inst) :- % number of insts by four by merging groups of four adjacent insts. % The overall complexity is thus closer to N log N than N^2. % -:- pred merge_var(list(mer_inst)::in, prog_var::in, mer_type::in, +:- pred merge_var_insts(list(mer_inst)::in, mer_type::in, module_info::in, module_info::out, maybe(mer_inst)::out) is det. -merge_var(Insts, Var, Type, !ModuleInfo, MaybeMergedInst) :- - % Construct yes(Type) here once per merge_var pass to avoid merge_var_2 +merge_var_insts(Insts, Type, !ModuleInfo, MaybeMergedInst) :- + % Construct yes(Type) here once per merge_var pass to avoid merge_var_inst % constructing the yes(Type) cell N times per pass. - merge_var_2(Insts, Var, yes(Type), [], MergedInsts, !ModuleInfo, + merge_var_insts_pass(Insts, yes(Type), [], MergedInsts, !ModuleInfo, no, Error), ( Error = yes, @@ -786,15 +863,15 @@ merge_var(Insts, Var, Type, !ModuleInfo, MaybeMergedInst) :- MaybeMergedInst = yes(MergedInst) ; MergedInsts = [_, _ | _], - merge_var(MergedInsts, Var, Type, !ModuleInfo, MaybeMergedInst) + merge_var_insts(MergedInsts, Type, !ModuleInfo, MaybeMergedInst) ) ). -:- pred merge_var_2(list(mer_inst)::in, prog_var::in, maybe(mer_type)::in, +:- pred merge_var_insts_pass(list(mer_inst)::in, maybe(mer_type)::in, list(mer_inst)::in, list(mer_inst)::out, module_info::in, module_info::out, bool::in, bool::out) is det. -merge_var_2(Insts, Var, YesType, !MergedInsts, !ModuleInfo, !Error) :- +merge_var_insts_pass(Insts, MaybeType, !MergedInsts, !ModuleInfo, !Error) :- ( Insts = [] ; @@ -803,7 +880,7 @@ merge_var_2(Insts, Var, YesType, !MergedInsts, !ModuleInfo, !Error) :- ; Insts = [Inst1, Inst2], ( - inst_merge(Inst1, Inst2, YesType, Inst12, !ModuleInfo) + inst_merge(Inst1, Inst2, MaybeType, Inst12, !ModuleInfo) -> !:MergedInsts = [Inst12 | !.MergedInsts] ; @@ -812,8 +889,8 @@ merge_var_2(Insts, Var, YesType, !MergedInsts, !ModuleInfo, !Error) :- ; Insts = [Inst1, Inst2, Inst3], ( - inst_merge(Inst1, Inst2, YesType, Inst12, !ModuleInfo), - inst_merge(Inst12, Inst3, YesType, Inst123, !ModuleInfo) + inst_merge(Inst1, Inst2, MaybeType, Inst12, !ModuleInfo), + inst_merge(Inst12, Inst3, MaybeType, Inst123, !ModuleInfo) -> !:MergedInsts = [Inst123 | !.MergedInsts] ; @@ -822,13 +899,13 @@ merge_var_2(Insts, Var, YesType, !MergedInsts, !ModuleInfo, !Error) :- ; Insts = [Inst1, Inst2, Inst3, Inst4 | MoreInsts], ( - inst_merge(Inst1, Inst2, YesType, Inst12, !ModuleInfo), - inst_merge(Inst3, Inst4, YesType, Inst34, !ModuleInfo), - inst_merge(Inst12, Inst34, YesType, Inst1234, !ModuleInfo) + inst_merge(Inst1, Inst2, MaybeType, Inst12, !ModuleInfo), + inst_merge(Inst3, Inst4, MaybeType, Inst34, !ModuleInfo), + inst_merge(Inst12, Inst34, MaybeType, Inst1234, !ModuleInfo) -> !:MergedInsts = [Inst1234 | !.MergedInsts], - merge_var_2(MoreInsts, Var, YesType, !MergedInsts, !ModuleInfo, - !Error) + merge_var_insts_pass(MoreInsts, MaybeType, !MergedInsts, + !ModuleInfo, !Error) ; !:Error = yes ) @@ -909,11 +986,11 @@ instmap_unify(NonLocals, InstMapList, !ModeInfo) :- InstMap0 = reachable(InstMapping0) -> % Having got the first instmapping, to use as an accumulator, - % all unify_2 which unifies each of the nonlocals from + % call unify_insts_of_vars which unifies each of the nonlocals from % each instmap with the corresponding inst in the accumulator. mode_info_get_module_info(!.ModeInfo, ModuleInfo0), set.to_sorted_list(NonLocals, NonLocalsList), - unify_2(NonLocalsList, InstMap0, InstMapList1, + unify_insts_of_vars(NonLocalsList, InstMap0, InstMapList1, ModuleInfo0, ModuleInfo, InstMapping0, InstMapping, ErrorList), mode_info_set_module_info(ModuleInfo, !ModeInfo), @@ -935,49 +1012,49 @@ instmap_unify(NonLocals, InstMapList, !ModeInfo) :- %-----------------------------------------------------------------------------% - % unify_2(Vars, InitialInstMap, InstMaps, !ModuleInfo, + % unify_insts_of_vars(Vars, InitialInstMap, InstMaps, !ModuleInfo, % !Instmap, ErrorList): % % Let `ErrorList' be the list of variables in `Vars' for which there are % two instmaps in `InstMaps' for which the insts of the variable is % incompatible. % -:- pred unify_2(list(prog_var)::in, instmap::in, +:- pred unify_insts_of_vars(list(prog_var)::in, instmap::in, list(pair(instmap, set(prog_var)))::in, module_info::in, module_info::out, map(prog_var, mer_inst)::in, map(prog_var, mer_inst)::out, merge_errors::out) is det. -unify_2([], _, _, !ModuleInfo, !InstMap, []). -unify_2([Var|Vars], InitialInstMap, InstMapList, +unify_insts_of_vars([], _, _, !ModuleInfo, !InstMap, []). +unify_insts_of_vars([Var | Vars], InitialInstMap, InstMapList, !ModuleInfo, !InstMap, ErrorList) :- - unify_2(Vars, InitialInstMap, InstMapList, !ModuleInfo, !InstMap, - ErrorListTail), + unify_insts_of_vars(Vars, InitialInstMap, InstMapList, !ModuleInfo, + !InstMap, ErrorListTail), lookup_var(InitialInstMap, Var, InitialVarInst), - unify_var(InstMapList, Var, [], Insts, InitialVarInst, Inst, + unify_var_insts(InstMapList, Var, [], Insts, InitialVarInst, Inst, !ModuleInfo, no, Error), ( Error = yes, - ErrorList = [ merge_error(Var, Insts) | ErrorListTail] + ErrorList = [merge_error(Var, Insts) | ErrorListTail] ; Error = no, ErrorList = ErrorListTail ), map.set(!.InstMap, Var, Inst, !:InstMap). - % unify_var(InstMaps, Var, InitialInstMap, ModuleInfo, + % unify_var_insts(InstMaps, Var, InitialInstMap, ModuleInfo, % Insts, Error): % % Let `Insts' be the list of the inst of `Var' in each of the % corresponding `InstMaps'. Let `Error' be yes iff there are two % instmaps for which the inst of `Var' is incompatible. % -:- pred unify_var(list(pair(instmap, set(prog_var)))::in, +:- pred unify_var_insts(list(pair(instmap, set(prog_var)))::in, prog_var::in, list(mer_inst)::in, list(mer_inst)::out, mer_inst::in, mer_inst::out, module_info::in, module_info::out, bool::in, bool::out) is det. -unify_var([], _, !Insts, !Inst, !ModuleInfo, !Error). -unify_var([InstMap - Nonlocals| Rest], Var, !InstList, !Inst, +unify_var_insts([], _, !Insts, !Inst, !ModuleInfo, !Error). +unify_var_insts([InstMap - Nonlocals| Rest], Var, !InstList, !Inst, !ModuleInfo, !Error) :- ( set.member(Var, Nonlocals) -> lookup_var(InstMap, Var, VarInst), @@ -997,7 +1074,7 @@ unify_var([InstMap - Nonlocals| Rest], Var, !InstList, !Inst, VarInst = free ), !:InstList = [VarInst | !.InstList], - unify_var(Rest, Var, !InstList, !Inst, !ModuleInfo, !Error). + unify_var_insts(Rest, Var, !InstList, !Inst, !ModuleInfo, !Error). %-----------------------------------------------------------------------------% @@ -1019,7 +1096,7 @@ compute_instmap_delta_2([Var | Vars], InstMapA, InstMapB, AssocList) :- ( InstA = InstB -> AssocList1 = AssocList ; - AssocList = [ Var - InstB | AssocList1 ] + AssocList = [Var - InstB | AssocList1] ), compute_instmap_delta_2(Vars, InstMapA, InstMapB, AssocList1). @@ -1035,8 +1112,7 @@ no_output_vars(InstMap0, reachable(InstMapDelta), Vars, VT, M) :- instmapping::in, vartypes::in, module_info::in) is semidet. no_output_vars_2([], _, _, _, _). -no_output_vars_2([Var | Vars], InstMap0, InstMapDelta, VarTypes, - ModuleInfo) :- +no_output_vars_2([Var | Vars], InstMap0, InstMapDelta, VarTypes, ModuleInfo) :- % We use `inst_matches_binding' to check that the new inst has only % added information or lost uniqueness, not bound anything. % If the instmap delta contains the variable, the variable may still diff --git a/compiler/intermod.m b/compiler/intermod.m index fae4e037b..63aca8d62 100644 --- a/compiler/intermod.m +++ b/compiler/intermod.m @@ -527,7 +527,8 @@ intermod_traverse_goal_expr(shorthand(_), _, _, _, _) :- bool::out, intermod_info::in, intermod_info::out) is det. intermod_traverse_list_of_goals([], [], yes, !Info). -intermod_traverse_list_of_goals([Goal0 | Goals0], [Goal | Goals], !:DoWrite, !Info) :- +intermod_traverse_list_of_goals([Goal0 | Goals0], [Goal | Goals], !:DoWrite, + !Info) :- intermod_traverse_goal(Goal0, Goal, !:DoWrite, !Info), ( !.DoWrite = yes, @@ -541,9 +542,10 @@ intermod_traverse_list_of_goals([Goal0 | Goals0], [Goal | Goals], !:DoWrite, !In intermod_info::in, intermod_info::out) is det. intermod_traverse_cases([], [], yes, !Info). -intermod_traverse_cases([case(F, Goal0) | Cases0], - [case(F, Goal) | Cases], !:DoWrite, !Info) :- +intermod_traverse_cases([Case0 | Cases0], [Case | Cases], !:DoWrite, !Info) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), intermod_traverse_goal(Goal0, Goal, !:DoWrite, !Info), + Case = case(MainConsId, OtherConsIds, Goal), ( !.DoWrite = yes, intermod_traverse_cases(Cases0, Cases, !:DoWrite, !Info) @@ -973,8 +975,8 @@ gather_types_2(TypeCtor, TypeDefn0, !Info) :- ( should_write_type(ModuleName, TypeCtor, TypeDefn0) -> hlds_data.get_type_defn_body(TypeDefn0, TypeBody0), ( - TypeBody0 = hlds_du_type(Ctors, Tags, Enum, MaybeUserEqComp0, - ReservedTag, ReservedAddr, MaybeForeign0), + TypeBody0 = hlds_du_type(Ctors, Tags, CheaperTagTest, Enum, + MaybeUserEqComp0, ReservedTag, ReservedAddr, MaybeForeign0), module_info_get_globals(ModuleInfo, Globals), globals.get_target(Globals, Target), @@ -1004,8 +1006,8 @@ gather_types_2(TypeCtor, TypeDefn0, !Info) :- MaybeUserEqComp0, MaybeUserEqComp, !Info), MaybeForeign = MaybeForeign0 ), - TypeBody = hlds_du_type(Ctors, Tags, Enum, MaybeUserEqComp, - ReservedTag, ReservedAddr, MaybeForeign), + TypeBody = hlds_du_type(Ctors, Tags, CheaperTagTest, Enum, + MaybeUserEqComp, ReservedTag, ReservedAddr, MaybeForeign), hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn) ; TypeBody0 = hlds_foreign_type(ForeignTypeBody0), @@ -1270,7 +1272,7 @@ write_type(TypeCtor - TypeDefn, !IO) :- hlds_data.get_type_defn_context(TypeDefn, Context), TypeCtor = type_ctor(Name, Arity), ( - Body = hlds_du_type(Ctors, _, _, MaybeUserEqComp, _, _, _), + Body = hlds_du_type(Ctors, _, _, _, MaybeUserEqComp, _, _, _), TypeBody = parse_tree_du_type(Ctors, MaybeUserEqComp) ; Body = hlds_eqv_type(EqvType), @@ -1361,7 +1363,7 @@ write_type(TypeCtor - TypeDefn, !IO) :- true ), ( - Body = hlds_du_type(_, ConsTagVals, EnumOrDummy, _, _, _, _), + Body = hlds_du_type(_, ConsTagVals, _, EnumOrDummy, _, _, _, _), EnumOrDummy = is_foreign_enum(Lang) -> map.foldl(gather_foreign_enum_value_pair, ConsTagVals, [], diff --git a/compiler/interval.m b/compiler/interval.m index 60c42a5ee..79d8d27b8 100644 --- a/compiler/interval.m +++ b/compiler/interval.m @@ -514,9 +514,10 @@ build_interval_info_in_disj([Goal | Goals], MaybeNeedsFlush, T::in, T::out) is det <= build_interval_info_acc(T). build_interval_info_in_cases([], _, _, _, _, [], !IntervalInfo, !Acc). -build_interval_info_in_cases([case(_Var, Goal) | Cases], +build_interval_info_in_cases([Case | Cases], StartAnchor, EndAnchor, BeforeId, AfterId, [OpenIntervals | OpenIntervalsList], !IntervalInfo, !Acc) :- + Case = case(_MainConsId, _OtherConsIds, Goal), enter_branch_tail(EndAnchor, AfterId, !IntervalInfo), build_interval_info_in_goal(Goal, !IntervalInfo, !Acc), reached_branch_start(doesnt_need_flush, StartAnchor, BeforeId, @@ -1180,11 +1181,12 @@ record_decisions_in_disj([Goal0 | Goals0], [Goal | Goals], !VarInfo, maybe(goal_feature)::in) is det. record_decisions_in_cases([], [], !VarInfo, _, _, _). -record_decisions_in_cases([case(Var, Goal0) | Cases0], - [case(Var, Goal) | Cases], !VarInfo, VarRename0, InsertMap, - MaybeFeature) :- +record_decisions_in_cases([Case0 | Cases0], [Case | Cases], + !VarInfo, VarRename0, InsertMap, MaybeFeature) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), record_decisions_in_goal(Goal0, Goal, !VarInfo, VarRename0, _, InsertMap, MaybeFeature), + Case = case(MainConsId, OtherConsIds, Goal), record_decisions_in_cases(Cases0, Cases, !VarInfo, VarRename0, InsertMap, MaybeFeature). diff --git a/compiler/jumpopt.m b/compiler/jumpopt.m index 3e052c82a..8c4af0d6a 100644 --- a/compiler/jumpopt.m +++ b/compiler/jumpopt.m @@ -512,14 +512,14 @@ jump_opt_instr_list([Instr0 | Instrs0], PrevInstr, Instrmap, Blockmap, NewRemain = usual_case ) ; - Uinstr0 = computed_goto(Index, LabelList0), + Uinstr0 = computed_goto(Index, Targets0), % Short-circuit all the destination labels. - short_labels(Instrmap, LabelList0, LabelList), - ( LabelList = LabelList0 -> + short_maybe_labels(Instrmap, Targets0, Targets), + ( Targets = Targets0 -> NewRemain = usual_case ; Shorted = Comment0 ++ " (some shortcircuits)", - NewInstrs = [llds_instr(computed_goto(Index, LabelList), Shorted)], + NewInstrs = [llds_instr(computed_goto(Index, Targets), Shorted)], NewRemain = specified(NewInstrs, Instrs0) ) ; @@ -968,12 +968,21 @@ short_label(Instrmap, Label0, Label) :- Label = Label0 ). -:- pred short_labels(instrmap::in, list(label)::in, list(label)::out) is det. +:- pred short_maybe_labels(instrmap::in, + list(maybe(label))::in, list(maybe(label))::out) is det. -short_labels(_Instrmap, [], []). -short_labels(Instrmap, [Label0 | Labels0], [Label | Labels]) :- - short_label(Instrmap, Label0, Label), - short_labels(Instrmap, Labels0, Labels). +short_maybe_labels(_Instrmap, [], []). +short_maybe_labels(Instrmap, [MaybeLabel0 | MaybeLabels0], + [MaybeLabel | MaybeLabels]) :- + ( + MaybeLabel0 = yes(Label0), + short_label(Instrmap, Label0, Label), + MaybeLabel = yes(Label) + ; + MaybeLabel0 = no, + MaybeLabel = no + ), + short_maybe_labels(Instrmap, MaybeLabels0, MaybeLabels). %-----------------------------------------------------------------------------% diff --git a/compiler/lambda.m b/compiler/lambda.m index 9878e49fd..81eb9deeb 100644 --- a/compiler/lambda.m +++ b/compiler/lambda.m @@ -271,9 +271,10 @@ lambda_process_goal_list([Goal0 | Goals0], [Goal | Goals], !Info) :- lambda_info::in, lambda_info::out) is det. lambda_process_cases([], [], !Info). -lambda_process_cases([case(ConsId, Goal0) | Cases0], - [case(ConsId, Goal) | Cases], !Info) :- +lambda_process_cases([Case0 | Cases0], [Case | Cases], !Info) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), lambda_process_goal(Goal0, Goal, !Info), + Case = case(MainConsId, OtherConsIds, Goal), lambda_process_cases(Cases0, Cases, !Info). :- pred lambda_process_unify_goal(prog_var::in, unify_rhs::in, unify_mode::in, diff --git a/compiler/lco.m b/compiler/lco.m index b04e11d2c..da6d28665 100644 --- a/compiler/lco.m +++ b/compiler/lco.m @@ -421,9 +421,10 @@ lco_in_disj([Goal0 | Goals0], [Goal | Goals], !Info, ConstInfo) :- lco_info::in, lco_info::out, lco_const_info::in) is det. lco_in_cases([], [], !Info, _ConstInfo). -lco_in_cases([case(Cons, Goal0) | Cases0], [case(Cons, Goal) | Cases], - !Info, ConstInfo) :- +lco_in_cases([Case0 | Cases0], [Case | Cases], !Info, ConstInfo) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), lco_in_goal(Goal0, Goal, !Info, ConstInfo), + Case = case(MainConsId, OtherConsIds, Goal), lco_in_cases(Cases0, Cases, !Info, ConstInfo). %-----------------------------------------------------------------------------% @@ -468,7 +469,7 @@ lco_in_conj([RevGoal | RevGoals], !.Unifies, !.UnifyInputVars, MaybeGoals, ), all_true(acceptable_construct_mode(ModuleInfo), ArgUniModes), map.lookup(VarTypes, ConstructedVar, ConstructedType), - ConsTag = cons_id_to_tag(ConsId, ConstructedType, ModuleInfo), + ConsTag = cons_id_to_tag(ModuleInfo, ConstructedType, ConsId), % The code generator can't handle the other tags. For example, it % doesn't make sense to take the address of the field of a function % symbol of a `notag' type. @@ -965,10 +966,12 @@ transform_variant_conj(ModuleInfo, VarToAddr, InstMap0, [Goal0 | Goals0], :- pred transform_variant_case(module_info::in, assoc_list(prog_var)::in, instmap::in, case::in, case::out, bool::out) is det. -transform_variant_case(ModuleInfo, VarToAddr, InstMap0, - case(ConsId, Goal0), case(ConsId, Goal), Changed) :- +transform_variant_case(ModuleInfo, VarToAddr, InstMap0, Case0, Case, + Changed) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), transform_variant_goal(ModuleInfo, VarToAddr, InstMap0, Goal0, Goal, - Changed). + Changed), + Case = case(MainConsId, OtherConsIds, Goal). :- pred transform_variant_atomic_goal(module_info::in, assoc_list(prog_var)::in, instmap::in, hlds_goal_info::in, diff --git a/compiler/live_vars.m b/compiler/live_vars.m index d549cf23c..3bdadeb9f 100644 --- a/compiler/live_vars.m +++ b/compiler/live_vars.m @@ -596,13 +596,14 @@ build_live_sets_in_disj([Goal0 | Goals0], [Goal | Goals], build_live_sets_in_cases([], [], _, _, !StackAlloc, !Liveness, !NondetLiveness, !ParStackVars). -build_live_sets_in_cases([case(Cons, Goal0) | Cases0], - [case(Cons, Goal) | Cases], ResumeVars0, AllocData, - !StackAlloc, Liveness0, Liveness, NondetLiveness0, NondetLiveness, - !ParStackVars) :- +build_live_sets_in_cases([Case0 | Cases0], [Case | Cases], + ResumeVars0, AllocData, !StackAlloc, + Liveness0, Liveness, NondetLiveness0, NondetLiveness, !ParStackVars) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), build_live_sets_in_goal(Goal0, Goal, ResumeVars0, AllocData, !StackAlloc, Liveness0, Liveness, NondetLiveness0, NondetLiveness1, !ParStackVars), + Case = case(MainConsId, OtherConsIds, Goal), build_live_sets_in_cases(Cases0, Cases, ResumeVars0, AllocData, !StackAlloc, Liveness0, _Liveness2, NondetLiveness0, NondetLiveness2, !ParStackVars), diff --git a/compiler/livemap.m b/compiler/livemap.m index a87fdae62..f0dbd8a2d 100644 --- a/compiler/livemap.m +++ b/compiler/livemap.m @@ -206,9 +206,9 @@ livemap_do_build_instr(Instr0, !Instrs, !Livevals, !ContainsBadUserCode, MaybeSpecial = no ) ; - Uinstr0 = computed_goto(Rval, Labels), + Uinstr0 = computed_goto(Rval, MaybeLabels), livemap.make_live_in_rvals([Rval], set.init, !:Livevals), - list.foldl(livemap_insert_label_livevals(!.Livemap), Labels, + list.foldl(livemap_insert_maybe_label_livevals(!.Livemap), MaybeLabels, !Livevals) ; Uinstr0 = if_val(Rval, CodeAddr), @@ -524,6 +524,17 @@ livemap_filter_livevals(Livevals0, Livevals) :- set.init(Livevals1), livemap_insert_proper_livevals(Livelist, Livevals1, Livevals). +:- pred livemap_insert_maybe_label_livevals(livemap::in, maybe(label)::in, + lvalset::in, lvalset::out) is det. + +livemap_insert_maybe_label_livevals(Livemap, MaybeLabel, !Livevals) :- + ( + MaybeLabel = yes(Label), + livemap_insert_label_livevals(Livemap, Label, !Livevals) + ; + MaybeLabel = no + ). + :- pred livemap_insert_label_livevals(livemap::in, label::in, lvalset::in, lvalset::out) is det. diff --git a/compiler/liveness.m b/compiler/liveness.m index 36c024d37..dcc8226d0 100644 --- a/compiler/liveness.m +++ b/compiler/liveness.m @@ -536,15 +536,17 @@ detect_liveness_in_disj([Goal0 | Goals0], [Goal | Goals], Liveness0, NonLocals, set(prog_var)::in, set(prog_var)::out) is det. detect_liveness_in_cases([], [], _Liveness, _NonLocals, _LiveInfo, !Union). -detect_liveness_in_cases([case(Cons, Goal0) | Goals0], - [case(Cons, Goal) | Goals], Liveness0, NonLocals, LiveInfo, !Union) :- +detect_liveness_in_cases([Case0 | Cases0], [Case | Cases], Liveness0, + NonLocals, LiveInfo, !Union) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), detect_liveness_in_goal(Goal0, Goal1, Liveness0, Liveness1, LiveInfo), set.union(Liveness1, !Union), - detect_liveness_in_cases(Goals0, Goals, Liveness0, NonLocals, LiveInfo, + detect_liveness_in_cases(Cases0, Cases, Liveness0, NonLocals, LiveInfo, !Union), set.intersect(!.Union, NonLocals, NonLocalUnion), set.difference(NonLocalUnion, Liveness1, Residue), - add_liveness_after_goal(Goal1, Residue, Goal). + add_liveness_after_goal(Goal1, Residue, Goal), + Case = case(MainConsId, OtherConsIds, Goal). %-----------------------------------------------------------------------------% @@ -785,9 +787,10 @@ detect_deadness_in_cases(SwitchVar, [], [], _Deadness0, _Liveness, % it must be put in the pre-death set of that case. set.insert(!.Union, SwitchVar, !:Union), set.intersect(!.Union, CompletedNonLocals, CompletedNonLocalUnion). -detect_deadness_in_cases(SwitchVar, [case(Cons, Goal0) | Goals0], - [case(Cons, Goal) | Goals], Deadness0, Liveness0, - CompletedNonLocals, LiveInfo, !Union, CompletedNonLocalUnion) :- +detect_deadness_in_cases(SwitchVar, [Case0 | Cases0], [Case | Cases], + Deadness0, Liveness0, CompletedNonLocals, LiveInfo, !Union, + CompletedNonLocalUnion) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), detect_deadness_in_goal(Goal0, Goal1, Deadness0, DeadnessGoal, Liveness0, LiveInfo), Goal1 = hlds_goal(_, GoalInfo1), @@ -798,11 +801,12 @@ detect_deadness_in_cases(SwitchVar, [case(Cons, Goal0) | Goals0], InstmapReachable = no ), union_branch_deadness(DeadnessGoal, Deadness0, InstmapReachable, !Union), - detect_deadness_in_cases(SwitchVar, Goals0, Goals, Deadness0, + detect_deadness_in_cases(SwitchVar, Cases0, Cases, Deadness0, Liveness0, CompletedNonLocals, LiveInfo, !Union, CompletedNonLocalUnion), add_branch_pre_deaths(DeadnessGoal, Deadness0, CompletedNonLocalUnion, - InstmapReachable, Goal1, Goal). + InstmapReachable, Goal1, Goal), + Case = case(MainConsId, OtherConsIds, Goal). %-----------------------------------------------------------------------------% @@ -988,7 +992,7 @@ find_reachable_goal([Goal | Goals], ReachableGoal) :- :- pred find_reachable_case(list(case)::in, hlds_goal::out) is semidet. -find_reachable_case([case(_, Goal) | Cases], ReachableGoal) :- +find_reachable_case([case(_, _, Goal) | Cases], ReachableGoal) :- Goal = hlds_goal(_, GoalInfo), InstmapDelta = goal_info_get_instmap_delta(GoalInfo), ( instmap_delta_is_unreachable(InstmapDelta) -> @@ -1200,11 +1204,12 @@ delay_death_disj([Goal0 | Goals0], [Goal - DelayedDeadGoal | Goals], maybe(pair(set(prog_var)))::out) is det. delay_death_cases([], [], _, _, _, no). -delay_death_cases([case(ConsId, Goal0) | Cases0], - [case(ConsId, Goal) - DelayedDeadGoal | Cases], +delay_death_cases([Case0 | Cases0], [Case - DelayedDeadGoal | Cases], BornVars0, DelayedDead0, VarSet, yes(BornVars - DelayedDead)) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), delay_death_goal(Goal0, Goal, BornVars0, BornVarsGoal, DelayedDead0, DelayedDeadGoal, VarSet), + Case = case(MainConsId, OtherConsIds, Goal), delay_death_cases(Cases0, Cases, BornVars0, DelayedDead0, VarSet, MaybeBornVarsDelayedDead), ( @@ -1235,14 +1240,15 @@ kill_excess_delayed_dead_goal(FinalDelayedDead, Goal0 - DelayedDead0) = Goal :- :- func kill_excess_delayed_dead_case(set(prog_var), pair(case, set(prog_var))) = case. -kill_excess_delayed_dead_case(FinalDelayedDead, - case(ConsId, Goal0) - DelayedDead0) = case(ConsId, Goal) :- +kill_excess_delayed_dead_case(FinalDelayedDead, Case0 - DelayedDead0) = Case :- + Case0 = case(MainConsId, OtherConsIds, Goal0), set.difference(DelayedDead0, FinalDelayedDead, ToBeKilled), Goal0 = hlds_goal(GoalExpr, GoalInfo0), goal_info_get_post_deaths(GoalInfo0, PostDeath0), set.union(PostDeath0, ToBeKilled, PostDeath), goal_info_set_post_deaths(PostDeath, GoalInfo0, GoalInfo), - Goal = hlds_goal(GoalExpr, GoalInfo). + Goal = hlds_goal(GoalExpr, GoalInfo), + Case = case(MainConsId, OtherConsIds, Goal). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -1549,11 +1555,12 @@ detect_resume_points_in_last_disjunct(Goal0, Goal, Liveness0, Liveness, live_info::in, set(prog_var)::in) is det. detect_resume_points_in_cases([], [], !Liveness, _, _). -detect_resume_points_in_cases([case(ConsId, Goal0) | Cases0], - [case(ConsId, Goal) | Cases], Liveness0, LivenessFirst, - LiveInfo, ResumeVars0) :- +detect_resume_points_in_cases([Case0 | Cases0], [Case | Cases], + Liveness0, LivenessFirst, LiveInfo, ResumeVars0) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), detect_resume_points_in_goal(Goal0, Goal, Liveness0, LivenessFirst, LiveInfo, ResumeVars0), + Case = case(MainConsId, OtherConsIds, Goal), ( Cases0 = [_ | _], detect_resume_points_in_cases(Cases0, Cases, diff --git a/compiler/ll_backend.m b/compiler/ll_backend.m index df5a8f4d5..ae989747b 100644 --- a/compiler/ll_backend.m +++ b/compiler/ll_backend.m @@ -46,6 +46,7 @@ :- include_module lookup_switch. :- include_module string_switch. :- include_module tag_switch. + :- include_module switch_case. :- include_module pragma_c_gen. :- include_module par_conj_gen. :- include_module middle_rec. diff --git a/compiler/llds.m b/compiler/llds.m index a3f88a5e4..878dad629 100644 --- a/compiler/llds.m +++ b/compiler/llds.m @@ -302,10 +302,11 @@ % do_redo, etc., can get optimized into the invocations of macros % fail(), redo(), etc.. - ; computed_goto(rval, list(label)) + ; computed_goto(rval, list(maybe(label))) % Evaluate rval, which should be an integer, and jump to the % (rval+1)th label in the list. e.g. computed_goto(2, [A, B, C, D]) - % will branch to label C. + % will branch to label C. A label that isn't there implicitly means + % "not reached". ; arbitrary_c_code(proc_affects_liveness, c_code_live_lvals, string) % Do whatever is specified by the string, which can be any piece diff --git a/compiler/llds_out.m b/compiler/llds_out.m index 7f54b7eb4..04708a375 100644 --- a/compiler/llds_out.m +++ b/compiler/llds_out.m @@ -2398,7 +2398,7 @@ output_instruction(computed_goto(Rval, Labels), _, !IO) :- io.write_string("\tMR_COMPUTED_GOTO(", !IO), output_rval_as_type(Rval, unsigned, !IO), io.write_string(",\n\t\t", !IO), - output_label_list(Labels, !IO), + output_label_list_or_not_reached(Labels, !IO), io.write_string(");\n", !IO). output_instruction(if_val(Rval, Target), ProfInfo, !IO) :- @@ -4579,24 +4579,35 @@ label_as_code_addr_to_string(Label, Str) :- Str = "MR_LABEL_AP(" ++ LabelStr ++ ")" ). -:- pred output_label_list(list(label)::in, io::di, io::uo) is det. +:- pred output_label_list_or_not_reached(list(maybe(label))::in, + io::di, io::uo) is det. -output_label_list([], !IO). -output_label_list([Label | Labels], !IO) :- - io.write_string("MR_LABEL_AP(", !IO), - output_label(Label, no, !IO), - io.write_string(")", !IO), - output_label_list_2(Labels, !IO). +output_label_list_or_not_reached([], !IO). +output_label_list_or_not_reached([MaybeLabel | MaybeLabels], !IO) :- + output_label_or_not_reached(MaybeLabel, !IO), + output_label_list_or_not_reached_2(MaybeLabels, !IO). -:- pred output_label_list_2(list(label)::in, io::di, io::uo) is det. +:- pred output_label_list_or_not_reached_2(list(maybe(label))::in, + io::di, io::uo) is det. -output_label_list_2([], !IO). -output_label_list_2([Label | Labels], !IO) :- +output_label_list_or_not_reached_2([], !IO). +output_label_list_or_not_reached_2([MaybeLabel | MaybeLabels], !IO) :- io.write_string(" MR_AND\n\t\t", !IO), - io.write_string("MR_LABEL_AP(", !IO), - output_label(Label, no, !IO), - io.write_string(")", !IO), - output_label_list_2(Labels, !IO). + output_label_or_not_reached(MaybeLabel, !IO), + output_label_list_or_not_reached_2(MaybeLabels, !IO). + +:- pred output_label_or_not_reached(maybe(label)::in, io::di, io::uo) is det. + +output_label_or_not_reached(MaybeLabel, !IO) :- + ( + MaybeLabel = yes(Label), + io.write_string("MR_LABEL_AP(", !IO), + output_label(Label, no, !IO), + io.write_string(")", !IO) + ; + MaybeLabel = no, + io.write_string("MR_ENTRY(MR_do_not_reached)", !IO) + ). :- pred output_label_defn(label::in, io::di, io::uo) is det. diff --git a/compiler/llds_to_x86_64.m b/compiler/llds_to_x86_64.m index c218a99f3..54fa32217 100644 --- a/compiler/llds_to_x86_64.m +++ b/compiler/llds_to_x86_64.m @@ -289,7 +289,7 @@ instr_to_x86_64(!RegMap, computed_goto(Rval, Labels), Instrs) :- "instr_to_x86_64: computed_goto: unexpected: Rval") ) ), - labels_to_string(Labels, "", LabelStr), + maybe_labels_to_string(Labels, "", LabelStr), ScratchReg = ll_backend.x86_64_regs.reg_map_get_scratch_reg(!.RegMap), ll_backend.x86_64_regs.reg_map_remove_scratch_reg(!RegMap), TempReg = operand_reg(ScratchReg), @@ -978,12 +978,19 @@ last_instr_dest(xor(_, Dest), Dest). % Get a string representation of llds labels. % -:- pred labels_to_string(list(label)::in, string::in, string::out) is det. +:- pred maybe_labels_to_string(list(maybe(label))::in, string::in, string::out) + is det. -labels_to_string([], Str, Str). -labels_to_string([Label | Labels], Str0, Str) :- - LabelStr = ll_backend.llds_out.label_to_c_string(Label, no), - labels_to_string(Labels, Str0 ++ LabelStr, Str). +maybe_labels_to_string([], Str, Str). +maybe_labels_to_string([MaybeLabel | MaybeLabels], Str0, Str) :- + ( + MaybeLabel = yes(Label), + LabelStr = ll_backend.llds_out.label_to_c_string(Label, no) + ; + MaybeLabel = no, + LabelStr = "<>" + ), + maybe_labels_to_string(MaybeLabels, Str0 ++ LabelStr, Str). %----------------------------------------------------------------------------% diff --git a/compiler/lookup_switch.m b/compiler/lookup_switch.m index a1acafe19..e8cf2896d 100644 --- a/compiler/lookup_switch.m +++ b/compiler/lookup_switch.m @@ -42,7 +42,6 @@ :- module ll_backend.lookup_switch. :- interface. -:- import_module backend_libs.switch_util. :- import_module hlds.code_model. :- import_module hlds.hlds_goal. :- import_module hlds.hlds_llds. @@ -50,21 +49,22 @@ :- import_module ll_backend.llds. :- import_module parse_tree.prog_data. +:- import_module list. + %-----------------------------------------------------------------------------% :- type lookup_switch_info. % Decide whether we can generate code for this switch using a lookup table. - % The cases_list must be sorted on the index values. % -:- pred is_lookup_switch(prog_var::in, cases_list::in, - hlds_goal_info::in, can_fail::in, int::in, abs_store_map::in, - branch_end::in, branch_end::out, code_model::in, lookup_switch_info::out, - code_info::in, code_info::out) is semidet. +:- pred is_lookup_switch(mer_type::in, list(tagged_case)::in, + int::in, int::in, int::in, hlds_goal_info::in, can_fail::in, int::in, + abs_store_map::in, branch_end::in, branch_end::out, code_model::in, + lookup_switch_info::out, code_info::in, code_info::out) is semidet. % Generate code for the switch that the lookup_switch_info came from. % -:- pred generate_lookup_switch(prog_var::in, abs_store_map::in, branch_end::in, +:- pred generate_lookup_switch(rval::in, abs_store_map::in, branch_end::in, lookup_switch_info::in, code_tree::out, code_info::in, code_info::out) is det. @@ -74,6 +74,7 @@ :- implementation. :- import_module backend_libs.builtin_ops. +:- import_module backend_libs.switch_util. :- import_module check_hlds.type_util. :- import_module hlds.goal_form. :- import_module hlds.hlds_data. @@ -90,12 +91,12 @@ :- import_module assoc_list. :- import_module bool. :- import_module int. -:- import_module list. :- import_module map. :- import_module maybe. :- import_module pair. :- import_module set. :- import_module string. +:- import_module svmap. %-----------------------------------------------------------------------------% @@ -152,8 +153,9 @@ % Most of this predicate is taken from dense_switch.m. % -is_lookup_switch(CaseVar, TaggedCases0, GoalInfo, SwitchCanFail0, ReqDensity, - StoreMap, !MaybeEnd, CodeModel, LookupSwitchInfo, !CI) :- +is_lookup_switch(Type, TaggedCases0, LowerLimit, UpperLimit, NumValues, + GoalInfo, SwitchCanFail0, ReqDensity, StoreMap, !MaybeEnd, CodeModel, + LookupSwitchInfo, !CI) :- % We need the code_info structure to generate code for the cases to % get the constants (if they exist). We can't throw it away at the % end because we may have allocated some new static ground terms. @@ -189,19 +191,15 @@ is_lookup_switch(CaseVar, TaggedCases0, GoalInfo, SwitchCanFail0, ReqDensity, % We want to generate a lookup switch for any switch that is dense enough % - we don't care how many cases it has. A memory lookup tends to be % cheaper than a branch. - list.length(TaggedCases, NumCases), - TaggedCases = [FirstCase | _], - FirstCase = extended_case(_, int_tag(FirstCaseVal), _, _), - list.index1_det(TaggedCases, NumCases, LastCase), - LastCase = extended_case(_, int_tag(LastCaseVal), _, _), - Span = LastCaseVal - FirstCaseVal, + + Span = UpperLimit - LowerLimit, Range = Span + 1, - Density = switch_density(NumCases, Range), + Density = switch_density(NumValues, Range), Density > ReqDensity, % If there are going to be no gaps in the lookup table then we won't need % a bitvector test to see if this switch has a value for this case. - ( NumCases = Range -> + ( NumValues = Range -> NeedBitVecCheck0 = dont_need_bit_vec_check ; NeedBitVecCheck0 = need_bit_vec_check @@ -213,12 +211,11 @@ is_lookup_switch(CaseVar, TaggedCases0, GoalInfo, SwitchCanFail0, ReqDensity, % range of the type is sufficiently small, we can make the jump table % large enough to hold all of the values for the type, but then we % will need to do the bitvector test. - Type = variable_type(!.CI, CaseVar), get_module_info(!.CI, ModuleInfo), classify_type(ModuleInfo, Type) = TypeCategory, ( - dense_switch.type_range(!.CI, TypeCategory, Type, TypeRange), - DetDensity = switch_density(NumCases, TypeRange), + type_range(ModuleInfo, TypeCategory, Type, _, _, TypeRange), + DetDensity = switch_density(NumValues, TypeRange), DetDensity > ReqDensity -> NeedRangeCheck = dont_need_range_check, @@ -228,21 +225,22 @@ is_lookup_switch(CaseVar, TaggedCases0, GoalInfo, SwitchCanFail0, ReqDensity, ; NeedRangeCheck = need_range_check, NeedBitVecCheck = NeedBitVecCheck0, - FirstVal = FirstCaseVal, - LastVal = LastCaseVal + FirstVal = LowerLimit, + LastVal = UpperLimit ) ; SwitchCanFail = cannot_fail, NeedRangeCheck = dont_need_range_check, NeedBitVecCheck = NeedBitVecCheck0, - FirstVal = FirstCaseVal, - LastVal = LastCaseVal + FirstVal = LowerLimit, + LastVal = UpperLimit ), figure_out_output_vars(!.CI, GoalInfo, OutVars), remember_position(!.CI, CurPos), generate_constants_for_lookup_switch(TaggedCases, OutVars, StoreMap, - CaseSolns, !MaybeEnd, MaybeLiveness, set.init, ResumeVars, - no, GoalsMayModifyTrail, !CI), + MaybeLiveness, map.init, CaseSolnMap, !MaybeEnd, + set.init, ResumeVars, no, GoalsMayModifyTrail, !CI), + map.to_assoc_list(CaseSolnMap, CaseSolns), reset_to_position(CurPos, !CI), ( MaybeLiveness = yes(Liveness) @@ -296,12 +294,13 @@ project_solns_to_rval_lists([Case | Cases], !RvalsList) :- %---------------------------------------------------------------------------% -:- pred filter_out_failing_cases(cases_list::in, - cases_list::in, cases_list::out, can_fail::in, can_fail::out) is det. +:- pred filter_out_failing_cases(list(tagged_case)::in, + list(tagged_case)::in, list(tagged_case)::out, + can_fail::in, can_fail::out) is det. filter_out_failing_cases([], !RevTaggedCases, !SwitchCanFail). filter_out_failing_cases([Case | Cases], !RevTaggedCases, !SwitchCanFail) :- - Case = extended_case(_, _, _, Goal), + Case = tagged_case(_, _, Goal), Goal = hlds_goal(GoalExpr, _), ( GoalExpr = disj([]) -> !:SwitchCanFail = can_fail @@ -312,18 +311,18 @@ filter_out_failing_cases([Case | Cases], !RevTaggedCases, !SwitchCanFail) :- %---------------------------------------------------------------------------% -:- pred generate_constants_for_lookup_switch(cases_list::in, - list(prog_var)::in, abs_store_map::in, assoc_list(int, soln_consts)::out, - branch_end::in, branch_end::out, maybe(set(prog_var))::out, - set(prog_var)::in, set(prog_var)::out, bool::in, bool::out, - code_info::in, code_info::out) is semidet. +:- pred generate_constants_for_lookup_switch(list(tagged_case)::in, + list(prog_var)::in, abs_store_map::in, maybe(set(prog_var))::out, + map(int, soln_consts)::in, map(int, soln_consts)::out, + branch_end::in, branch_end::out, set(prog_var)::in, set(prog_var)::out, + bool::in, bool::out, code_info::in, code_info::out) is semidet. -generate_constants_for_lookup_switch([], _Vars, _StoreMap, [], !MaybeEnd, no, - !ResumeVars, !GoalTrailOps, !CI). -generate_constants_for_lookup_switch([Case | Cases], Vars, StoreMap, - [CaseVal | Rest], !MaybeEnd, MaybeLiveness, !ResumeVars, +generate_constants_for_lookup_switch([], _Vars, _StoreMap, no, !IndexMap, + !MaybeEnd, !ResumeVars, !GoalTrailOps, !CI). +generate_constants_for_lookup_switch([TaggedCase | TaggedCases], Vars, + StoreMap, MaybeLiveness, !IndexMap, !MaybeEnd, !ResumeVars, !GoalsMayModifyTrail, !CI) :- - Case = extended_case(_, int_tag(CaseTag), _, Goal), + TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal), Goal = hlds_goal(GoalExpr, GoalInfo), % Goals with these features need special treatment in generate_goal. @@ -361,7 +360,7 @@ generate_constants_for_lookup_switch([Case | Cases], Vars, StoreMap, !MaybeEnd, MaybeLiveness, !CI), set_instmap(InstMap, !CI), post_goal_update(GoalInfo, !CI), - CaseVal = CaseTag - several_solns(Solns) + SolnConsts = several_solns(Solns) ; goal_is_conj_of_unify(Goal), % The pre- and post-goal updates for the goals themselves @@ -370,27 +369,39 @@ generate_constants_for_lookup_switch([Case | Cases], Vars, StoreMap, generate_constants_for_arm(Goal, Vars, StoreMap, Soln, !MaybeEnd, Liveness, !CI), MaybeLiveness = yes(Liveness), - CaseVal = CaseTag - one_soln(Soln) + SolnConsts = one_soln(Soln) ), - generate_constants_for_lookup_switch(Cases, Vars, StoreMap, Rest, - !MaybeEnd, _, !ResumeVars, !GoalsMayModifyTrail, !CI). + record_lookup_for_tagged_cons_id(SolnConsts, TaggedMainConsId, !IndexMap), + list.foldl(record_lookup_for_tagged_cons_id(SolnConsts), + TaggedOtherConsIds, !IndexMap), + generate_constants_for_lookup_switch(TaggedCases, Vars, + StoreMap, _MaybeLivenessRest, !IndexMap, !MaybeEnd, !ResumeVars, + !GoalsMayModifyTrail, !CI). + +:- pred record_lookup_for_tagged_cons_id(soln_consts::in, tagged_cons_id::in, + map(int, soln_consts)::in, map(int, soln_consts)::out) is det. + +record_lookup_for_tagged_cons_id(SolnConsts, TaggedConsId, !IndexMap) :- + TaggedConsId = tagged_cons_id(_ConsId, ConsTag), + ( ConsTag = int_tag(Index) -> + svmap.det_insert(Index, SolnConsts, !IndexMap) + ; + unexpected(this_file, "record_lookup_for_tagged_cons_id: not int_tag") + ). %---------------------------------------------------------------------------% -generate_lookup_switch(Var, StoreMap, MaybeEnd0, LookupSwitchInfo, Code, +generate_lookup_switch(VarRval, StoreMap, MaybeEnd0, LookupSwitchInfo, Code, !CI) :- LookupSwitchInfo = lookup_switch_info(StartVal, EndVal, CaseConsts, OutVars, LLDSTypes, NeedRangeCheck, NeedBitVecCheck, Liveness), - % Evaluate the variable which we are going to be switching on. - produce_variable(Var, VarCode, Rval, !CI), - % If the case values start at some number other than 0, % then subtract that number to give us a zero-based index. ( StartVal = 0 -> - IndexRval = Rval + IndexRval = VarRval ; - IndexRval = binop(int_sub, Rval, const(llconst_int(StartVal))) + IndexRval = binop(int_sub, VarRval, const(llconst_int(StartVal))) ), % If the switch is not locally deterministic, we may need to check that @@ -430,7 +441,7 @@ generate_lookup_switch(Var, StoreMap, MaybeEnd0, LookupSwitchInfo, Code, StartVal, EndVal, CaseSolns, ResumeVars, AddTrailOps, OutVars, LLDSTypes, NeedBitVecCheck, Liveness, RestCode, !CI) ), - Code = tree_list([Comment, VarCode, RangeCheckCode, RestCode]). + Code = tree_list([Comment, RangeCheckCode, RestCode]). :- pred generate_simple_lookup_switch(rval::in, abs_store_map::in, branch_end::in, int::in, int::in, assoc_list(int, list(rval))::in, diff --git a/compiler/loop_inv.m b/compiler/loop_inv.m index bf07fca95..c6edbe9a9 100644 --- a/compiler/loop_inv.m +++ b/compiler/loop_inv.m @@ -411,7 +411,7 @@ invariant_goal_candidates_keeping_path_candidates(PPId, Goal, IGCs) = :- func case_goals(list(case)) = hlds_goals. case_goals(Cases) = - list.map(func(case(_ConsId, Goal)) = Goal, Cases). + list.map(func(case(_MainConsId, _OtherConsIds, Goal)) = Goal, Cases). %-----------------------------------------------------------------------------% @@ -933,7 +933,8 @@ gen_aux_proc_list(Info, Goals) = list.map(gen_aux_proc_2(Info), Goals). gen_aux_proc_switch(Info, Cases) = list.map( - func(case(CaseId, Goal)) = case(CaseId, gen_aux_proc_2(Info, Goal)), + func(case(MainCaseId, OtherConsIds, Goal)) = + case(MainCaseId, OtherConsIds, gen_aux_proc_2(Info, Goal)), Cases ). @@ -1028,8 +1029,9 @@ gen_out_proc_2(PPId, CallAux, hlds_goal(switch(Var, CanFail, list.map(GOPCase, Cases)), GoalInfo) :- GOPCase = - ( func(case(ConsId, Goal)) = - case(ConsId, gen_out_proc_2(PPId, CallAux, Goal)) ). + ( func(case(MainConsId, OtherConsIds, Goal)) = + case(MainConsId, OtherConsIds, + gen_out_proc_2(PPId, CallAux, Goal)) ). gen_out_proc_2(PPId, CallAux, hlds_goal(negation(NegatedGoal), GoalInfo)) = diff --git a/compiler/make_hlds_warn.m b/compiler/make_hlds_warn.m index 38564af02..1773c1131 100644 --- a/compiler/make_hlds_warn.m +++ b/compiler/make_hlds_warn.m @@ -242,7 +242,7 @@ warn_singletons_in_goal_list([Goal | Goals], QuantVars, VarSet, CallPredId, warn_singletons_in_cases([], _, _, _, _, !IO). warn_singletons_in_cases([Case | Cases], QuantVars, VarSet, CallPredId, ModuleInfo, !Specs) :- - Case = case(_ConsId, Goal), + Case = case(_MainConsId, _OtherConsIds, Goal), warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId, ModuleInfo, !Specs), warn_singletons_in_cases(Cases, QuantVars, VarSet, CallPredId, diff --git a/compiler/mark_static_terms.m b/compiler/mark_static_terms.m index 93d466e08..9fde45167 100644 --- a/compiler/mark_static_terms.m +++ b/compiler/mark_static_terms.m @@ -136,10 +136,10 @@ disj_mark_static_terms([Goal0 | Goals0], [Goal | Goals], SI0) :- cases_mark_static_terms([], [], _SI0). cases_mark_static_terms([Case0 | Cases0], [Case | Cases], SI0) :- - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), % We throw away the static_info obtained after each branch. goal_mark_static_terms(Goal0, Goal, SI0, _SI), - Case = case(ConsId, Goal), + Case = case(MainConsId, OtherConsIds, Goal), cases_mark_static_terms(Cases0, Cases, SI0). :- pred unification_mark_static_terms(unification::in, unification::out, diff --git a/compiler/middle_rec.m b/compiler/middle_rec.m index 5a5c64736..169e22bd2 100644 --- a/compiler/middle_rec.m +++ b/compiler/middle_rec.m @@ -57,8 +57,8 @@ match_and_generate(Goal, Instrs, !CI) :- Goal = hlds_goal(GoalExpr, GoalInfo), GoalExpr = switch(Var, cannot_fail, [Case1, Case2]), - Case1 = case(ConsId1, Goal1), - Case2 = case(ConsId2, Goal2), + Case1 = case(ConsId1, [], Goal1), + Case2 = case(ConsId2, [], Goal2), ( contains_only_builtins(Goal1) = yes, contains_simple_recursive_call(Goal2, !.CI) @@ -200,7 +200,7 @@ contains_only_builtins_expr(shorthand(_)) = no. :- func contains_only_builtins_cases(list(case)) = bool. contains_only_builtins_cases([]) = yes. -contains_only_builtins_cases([case(_ConsId, Goal) | Cases]) = OnlyBuiltins :- +contains_only_builtins_cases([case(_, _, Goal) | Cases]) = OnlyBuiltins :- ( contains_only_builtins(Goal) = yes -> OnlyBuiltins = contains_only_builtins_cases(Cases) ; @@ -234,17 +234,19 @@ middle_rec_generate_switch(Var, BaseConsId, Base, Recursive, SwitchGoalInfo, EntryLabel = make_local_entry_label(ModuleInfo, PredId, ProcId, no), pre_goal_update(SwitchGoalInfo, no, !CI), - unify_gen.generate_tag_test(Var, BaseConsId, branch_on_success, + VarType = variable_type(!.CI, Var), + CheaperTagTest = lookup_cheaper_tag_test(!.CI, VarType), + generate_tag_test(Var, BaseConsId, CheaperTagTest, branch_on_success, BaseLabel, EntryTestCode, !CI), tree.flatten(EntryTestCode, EntryTestListList), list.condense(EntryTestListList, EntryTestList), goal_info_get_store_map(SwitchGoalInfo, StoreMap), remember_position(!.CI, BranchStart), - code_gen.generate_goal(model_det, Base, BaseGoalCode, !CI), + generate_goal(model_det, Base, BaseGoalCode, !CI), generate_branch_end(StoreMap, no, MaybeEnd1, BaseSaveCode, !CI), reset_to_position(BranchStart, !CI), - code_gen.generate_goal(model_det, Recursive, RecGoalCode, !CI), + generate_goal(model_det, Recursive, RecGoalCode, !CI), generate_branch_end(StoreMap, MaybeEnd1, MaybeEnd, RecSaveCode, !CI), post_goal_update(SwitchGoalInfo, !CI), @@ -255,8 +257,8 @@ middle_rec_generate_switch(Var, BaseConsId, Base, Recursive, SwitchGoalInfo, assoc_list.from_corresponding_lists(HeadVars, ArgModes, Args), setup_return(Args, LiveArgs, EpilogCode, !CI), - BaseCode = tree(BaseGoalCode, tree(BaseSaveCode, EpilogCode)), - RecCode = tree(RecGoalCode, tree(RecSaveCode, EpilogCode)), + BaseCode = tree_list([BaseGoalCode, BaseSaveCode, EpilogCode]), + RecCode = tree_list([RecGoalCode, RecSaveCode, EpilogCode]), LiveValCode = [llds_instr(livevals(LiveArgs), "")], tree.flatten(BaseCode, BaseListList), diff --git a/compiler/ml_string_switch.m b/compiler/ml_string_switch.m index 844420d5e..fa8aa3d62 100644 --- a/compiler/ml_string_switch.m +++ b/compiler/ml_string_switch.m @@ -20,15 +20,18 @@ :- module ml_backend.ml_string_switch. :- interface. -:- import_module backend_libs.switch_util. :- import_module hlds.code_model. +:- import_module hlds.hlds_goal. :- import_module ml_backend.ml_code_util. :- import_module ml_backend.mlds. :- import_module parse_tree.prog_data. -:- pred generate(cases_list::in, prog_var::in, code_model::in, can_fail::in, - prog_context::in, mlds_defns::out, statements::out, - ml_gen_info::in, ml_gen_info::out) is det. +:- import_module list. + +:- pred ml_generate_string_switch(list(tagged_case)::in, prog_var::in, + code_model::in, can_fail::in, prog_context::in, + mlds_defns::out, statements::out, ml_gen_info::in, ml_gen_info::out) + is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -36,6 +39,7 @@ :- implementation. :- import_module backend_libs.builtin_ops. +:- import_module backend_libs.switch_util. :- import_module hlds.hlds_data. :- import_module libs.compiler_util. :- import_module ml_backend.ml_code_gen. @@ -43,15 +47,16 @@ :- import_module bool. :- import_module int. -:- import_module list. :- import_module map. :- import_module maybe. :- import_module pair. :- import_module string. +:- import_module unit. %-----------------------------------------------------------------------------% -generate(Cases, Var, CodeModel, _CanFail, Context, Decls, Statements, !Info) :- +ml_generate_string_switch(Cases, Var, CodeModel, _CanFail, Context, + Decls, Statements, !Info) :- MLDS_Context = mlds_make_context(Context), % Compute the value we're going to switch on. @@ -98,9 +103,12 @@ generate(Cases, Var, CodeModel, _CanFail, Context, Decls, Statements, !Info) :- HashMask = TableSize - 1, % Compute the hash table. - switch_util.string_hash_cases(Cases, HashMask, HashValsMap), + switch_util.string_hash_cases(Cases, HashMask, + represent_tagged_case_by_itself, unit, _, unit, _, unit, _, + HashValsMap), map.to_assoc_list(HashValsMap, HashValsList), - switch_util.calc_hash_slots(HashValsList, HashValsMap, HashSlotsMap), + switch_util.calc_string_hash_slots(HashValsList, HashValsMap, + HashSlotsMap), % Generate the code for when the hash lookup fails. ( @@ -120,7 +128,7 @@ generate(Cases, Var, CodeModel, _CanFail, Context, Decls, Statements, !Info) :- ), % Generate the code etc. for the hash table. - gen_hash_slots(0, TableSize, HashSlotsMap, CodeModel, + ml_gen_string_hash_slots(0, TableSize, HashSlotsMap, CodeModel, Context, Strings, NextSlots, SlotsCases, !Info), % Generate the following local constant declarations: @@ -223,48 +231,52 @@ generate(Cases, Var, CodeModel, _CanFail, Context, Decls, Statements, !Info) :- %-----------------------------------------------------------------------------% -:- pred gen_hash_slots(int::in, int::in, - map(int, hash_slot)::in, code_model::in, prog_context::in, - list(mlds_initializer)::out, list(mlds_initializer)::out, +:- pred ml_gen_string_hash_slots(int::in, int::in, + map(int, string_hash_slot(tagged_case))::in, code_model::in, + prog_context::in, list(mlds_initializer)::out, list(mlds_initializer)::out, list(mlds_switch_case)::out, ml_gen_info::in, ml_gen_info::out) is det. -gen_hash_slots(Slot, TableSize, HashSlotMap, CodeModel, Context, Strings, - NextSlots, MLDS_Cases, !Info) :- +ml_gen_string_hash_slots(Slot, TableSize, HashSlotMap, CodeModel, Context, + Strings, NextSlots, MLDS_Cases, !Info) :- ( Slot = TableSize -> Strings = [], NextSlots = [], MLDS_Cases = [] ; MLDS_Context = mlds_make_context(Context), - gen_hash_slot(Slot, HashSlotMap, CodeModel, MLDS_Context, String, - NextSlot, SlotCases, !Info), - gen_hash_slots(Slot + 1, TableSize, HashSlotMap, CodeModel, Context, - Strings0, NextSlots0, MLDS_Cases0, !Info), + ml_gen_string_hash_slot(Slot, HashSlotMap, CodeModel, MLDS_Context, + String, NextSlot, SlotCases, !Info), + ml_gen_string_hash_slots(Slot + 1, TableSize, HashSlotMap, CodeModel, + Context, Strings0, NextSlots0, MLDS_Cases0, !Info), Strings = [String | Strings0], NextSlots = [NextSlot | NextSlots0], MLDS_Cases = SlotCases ++ MLDS_Cases0 ). -:- pred gen_hash_slot(int::in, map(int, hash_slot)::in, - code_model::in, mlds_context::in, mlds_initializer::out, - mlds_initializer::out, list(mlds_switch_case)::out, - ml_gen_info::in, ml_gen_info::out) is det. +:- pred ml_gen_string_hash_slot(int::in, + map(int, string_hash_slot(tagged_case))::in, code_model::in, + mlds_context::in, mlds_initializer::out, mlds_initializer::out, + list(mlds_switch_case)::out, ml_gen_info::in, ml_gen_info::out) is det. -gen_hash_slot(Slot, HashSlotMap, CodeModel, MLDS_Context, +ml_gen_string_hash_slot(Slot, HashSlotMap, CodeModel, MLDS_Context, init_obj(StringRval), init_obj(NextSlotRval), MLDS_Cases, !Info) :- - ( map.search(HashSlotMap, Slot, hash_slot(Case, Next)) -> + ( map.search(HashSlotMap, Slot, string_hash_slot(Next, String, Case)) -> NextSlotRval = const(mlconst_int(Next)), - Case = extended_case(_, ConsTag, _, Goal), - ( ConsTag = string_tag(String0) -> - String = String0 + Case = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal), + expect(unify(TaggedOtherConsIds, []), this_file, + "ml_gen_string_hash_slot: other cons_ids"), + TaggedMainConsId = tagged_cons_id(_ConsId, ConsTag), + ( ConsTag = string_tag(StringPrime) -> + expect(unify(String, StringPrime), this_file, + "ml_gen_string_hash_slot: string mismatch") ; - unexpected(this_file, "gen_hash_slots: string expected") + unexpected(this_file, "ml_gen_string_hash_slot: string expected") ), StringRval = const(mlconst_string(String)), ml_gen_goal(CodeModel, Goal, GoalStatement, !Info), - string.append_list(["case """, String, """"], CommentString), + CommentString = "case """ ++ String ++ """", Comment = statement(ml_stmt_atomic(comment(CommentString)), MLDS_Context), CaseStatement = statement(ml_stmt_block([], [Comment, GoalStatement]), diff --git a/compiler/ml_switch_gen.m b/compiler/ml_switch_gen.m index 08a2a7719..126e2430b 100644 --- a/compiler/ml_switch_gen.m +++ b/compiler/ml_switch_gen.m @@ -105,6 +105,7 @@ :- import_module backend_libs.switch_util. :- import_module check_hlds.type_util. :- import_module hlds.hlds_data. +:- import_module hlds.hlds_module. :- import_module libs.compiler_util. :- import_module libs.options. :- import_module ml_backend.ml_code_gen. @@ -113,9 +114,12 @@ :- import_module ml_backend.ml_string_switch. :- import_module ml_backend.ml_tag_switch. :- import_module ml_backend.ml_unify_gen. +:- import_module parse_tree.prog_type. +:- import_module assoc_list. :- import_module bool. :- import_module int. +:- import_module map. :- import_module maybe. :- import_module pair. @@ -125,29 +129,31 @@ ml_gen_switch(CaseVar, CanFail, Cases, CodeModel, Context, Decls, Statements, !Info) :- % Lookup the representation of the constructors for the tag tests % and their corresponding priorities. - ml_switch_lookup_tags(!.Info, Cases, CaseVar, TaggedCases0), + ml_switch_lookup_tags(!.Info, Cases, CaseVar, CostTaggedCases), % Sort the cases according to the priority of their tag tests. - list.sort_and_remove_dups(TaggedCases0, TaggedCases), + list.sort_and_remove_dups(CostTaggedCases, SortedCostTaggedCases), + assoc_list.values(SortedCostTaggedCases, SortedTaggedCases), % Figure out what kind of switch this is. SwitchCategory = determine_category(!.Info, CaseVar), ml_gen_info_get_globals(!.Info, Globals), globals.lookup_bool_option(Globals, smart_indexing, Indexing), ( - % Check for a switch on a type whose representation - % uses reserved addresses. - list.member(Case, TaggedCases), - Case = extended_case(_Priority, Tag, _ConsId, _Goal), - ( - Tag = reserved_address_tag(_) - ; - Tag = shared_with_reserved_addresses_tag(_, _) - ) + % Check for a switch on a type whose representation uses + % reserved addresses. + ml_variable_type(!.Info, CaseVar, CaseVarType), + type_to_ctor_det(CaseVarType, CaseVarTypeCtor), + ml_gen_info_get_module_info(!.Info, ModuleInfo), + module_info_get_type_table(ModuleInfo, TypeTable), + % The search will fail for builtin types. + map.search(TypeTable, CaseVarTypeCtor, CaseVarTypeDefn), + hlds_data.get_type_defn_body(CaseVarTypeDefn, CaseVarTypeBody), + CaseVarTypeBody ^ du_type_reserved_addr = uses_reserved_address -> % XXX This may be inefficient in some cases. - ml_switch_generate_if_else_chain(TaggedCases, CaseVar, CodeModel, - CanFail, Context, Decls, Statements, !Info) + ml_switch_generate_if_then_else_chain(SortedTaggedCases, CaseVar, + CodeModel, CanFail, Context, Decls, Statements, !Info) ; % XXX Lookup switches are NYI % When we do get around to implementing them, @@ -157,26 +163,26 @@ ml_gen_switch(CaseVar, CanFail, Cases, CodeModel, Context, Decls, Statements, % % Note that if/when the MLDS back-end supports execution % % tracing, we would also need to check that tracing is not % % enabled. -% list.length(TaggedCases, NumCases), +% list.length(SortedTaggedCases, NumCases), % globals.lookup_int_option(Globals, lookup_switch_size, % LookupSize), % NumCases >= LookupSize, % globals.lookup_int_option(Globals, lookup_switch_req_density, % ReqDensity), -% lookup_switch.is_lookup_switch(CaseVar, TaggedCases, GoalInfo, +% lookup_switch.is_lookup_switch(CaseVar, SortedTaggedCases, GoalInfo, % CanFail, ReqDensity, % CodeModel, FirstVal, LastVal, NeedRangeCheck, % NeedBitVecCheck, OutVars, CaseVals, !Info) % -> % MaybeEnd = MaybeEndPrime, -% ml_lookup_switch.generate(CaseVar, OutVars, CaseVals, +% ml_generate_lookup_switch(CaseVar, OutVars, CaseVals, % FirstVal, LastVal, NeedRangeCheck, NeedBitVecCheck, % Decls, Statements, !Info) % ; % Try using a string hash switch. Indexing = yes, SwitchCategory = string_switch, - list.length(TaggedCases, NumCases), + list.length(SortedTaggedCases, NumCases), globals.lookup_int_option(Globals, string_switch_size, StringSize), NumCases >= StringSize, % We can implement string hash switches using either @@ -198,18 +204,18 @@ ml_gen_switch(CaseVar, CanFail, Cases, CodeModel, Context, Decls, Statements, globals.lookup_bool_option(Globals, prefer_switch, yes) ) -> - ml_string_switch.generate(TaggedCases, CaseVar, CodeModel, + ml_generate_string_switch(SortedTaggedCases, CaseVar, CodeModel, CanFail, Context, Decls, Statements, !Info) ; % Try using a tag switch. Indexing = yes, SwitchCategory = tag_switch, - list.length(TaggedCases, NumCases), + list.length(SortedTaggedCases, NumCases), globals.lookup_int_option(Globals, tag_switch_size, TagSize), NumCases >= TagSize, target_supports_int_switch(Globals) -> - ml_tag_switch.generate(TaggedCases, CaseVar, CodeModel, + ml_generate_tag_switch(SortedTaggedCases, CaseVar, CodeModel, CanFail, Context, Decls, Statements, !Info) ; % Try using a "direct-mapped" switch. This also handles dense @@ -225,13 +231,13 @@ ml_gen_switch(CaseVar, CanFail, Cases, CodeModel, Context, Decls, Statements, target_supports_computed_goto(Globals) ) -> - ml_switch_generate_mlds_switch(TaggedCases, CaseVar, CodeModel, + ml_switch_generate_mlds_switch(SortedTaggedCases, CaseVar, CodeModel, CanFail, Context, Decls, Statements, !Info) ; % The fallback method: if all else fails, generate an if-then-else % chain which tests each of the cases in turn. - ml_switch_generate_if_else_chain(TaggedCases, CaseVar, CodeModel, - CanFail, Context, Decls, Statements, !Info) + ml_switch_generate_if_then_else_chain(SortedTaggedCases, CaseVar, + CodeModel, CanFail, Context, Decls, Statements, !Info) ). %-----------------------------------------------------------------------------% @@ -329,27 +335,32 @@ determine_category(Info, CaseVar) = SwitchCategory :- % Also look up the priority of each tag test. % :- pred ml_switch_lookup_tags(ml_gen_info::in, list(case)::in, prog_var::in, - cases_list::out) is det. + assoc_list(int, tagged_case)::out) is det. ml_switch_lookup_tags(_Info, [], _, []). -ml_switch_lookup_tags(Info, [Case | Cases], Var, [TaggedCase | TaggedCases]) :- - Case = case(ConsId, Goal), +ml_switch_lookup_tags(Info, [Case | Cases], Var, + [CostTaggedCase | CostTaggedCases]) :- + Case = case(MainConsId, OtherConsIds, Goal), + expect(unify(OtherConsIds, []), this_file, + "ml_switch_lookup_tags: multi-cons-id switch arms NYI"), ml_variable_type(Info, Var, Type), - ml_cons_id_to_tag(Info, ConsId, Type, Tag), - Priority = switch_util.switch_priority(Tag), - TaggedCase = extended_case(Priority, Tag, ConsId, Goal), - ml_switch_lookup_tags(Info, Cases, Var, TaggedCases). + ml_cons_id_to_tag(Info, MainConsId, Type, MainConsTag), + Cost = estimate_switch_tag_test_cost(MainConsTag), + TaggedMainConsId = tagged_cons_id(MainConsId, MainConsTag), + TaggedCase = tagged_case(TaggedMainConsId, [], Goal), + CostTaggedCase = Cost - TaggedCase, + ml_switch_lookup_tags(Info, Cases, Var, CostTaggedCases). %-----------------------------------------------------------------------------% % Generate a chain of if-then-elses to test each case in turn. % -:- pred ml_switch_generate_if_else_chain(list(extended_case)::in, prog_var::in, - code_model::in, can_fail::in, prog_context::in, +:- pred ml_switch_generate_if_then_else_chain(list(tagged_case)::in, + prog_var::in, code_model::in, can_fail::in, prog_context::in, mlds_defns::out, statements::out, ml_gen_info::in, ml_gen_info::out) is det. -ml_switch_generate_if_else_chain([], _Var, CodeModel, CanFail, Context, +ml_switch_generate_if_then_else_chain([], _Var, CodeModel, CanFail, Context, [], Statements, !Info) :- ( CanFail = can_fail, @@ -358,11 +369,14 @@ ml_switch_generate_if_else_chain([], _Var, CodeModel, CanFail, Context, CanFail = cannot_fail, unexpected(this_file, "switch failure") ). -ml_switch_generate_if_else_chain([Case | Cases], Var, CodeModel, CanFail, - Context, Decls, Statements, !Info) :- - Case = extended_case(_, _Tag, ConsId, Goal), +ml_switch_generate_if_then_else_chain([TaggedCase | TaggedCases], Var, + CodeModel, CanFail, Context, Decls, Statements, !Info) :- + TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal), + expect(unify(TaggedOtherConsIds, []), this_file, + "ml_switch_generate_if_then_else_chain: OtherTaggedConsIds != []"), + TaggedMainConsId = tagged_cons_id(ConsId, _Tag), ( - Cases = [], + TaggedCases = [], CanFail = cannot_fail -> ml_gen_goal(CodeModel, Goal, Decls, Statements, !Info) @@ -370,7 +384,7 @@ ml_switch_generate_if_else_chain([Case | Cases], Var, CodeModel, CanFail, ml_gen_tag_test(Var, ConsId, TagTestDecls, TagTestStatements, TagTestExpression, !Info), ml_gen_goal(CodeModel, Goal, GoalStatement, !Info), - ml_switch_generate_if_else_chain(Cases, Var, CodeModel, + ml_switch_generate_if_then_else_chain(TaggedCases, Var, CodeModel, CanFail, Context, RestDecls, RestStatements, !Info), Rest = ml_gen_block(RestDecls, RestStatements, Context), IfStmt = ml_stmt_if_then_else(TagTestExpression, GoalStatement, @@ -386,9 +400,10 @@ ml_switch_generate_if_else_chain([Case | Cases], Var, CodeModel, CanFail, % where we map a Mercury switch directly to a switch in the target % language. % -:- pred ml_switch_generate_mlds_switch(list(extended_case)::in, prog_var::in, - code_model::in, can_fail::in, prog_context::in, mlds_defns::out, - statements::out, ml_gen_info::in, ml_gen_info::out) is det. +:- pred ml_switch_generate_mlds_switch(list(tagged_case)::in, + prog_var::in, code_model::in, can_fail::in, prog_context::in, + mlds_defns::out, statements::out, + ml_gen_info::in, ml_gen_info::out) is det. ml_switch_generate_mlds_switch(Cases, Var, CodeModel, CanFail, Context, Decls, Statements, !Info) :- @@ -413,30 +428,33 @@ ml_switch_gen_range(Info, MLDS_Type, Range) :- ml_gen_info_get_module_info(Info, ModuleInfo), ExportedType = to_exported_type(ModuleInfo, Type), MLDS_Type = mercury_type(Type, TypeCategory, ExportedType), - switch_util.type_range(TypeCategory, Type, ModuleInfo, - MinRange, MaxRange) + switch_util.type_range(ModuleInfo, TypeCategory, Type, + MinRange, MaxRange, _NumValuesInRange) -> Range = range(MinRange, MaxRange) ; Range = range_unknown ). -:- pred ml_switch_generate_mlds_cases(list(extended_case)::in, +:- pred ml_switch_generate_mlds_cases(list(tagged_case)::in, code_model::in, list(mlds_switch_case)::out, ml_gen_info::in, ml_gen_info::out) is det. ml_switch_generate_mlds_cases([], _, [], !Info). -ml_switch_generate_mlds_cases([Case | Cases], CodeModel, +ml_switch_generate_mlds_cases([TaggedCase | TaggedCases], CodeModel, [MLDS_Case | MLDS_Cases], !Info) :- - ml_switch_generate_mlds_case(Case, CodeModel, MLDS_Case, !Info), - ml_switch_generate_mlds_cases(Cases, CodeModel, MLDS_Cases, !Info). + ml_switch_generate_mlds_case(TaggedCase, CodeModel, MLDS_Case, !Info), + ml_switch_generate_mlds_cases(TaggedCases, CodeModel, MLDS_Cases, !Info). -:- pred ml_switch_generate_mlds_case(extended_case::in, code_model::in, +:- pred ml_switch_generate_mlds_case(tagged_case::in, code_model::in, mlds_switch_case::out, ml_gen_info::in, ml_gen_info::out) is det. -ml_switch_generate_mlds_case(Case, CodeModel, MLDS_Case, !Info) :- - Case = extended_case(_Priority, Tag, _ConsId, Goal), +ml_switch_generate_mlds_case(TaggedCase, CodeModel, MLDS_Case, !Info) :- + TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal), + expect(unify(TaggedOtherConsIds, []), this_file, + "ml_switch_generate_mlds_case: OtherTaggedConsIds != []"), + TaggedMainConsId = tagged_cons_id(_ConsId, Tag), ( Tag = int_tag(Int), Rval = const(mlconst_int(Int)) diff --git a/compiler/ml_tag_switch.m b/compiler/ml_tag_switch.m index c81cc74fd..478a61dee 100644 --- a/compiler/ml_tag_switch.m +++ b/compiler/ml_tag_switch.m @@ -17,8 +17,8 @@ :- module ml_backend.ml_tag_switch. :- interface. -:- import_module backend_libs.switch_util. :- import_module hlds.code_model. +:- import_module hlds.hlds_goal. :- import_module ml_backend.ml_code_util. :- import_module ml_backend.mlds. :- import_module parse_tree.prog_data. @@ -29,9 +29,10 @@ % Generate efficient indexing code for tag based switches. % -:- pred generate(list(extended_case)::in, prog_var::in, code_model::in, - can_fail::in, prog_context::in, mlds_defns::out, statements::out, - ml_gen_info::in, ml_gen_info::out) is det. +:- pred ml_generate_tag_switch(list(tagged_case)::in, prog_var::in, + code_model::in, can_fail::in, prog_context::in, + mlds_defns::out, statements::out, ml_gen_info::in, ml_gen_info::out) + is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -40,6 +41,7 @@ :- import_module backend_libs.builtin_ops. :- import_module backend_libs.rtti. +:- import_module backend_libs.switch_util. :- import_module hlds.hlds_data. :- import_module libs.compiler_util. :- import_module ml_backend.ml_code_gen. @@ -51,10 +53,12 @@ :- import_module int. :- import_module map. :- import_module pair. +:- import_module unit. %-----------------------------------------------------------------------------% -generate(Cases, Var, CodeModel, CanFail, Context, Decls, Statements, !Info) :- +ml_generate_tag_switch(TaggedCases, Var, CodeModel, CanFail, Context, + Decls, Statements, !Info) :- % Generate the rval for the primary tag. ml_gen_var(!.Info, Var, VarLval), VarRval = lval(VarLval), @@ -69,7 +73,9 @@ generate(Cases, Var, CodeModel, CanFail, Context, Decls, Statements, !Info) :- switch_util.get_ptag_counts(Type, ModuleInfo, MaxPrimary, PtagCountMap), map.to_assoc_list(PtagCountMap, PtagCountList), map.init(PtagCaseMap0), - switch_util.group_cases_by_ptag(Cases, PtagCaseMap0, PtagCaseMap), + switch_util.group_cases_by_ptag(TaggedCases, + represent_tagged_case_by_itself, unit, _, unit, _, unit, _, + PtagCaseMap0, PtagCaseMap), switch_util.order_ptags_by_count(PtagCountList, PtagCaseMap, PtagCaseList), @@ -87,7 +93,7 @@ generate(Cases, Var, CodeModel, CanFail, Context, Decls, Statements, !Info) :- Decls = [], Statements = [SwitchStatement]. -:- pred gen_ptag_cases(ptag_case_list::in, prog_var::in, +:- pred gen_ptag_cases(ptag_case_list(tagged_case)::in, prog_var::in, can_fail::in, code_model::in, ptag_count_map::in, prog_context::in, list(mlds_switch_case)::out, ml_gen_info::in, ml_gen_info::out) is det. @@ -100,7 +106,7 @@ gen_ptag_cases([Case | Cases], Var, CanFail, CodeModel, gen_ptag_cases(Cases, Var, CanFail, CodeModel, PtagCountMap, Context, MLDS_Cases, !Info). -:- pred gen_ptag_case(pair(tag_bits, ptag_case)::in, +:- pred gen_ptag_case(pair(tag_bits, ptag_case(tagged_case))::in, prog_var::in, can_fail::in, code_model::in, ptag_count_map::in, prog_context::in, mlds_switch_case::out, ml_gen_info::in, ml_gen_info::out) is det. @@ -120,7 +126,9 @@ gen_ptag_case(Case, Var, CanFail, CodeModel, PtagCountMap, Context, MLDS_Case, GoalList = [], unexpected(this_file, "no goal for non-shared tag") ; - GoalList = [_Stag - stag_goal(_ConsId, Goal)], + GoalList = [_Stag - TaggedCase], + TaggedCase = tagged_case(_MainTaggedConsId, _OtherTaggedConsIds, + Goal), ml_gen_goal(CodeModel, Goal, Statement, !Info) ; GoalList = [_, _ | _], @@ -146,9 +154,11 @@ gen_ptag_case(Case, Var, CanFail, CodeModel, PtagCountMap, Context, MLDS_Case, ) ), ( - GoalList = [_Stag - stag_goal(_ConsId, Goal)], + GoalList = [_Stag - TaggedCase], CaseCanFail = cannot_fail -> + TaggedCase = tagged_case(_MainTaggedConsId, _OtherTaggedConsIds, + Goal), % There is only one possible matching goal, % so we don't need to switch on it. ml_gen_goal(CodeModel, Goal, Statement, !Info) @@ -160,9 +170,10 @@ gen_ptag_case(Case, Var, CanFail, CodeModel, PtagCountMap, Context, MLDS_Case, PrimaryTagRval = const(mlconst_int(PrimaryTag)), MLDS_Case = mlds_switch_case([match_value(PrimaryTagRval)], Statement). -:- pred gen_stag_switch(stag_goal_list::in, int::in, sectag_locn::in, - prog_var::in, code_model::in, can_fail::in, prog_context::in, - statement::out, ml_gen_info::in, ml_gen_info::out) is det. +:- pred gen_stag_switch(stag_goal_list(tagged_case)::in, int::in, + sectag_locn::in, prog_var::in, code_model::in, can_fail::in, + prog_context::in, statement::out, ml_gen_info::in, ml_gen_info::out) + is det. gen_stag_switch(Cases, PrimaryTag, StagLocn, Var, CodeModel, CanFail, Context, Statement, !Info) :- @@ -194,7 +205,7 @@ gen_stag_switch(Cases, PrimaryTag, StagLocn, Var, CodeModel, CanFail, Context, MLDS_Context = mlds_make_context(Context), ml_simplify_switch(SwitchStmt, MLDS_Context, Statement, !Info). -:- pred gen_stag_cases(stag_goal_list::in, code_model::in, +:- pred gen_stag_cases(stag_goal_list(tagged_case)::in, code_model::in, list(mlds_switch_case)::out, ml_gen_info::in, ml_gen_info::out) is det. gen_stag_cases([], _, [], !Info). @@ -202,12 +213,12 @@ gen_stag_cases([Case | Cases], CodeModel, [MLDS_Case | MLDS_Cases], !Info) :- gen_stag_case(Case, CodeModel, MLDS_Case, !Info), gen_stag_cases(Cases, CodeModel, MLDS_Cases, !Info). -:- pred gen_stag_case(pair(tag_bits, stag_goal)::in, +:- pred gen_stag_case(pair(tag_bits, tagged_case)::in, code_model::in, mlds_switch_case::out, ml_gen_info::in, ml_gen_info::out) is det. gen_stag_case(Case, CodeModel, MLDS_Case, !Info) :- - Case = Stag - stag_goal(_ConsId, Goal), + Case = Stag - tagged_case(_MainTaggedConsId, _OtherTaggedConsIds, Goal), StagRval = const(mlconst_int(Stag)), ml_gen_goal(CodeModel, Goal, Statement, !Info), MLDS_Case = mlds_switch_case([match_value(StagRval)], Statement). diff --git a/compiler/ml_type_gen.m b/compiler/ml_type_gen.m index 8ddca3ff5..266cfac1e 100644 --- a/compiler/ml_type_gen.m +++ b/compiler/ml_type_gen.m @@ -148,35 +148,42 @@ ml_gen_type_defn(ModuleInfo, TypeTable, TypeCtor, MLDS_Defns0, MLDS_Defns) :- :- pred ml_gen_type_2(hlds_type_body::in, module_info::in, type_ctor::in, hlds_type_defn::in, mlds_defns::in, mlds_defns::out) is det. -ml_gen_type_2(hlds_abstract_type(_), _, _, _, !Defns). -ml_gen_type_2(hlds_eqv_type(_EqvType), _, _, _, !Defns). - % XXX Fixme! - % For a description of the problems with equivalence types, - % see our BABEL'01 paper "Compiling Mercury to the .NET CLR". -ml_gen_type_2(hlds_du_type(Ctors, TagValues, EnumDummy, MaybeUserEqComp, - _ReservedTag, _, _), ModuleInfo, TypeCtor, TypeDefn, !Defns) :- - % XXX we probably shouldn't ignore _ReservedTag - ml_gen_equality_members(MaybeUserEqComp, MaybeEqualityMembers), +ml_gen_type_2(TypeBody, ModuleInfo, TypeCtor, TypeDefn, !Defns) :- ( - ( EnumDummy = is_mercury_enum - ; EnumDummy = is_foreign_enum(_) - ), - ml_gen_enum_type(TypeCtor, TypeDefn, Ctors, TagValues, - MaybeEqualityMembers, !Defns) + TypeBody = hlds_abstract_type(_) ; - EnumDummy = is_dummy, - % XXX We shouldn't have to generate an MLDS type for these types, - % but it is not easy to ensure that we never refer to that type. - ml_gen_enum_type(TypeCtor, TypeDefn, Ctors, TagValues, - MaybeEqualityMembers, !Defns) + TypeBody = hlds_eqv_type(_EqvType) + % XXX Fixme! + % For a description of the problems with equivalence types, + % see our BABEL'01 paper "Compiling Mercury to the .NET CLR". + % The same issue arises for some of the cases below. ; - EnumDummy = not_enum_or_dummy, - ml_gen_du_parent_type(ModuleInfo, TypeCtor, TypeDefn, - Ctors, TagValues, MaybeEqualityMembers, !Defns) + TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest, EnumDummy, + MaybeUserEqComp, _ReservedTag, _, _), + % XXX We probably shouldn't ignore _ReservedTag. + ml_gen_equality_members(MaybeUserEqComp, MaybeEqualityMembers), + ( + ( EnumDummy = is_mercury_enum + ; EnumDummy = is_foreign_enum(_) + ), + ml_gen_enum_type(TypeCtor, TypeDefn, Ctors, TagValues, + MaybeEqualityMembers, !Defns) + ; + EnumDummy = is_dummy, + % XXX We shouldn't have to generate an MLDS type for these types, + % but it is not easy to ensure that we never refer to that type. + ml_gen_enum_type(TypeCtor, TypeDefn, Ctors, TagValues, + MaybeEqualityMembers, !Defns) + ; + EnumDummy = not_enum_or_dummy, + ml_gen_du_parent_type(ModuleInfo, TypeCtor, TypeDefn, + Ctors, TagValues, MaybeEqualityMembers, !Defns) + ) + ; + TypeBody = hlds_foreign_type(_) + ; + TypeBody = hlds_solver_type(_, _) ). - % XXX Fixme! Same issues here as for eqv_type/1. -ml_gen_type_2(hlds_foreign_type(_), _, _, _, !Defns). -ml_gen_type_2(hlds_solver_type(_, _), _, _, _, !Defns). %-----------------------------------------------------------------------------% % @@ -1068,8 +1075,9 @@ ml_gen_exported_enum(_ModuleInfo, TypeTable, ExportedEnumInfo, ), unexpected(this_file, "ml_gen_exported_enum - invalid type (2).") ; - TypeBody = hlds_du_type(Ctors, TagValues, _IsEnumOrDummy, _MaybeUserEq, - _ReservedTag, _ReservedAddr, _IsForeignType), + TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest, + _IsEnumOrDummy, _MaybeUserEq, _ReservedTag, _ReservedAddr, + _IsForeignType), list.foldl(generate_foreign_enum_constant(Mapping, TagValues), Ctors, [], NamesAndTags), MLDS_ExportedEnum = mlds_exported_enum(Lang, Context, diff --git a/compiler/ml_unify_gen.m b/compiler/ml_unify_gen.m index 46b26e6c0..5b7b1da33 100644 --- a/compiler/ml_unify_gen.m +++ b/compiler/ml_unify_gen.m @@ -556,7 +556,7 @@ target_supports_inheritence(target_erlang) = % ml_cons_id_to_tag(Info, ConsId, Type, Tag) :- ml_gen_info_get_module_info(Info, ModuleInfo), - Tag = cons_id_to_tag(ConsId, Type, ModuleInfo). + Tag = cons_id_to_tag(ModuleInfo, Type, ConsId). % Generate code to construct a new object. % @@ -1820,7 +1820,7 @@ ml_gen_hl_tag_field_id(Type, ModuleInfo) = 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] ( diff --git a/compiler/mode_constraints.m b/compiler/mode_constraints.m index 82908daf1..93f415402 100644 --- a/compiler/mode_constraints.m +++ b/compiler/mode_constraints.m @@ -554,9 +554,11 @@ number_robdd_variables_in_goals(InstGraph, NonLocals, Occurring, number_robdd_variables_in_cases(_, _, Occurring, [], [], !RInfo) :- set.init(Occurring). number_robdd_variables_in_cases(InstGraph, NonLocals, Occurring, - [case(C, Goal0) | Cases0], [case(C, Goal) | Cases], !RInfo) :- + [Case0 | Cases0], [Case | Cases], !RInfo) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), number_robdd_variables_in_goal(InstGraph, NonLocals, Occurring0, Goal0, Goal, !RInfo), + Case = case(MainConsId, OtherConsIds, Goal), number_robdd_variables_in_cases(InstGraph, NonLocals, Occurring1, Cases0, Cases, !RInfo), Occurring = Occurring0 `set.union` Occurring1. diff --git a/compiler/mode_errors.m b/compiler/mode_errors.m index 9a0b70a41..706346203 100644 --- a/compiler/mode_errors.m +++ b/compiler/mode_errors.m @@ -1054,7 +1054,7 @@ mode_context_to_pieces(mode_context_call(CallId, ArgNum), Markers) = suffix(":"), nl]. mode_context_to_pieces(mode_context_unify(UnifyContext, _Side), _Markers) = Pieces :- - unify_context_first_to_pieces(no, _, UnifyContext, [], Pieces). + unify_context_first_to_pieces(is_not_first, _, UnifyContext, [], Pieces). %-----------------------------------------------------------------------------% diff --git a/compiler/mode_util.m b/compiler/mode_util.m index 10f64ce99..cfefb1c4e 100644 --- a/compiler/mode_util.m +++ b/compiler/mode_util.m @@ -1210,15 +1210,15 @@ recompute_instmap_delta_cases_2(_Atomic, _Var, [], [], _VarTypes, _InstMap, _NonLocals, [], !RI). recompute_instmap_delta_cases_2(Atomic, Var, [Case0 | Cases0], [Case | Cases], VarTypes, InstMap0, NonLocals, [InstMapDelta | InstMapDeltas], !RI) :- - Case0 = case(Functor, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), map.lookup(VarTypes, Var, Type), - update_module_info(instmap.bind_var_to_functor(Var, Type, Functor, - InstMap0), InstMap1, !RI), + update_module_info(bind_var_to_functors(Var, Type, + MainConsId, OtherConsIds, InstMap0), InstMap1, !RI), recompute_instmap_delta_1(Atomic, Goal0, Goal, VarTypes, InstMap1, InstMapDelta0, !RI), - update_module_info(instmap_delta_bind_var_to_functor(Var, Type, - Functor, InstMap0, InstMapDelta0), InstMapDelta, !RI), - Case = case(Functor, Goal), + update_module_info(instmap_delta_bind_var_to_functors(Var, Type, + MainConsId, OtherConsIds, InstMap0, InstMapDelta0), InstMapDelta, !RI), + Case = case(MainConsId, OtherConsIds, Goal), recompute_instmap_delta_cases_2(Atomic, Var, Cases0, Cases, VarTypes, InstMap0, NonLocals, InstMapDeltas, !RI). diff --git a/compiler/modecheck_unify.m b/compiler/modecheck_unify.m index c82f1d3db..184c40d48 100644 --- a/compiler/modecheck_unify.m +++ b/compiler/modecheck_unify.m @@ -1302,7 +1302,7 @@ categorize_unify_var_functor(ModeOfX, ModeOfXArgs, ArgModes0, ; % If the type has only one constructor, then the unification % cannot fail. - type_constructors(TypeOfX, ModuleInfo, Constructors), + type_constructors(ModuleInfo, TypeOfX, Constructors), Constructors = [_] -> CanFail = cannot_fail diff --git a/compiler/modes.m b/compiler/modes.m index ae824754c..8ea61f312 100644 --- a/compiler/modes.m +++ b/compiler/modes.m @@ -251,7 +251,7 @@ :- pred mode_info_remove_goals_live_vars(list(hlds_goal)::in, mode_info::in, mode_info::out) is det. - % modecheck_functor_test(ConsId, Var): + % modecheck_functor_test(Var, ConsId, !ModeInfo): % % Update the instmap to reflect the fact that Var was bound to ConsId. % This is used for the functor tests in `switch' statements. @@ -259,11 +259,20 @@ :- pred modecheck_functor_test(prog_var::in, cons_id::in, mode_info::in, mode_info::out) is det. - % compute_goal_instmap_delta(InstMap0, Goal, - % GoalInfo0, GoalInfo, ModeInfo0, ModeInfo): + % modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo): % - % Work out the instmap_delta for a goal from - % the instmaps before and after the goal. + % Update the instmap to reflect the fact that Var was bound to either + % MainConsId or one of the OtherConsIds. + % This is used for the functor tests in `switch' statements. + % +:- pred modecheck_functors_test(prog_var::in, cons_id::in, list(cons_id)::in, + mode_info::in, mode_info::out) is det. + + % compute_goal_instmap_delta(InstMap0, GoalExpr, GoalInfo0, GoalInfo, + % !ModeInfo): + % + % Work out the instmap_delta for a goal from the instmaps before and after + % the goal. % :- pred compute_goal_instmap_delta(instmap::in, hlds_goal_expr::in, hlds_goal_info::in, hlds_goal_info::out, @@ -1000,10 +1009,10 @@ modecheck_clause_disj(HeadVars, InstMap0, ArgFinalInsts0, Disjunct0, Disjunct, modecheck_clause_switch(HeadVars, InstMap0, ArgFinalInsts0, Var, Case0, Case, !ModeInfo, !IO) :- - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), mode_info_set_instmap(InstMap0, !ModeInfo), - modecheck_functor_test(Var, ConsId, !ModeInfo), + modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo), % Modecheck this case (if it is reachable). mode_info_get_instmap(!.ModeInfo, InstMap1), @@ -1024,7 +1033,7 @@ modecheck_clause_switch(HeadVars, InstMap0, ArgFinalInsts0, Var, Case0, Case, % Check that final insts match those specified in the mode declaration. modecheck_final_insts(HeadVars, no, ArgFinalInsts0, _ArgFinalInsts, Goal2, Goal, !ModeInfo), - Case = case(ConsId, Goal). + Case = case(MainConsId, OtherConsIds, Goal). :- pred unique_modecheck_clause_disj(list(prog_var)::in, instmap::in, list(mer_inst)::in, determinism::in, set(prog_var)::in, bag(prog_var)::in, @@ -1049,10 +1058,10 @@ unique_modecheck_clause_disj(HeadVars, InstMap0, ArgFinalInsts0, DisjDetism, unique_modecheck_clause_switch(HeadVars, InstMap0, ArgFinalInsts0, Var, Case0, Case, !ModeInfo, !IO) :- - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), mode_info_set_instmap(InstMap0, !ModeInfo), - modecheck_functor_test(Var, ConsId, !ModeInfo), + modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo), mode_info_get_instmap(!.ModeInfo, InstMap1), ( instmap.is_reachable(InstMap1) -> @@ -1071,7 +1080,7 @@ unique_modecheck_clause_switch(HeadVars, InstMap0, ArgFinalInsts0, Var, % Check that final insts match those specified in the mode declaration. modecheck_final_insts(HeadVars, no, ArgFinalInsts0, _ArgFinalInsts, Goal2, Goal, !ModeInfo), - Case = case(ConsId, Goal). + Case = case(MainConsId, OtherConsIds, Goal). %-----------------------------------------------------------------------------% @@ -2756,12 +2765,12 @@ modecheck_disj_list([Goal0 | Goals0], [Goal | Goals], [InstMap | InstMaps], modecheck_case_list([], _Var, [], [], !ModeInfo, !IO). modecheck_case_list([Case0 | Cases0], Var, [Case | Cases], [InstMap | InstMaps], !ModeInfo, !IO) :- - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), mode_info_get_instmap(!.ModeInfo, InstMap0), % Record the fact that Var was bound to ConsId in the % instmap before processing this case. - modecheck_functor_test(Var, ConsId, !ModeInfo), + modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo), % Modecheck this case (if it is reachable). mode_info_get_instmap(!.ModeInfo, InstMap1), @@ -2778,28 +2787,41 @@ modecheck_case_list([Case0 | Cases0], Var, [Case | Cases], % Don't lose the information added by the functor test above. fixup_switch_var(Var, InstMap0, InstMap, Goal1, Goal), - Case = case(ConsId, Goal), + Case = case(MainConsId, OtherConsIds, Goal), mode_info_set_instmap(InstMap0, !ModeInfo), modecheck_case_list(Cases0, Var, Cases, InstMaps, !ModeInfo, !IO). - % modecheck_functor_test(ConsId, Var): - % - % Update the instmap to reflect the fact that Var was bound to ConsId. - % This is used for the functor tests in `switch' statements. - % modecheck_functor_test(Var, ConsId, !ModeInfo) :- % Figure out the arity of this constructor, _including_ any type-infos % or typeclass-infos inserted for existential data types. mode_info_get_module_info(!.ModeInfo, ModuleInfo), mode_info_get_var_types(!.ModeInfo, VarTypes), map.lookup(VarTypes, Var, Type), - AdjustedArity = cons_id_adjusted_arity(ModuleInfo, Type, ConsId), + BoundInst = cons_id_to_bound_inst(ModuleInfo, Type, ConsId), - % record the fact that Var was bound to ConsId in the instmap - list.duplicate(AdjustedArity, free, ArgInsts), - modecheck_set_var_inst(Var, - bound(unique, [bound_functor(ConsId, ArgInsts)]), no, !ModeInfo). + % Record the fact that Var was bound to ConsId. + modecheck_set_var_inst(Var, bound(unique, [BoundInst]), no, !ModeInfo). + +modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo) :- + % Figure out the arity of this constructor, _including_ any type-infos + % or typeclass-infos inserted for existential data types. + mode_info_get_module_info(!.ModeInfo, ModuleInfo), + mode_info_get_var_types(!.ModeInfo, VarTypes), + map.lookup(VarTypes, Var, Type), + BoundInsts = list.map(cons_id_to_bound_inst(ModuleInfo, Type), + [MainConsId | OtherConsIds]), + + % Record the fact that Var was bound to MainConsId or one of the + % OtherConsIds. + modecheck_set_var_inst(Var, bound(unique, BoundInsts), no, !ModeInfo). + +:- func cons_id_to_bound_inst(module_info, mer_type, cons_id) = bound_inst. + +cons_id_to_bound_inst(ModuleInfo, Type, ConsId) = BoundInst :- + ConsIdAdjustedArity = cons_id_adjusted_arity(ModuleInfo, Type, ConsId), + list.duplicate(ConsIdAdjustedArity, free, ArgInsts), + BoundInst = bound_functor(ConsId, ArgInsts). %-----------------------------------------------------------------------------% diff --git a/compiler/notes/compiler_design.html b/compiler/notes/compiler_design.html index fe0555256..cb5498475 100644 --- a/compiler/notes/compiler_design.html +++ b/compiler/notes/compiler_design.html @@ -1242,6 +1242,7 @@ or perform LLDS-specific transformations on the HLDS:
  • lookup_switch.m
  • string_switch.m
  • tag_switch.m +
  • switch_case.m
  • switch_util.m -- this is in the backend_libs.m package, since it is also used by MLDS back-end @@ -1780,6 +1781,6 @@ The following modules are part of the libs.m package.
    -Last update was $Date: 2007-06-25 00:58:13 $ by $Author: wangp $@cs.mu.oz.au.
    +Last update was $Date: 2007-12-30 08:24:22 $ by $Author: zs $@cs.mu.oz.au.
    diff --git a/compiler/opt_debug.m b/compiler/opt_debug.m index 4e2dcb2a8..c4f480356 100644 --- a/compiler/opt_debug.m +++ b/compiler/opt_debug.m @@ -83,6 +83,9 @@ :- func dump_label(maybe(proc_label), label) = string. +:- func dump_labels_or_not_reached(maybe(proc_label), list(maybe(label))) + = string. + :- func dump_labels(maybe(proc_label), list(label)) = string. :- func dump_label_pairs(maybe(proc_label), list(pair(label))) = string. @@ -630,6 +633,18 @@ dump_label(yes(CurProcLabel), entry_label(_, ProcLabel)) = Str :- Str = dump_proclabel(ProcLabel) ). +dump_labels_or_not_reached(_, []) = "". +dump_labels_or_not_reached(MaybeProcLabel, [MaybeLabel | MaybeLabels]) = Str :- + ( + MaybeLabel = yes(Label), + LabelStr = dump_label(MaybeProcLabel, Label) + ; + MaybeLabel = no, + LabelStr = dump_code_addr(MaybeProcLabel, do_not_reached) + ), + Str = " " ++ LabelStr ++ + dump_labels_or_not_reached(MaybeProcLabel, MaybeLabels). + dump_labels(_, []) = "". dump_labels(MaybeProcLabel, [Label | Labels]) = " " ++ dump_label(MaybeProcLabel, Label) ++ @@ -761,7 +776,7 @@ dump_instr(ProcLabel, PrintComments, Instr) = Str :- ; Instr = computed_goto(Rval, Labels), Str = "computed_goto " ++ dump_rval(yes(ProcLabel), Rval) ++ ":" - ++ dump_labels(yes(ProcLabel), Labels) + ++ dump_labels_or_not_reached(yes(ProcLabel), Labels) ; Instr = arbitrary_c_code(AL, _, Code), Str = "arbitrary_c_code(" ++ dump_affects_liveness(AL) ++ "\n" ++ diff --git a/compiler/opt_util.m b/compiler/opt_util.m index 163e528bb..38aef903c 100644 --- a/compiler/opt_util.m +++ b/compiler/opt_util.m @@ -309,8 +309,8 @@ :- pred replace_labels_code_addr(code_addr::in, code_addr::out, map(label, label)::in) is det. -:- pred replace_labels_label_list(list(label)::in, list(label)::out, - map(label, label)::in) is det. +:- pred replace_labels_maybe_label_list(list(maybe(label))::in, + list(maybe(label))::out, map(label, label)::in) is det. :- pred replace_labels_label(label::in, label::out, map(label, label)::in) is det. @@ -1256,7 +1256,9 @@ instr_labels_2(mkframe(_, yes(Addr)), [], [Addr]). instr_labels_2(mkframe(_, no), [], []). instr_labels_2(label(_), [], []). instr_labels_2(goto(Addr), [], [Addr]). -instr_labels_2(computed_goto(_, Labels), Labels, []). +instr_labels_2(computed_goto(_, MaybeLabels), Labels, []) :- + possible_targets_maybe_labels(MaybeLabels, [], RevLabels), + list.reverse(RevLabels, Labels). instr_labels_2(arbitrary_c_code(_, _, _), [], []). instr_labels_2(if_val(_, Addr), [], [Addr]). instr_labels_2(save_maxfr(_), [], []). @@ -1315,7 +1317,9 @@ possible_targets(goto(CodeAddr), Labels, CodeAddrs) :- Labels = [], CodeAddrs = [CodeAddr] ). -possible_targets(computed_goto(_, Labels), Labels, []). +possible_targets(computed_goto(_, MaybeLabels), Labels, []) :- + possible_targets_maybe_labels(MaybeLabels, [], RevLabels), + list.reverse(RevLabels, Labels). possible_targets(arbitrary_c_code(_, _, _), [], []). possible_targets(if_val(_, CodeAddr), Labels, CodeAddrs) :- ( CodeAddr = code_label(Label) -> @@ -1354,6 +1358,19 @@ possible_targets(foreign_proc_code(_, _, _, MaybeFixedLabel, MaybeLayoutLabel, foreign_proc_labels(MaybeFixedLabel, MaybeLayoutLabel, no, MaybeSubLabel, Labels). +:- pred possible_targets_maybe_labels(list(maybe(label))::in, + list(label)::in, list(label)::out) is det. + +possible_targets_maybe_labels([], !RevLabels). +possible_targets_maybe_labels([MaybeLabel | MaybeLabels], !RevLabels) :- + ( + MaybeLabel = yes(Label), + !:RevLabels = [Label | !.RevLabels] + ; + MaybeLabel = no + ), + possible_targets_maybe_labels(MaybeLabels, !RevLabels). + :- pred foreign_proc_labels(maybe(label)::in, maybe(label)::in, maybe(label)::in, maybe(label)::in, list(label)::out) is det. @@ -2151,7 +2168,7 @@ replace_labels_instr(Uinstr0, Uinstr, ReplMap, ReplData) :- replace_labels_code_addr(Target0, Target, ReplMap), Uinstr = goto(Target) ; - Uinstr0 = computed_goto(Rval0, Labels0), + Uinstr0 = computed_goto(Rval0, MaybeLabels0), ( ReplData = yes, replace_labels_rval(Rval0, Rval, ReplMap) @@ -2159,8 +2176,8 @@ replace_labels_instr(Uinstr0, Uinstr, ReplMap, ReplData) :- ReplData = no, Rval = Rval0 ), - replace_labels_label_list(Labels0, Labels, ReplMap), - Uinstr = computed_goto(Rval, Labels) + replace_labels_maybe_label_list(MaybeLabels0, MaybeLabels, ReplMap), + Uinstr = computed_goto(Rval, MaybeLabels) ; Uinstr0 = arbitrary_c_code(AffectsLiveness, Lvals0, Code), ( @@ -2581,10 +2598,18 @@ replace_labels_code_addr(Addr0, Addr, ReplMap) :- Addr = Addr0 ). -replace_labels_label_list([], [], _ReplMap). -replace_labels_label_list([Label0 | Labels0], [Label | Labels], ReplMap) :- - replace_labels_label(Label0, Label, ReplMap), - replace_labels_label_list(Labels0, Labels, ReplMap). +replace_labels_maybe_label_list([], [], _ReplMap). +replace_labels_maybe_label_list([MaybeLabel0 | MaybeLabels0], + [MaybeLabel | MaybeLabels], ReplMap) :- + ( + MaybeLabel0 = yes(Label0), + replace_labels_label(Label0, Label, ReplMap), + MaybeLabel = yes(Label) + ; + MaybeLabel0 = no, + MaybeLabel = no + ), + replace_labels_maybe_label_list(MaybeLabels0, MaybeLabels, ReplMap). replace_labels_label(Label0, Label, ReplMap) :- ( map.search(ReplMap, Label0, NewLabel) -> diff --git a/compiler/options.m b/compiler/options.m index d70eb1738..25a7e654e 100644 --- a/compiler/options.m +++ b/compiler/options.m @@ -483,6 +483,8 @@ % Insert calls to solver type initialisation predicates when % the inst of solver type variables changes from free to any. + ; allow_multi_arm_switches + % Code generation options ; low_level_debug ; table_debug @@ -1230,7 +1232,8 @@ option_defaults_2(internal_use_option, [ % stable. size_region_disj_snapshot - int(3), size_region_commit_entry - int(1), - solver_type_auto_init - bool(no) + solver_type_auto_init - bool(no), + allow_multi_arm_switches - bool(yes) ]). option_defaults_2(code_gen_option, [ % Code Generation Options @@ -2023,6 +2026,7 @@ long_option("size-region-disj-protect", size_region_disj_protect). long_option("size-region-disj-snapshot", size_region_disj_snapshot). long_option("size-region-commit-entry", size_region_commit_entry). long_option("solver-type-auto-init", solver_type_auto_init). +long_option("allow-multi-arm-switches", allow_multi_arm_switches). % code generation options long_option("low-level-debug", low_level_debug). @@ -4143,6 +4147,12 @@ options_help_compilation_model --> % "--solver-type-auto-init", % "(This option is not for general use.)", % Allow automatic initialisation of solver types. + + % This is a developer only option. +% "--allow-multi-arm-switches", +% "(This option is not for general use.)", +% Allow the compiler to generate switches in which one arm handles +% more than one cons_id. ]). :- pred options_help_code_generation(io::di, io::uo) is det. diff --git a/compiler/pd_cost.m b/compiler/pd_cost.m index 4b681b620..e11b59064 100644 --- a/compiler/pd_cost.m +++ b/compiler/pd_cost.m @@ -156,7 +156,7 @@ goal_costs([Goal | Goals], Cost0, Cost) :- :- pred cases_cost(list(case)::in, int::in, int::out) is det. cases_cost([], Cost, Cost). -cases_cost([case(_, Goal) | Cases], Cost0, Cost) :- +cases_cost([case(_, _, Goal) | Cases], Cost0, Cost) :- goal_cost(Goal, Cost1), Cost2 = Cost0 + Cost1, cases_cost(Cases, Cost2, Cost). diff --git a/compiler/pd_info.m b/compiler/pd_info.m index 3cc8efbcb..b375d33f9 100644 --- a/compiler/pd_info.m +++ b/compiler/pd_info.m @@ -107,8 +107,8 @@ :- pred pd_info_update_goal(hlds_goal::in, pd_info::in, pd_info::out) is det. -:- pred pd_info_bind_var_to_functor(prog_var::in, cons_id::in, - pd_info::in, pd_info::out) is det. +:- pred pd_info_bind_var_to_functors(prog_var::in, + cons_id::in, list(cons_id)::in, pd_info::in, pd_info::out) is det. :- pred pd_info_unset_unfold_info(pd_info::in, pd_info::out) is det. @@ -203,14 +203,14 @@ pd_info_update_goal(hlds_goal(_, GoalInfo), !PDInfo) :- instmap.apply_instmap_delta(InstMap0, Delta, InstMap), pd_info_set_instmap(InstMap, !PDInfo). -pd_info_bind_var_to_functor(Var, ConsId, !PDInfo) :- +pd_info_bind_var_to_functors(Var, MainConsId, OtherConsIds, !PDInfo) :- pd_info_get_instmap(!.PDInfo, InstMap0), pd_info_get_module_info(!.PDInfo, ModuleInfo0), pd_info_get_proc_info(!.PDInfo, ProcInfo), proc_info_get_vartypes(ProcInfo, VarTypes), map.lookup(VarTypes, Var, Type), - instmap.bind_var_to_functor(Var, Type, ConsId, InstMap0, InstMap, - ModuleInfo0, ModuleInfo), + bind_var_to_functors(Var, Type, MainConsId, OtherConsIds, + InstMap0, InstMap, ModuleInfo0, ModuleInfo), pd_info_set_instmap(InstMap, !PDInfo), pd_info_set_module_info(ModuleInfo, !PDInfo). diff --git a/compiler/pd_util.m b/compiler/pd_util.m index 8d797c156..063973af1 100644 --- a/compiler/pd_util.m +++ b/compiler/pd_util.m @@ -371,14 +371,15 @@ rerun_det_analysis(Goal0, Goal, !PDInfo, !IO) :- pd_info_get_proc_info(!.PDInfo, ProcInfo), pd_info_get_module_info(!.PDInfo, ModuleInfo0), module_info_set_pred_proc_info(PredId, ProcId, PredInfo, ProcInfo, - ModuleInfo0, ModuleInfo), - pd_info_set_module_info(ModuleInfo, !PDInfo), + ModuleInfo0, ModuleInfo1), proc_info_get_vartypes(ProcInfo, VarTypes), - det_info_init(ModuleInfo, VarTypes, PredId, ProcId, DetInfo), + det_info_init(ModuleInfo1, VarTypes, PredId, ProcId, DetInfo0), pd_info_get_instmap(!.PDInfo, InstMap), - det_infer_goal(Goal0, Goal, InstMap, SolnContext, [], no, DetInfo, _, _, - [], Specs), + det_infer_goal(Goal0, Goal, InstMap, SolnContext, [], no, _, _, + DetInfo0, DetInfo, [], Specs), + det_info_get_module_info(DetInfo, ModuleInfo2), + pd_info_set_module_info(ModuleInfo2, !PDInfo), % Make sure there were no errors. globals.io_get_globals(Globals, !IO), @@ -574,7 +575,7 @@ get_branch_instmap_deltas(Goal, [CondDelta, ThenDelta, ElseDelta]) :- get_branch_instmap_deltas(hlds_goal(switch(_, _, Cases), _), InstMapDeltas) :- GetCaseInstMapDelta = (pred(Case::in, InstMapDelta::out) is det :- - Case = case(_, hlds_goal(_, CaseInfo)), + Case = case(_, _, hlds_goal(_, CaseInfo)), InstMapDelta = goal_info_get_instmap_delta(CaseInfo) ), list.map(GetCaseInstMapDelta, Cases, InstMapDeltas). @@ -715,17 +716,18 @@ examine_branch_list(ModuleInfo, ProcArgInfo, BranchNo, [Goal | Goals], module_info::in, module_info::out) is det. examine_case_list(_, _, _, [], _, _, !Vars, !ModuleInfo). -examine_case_list(ProcArgInfo, BranchNo, Var, - [case(ConsId, Goal) | Goals], VarTypes, InstMap, !Vars, !ModuleInfo) :- +examine_case_list(ProcArgInfo, BranchNo, Var, [Case | Cases], + VarTypes, InstMap0, !Vars, !ModuleInfo) :- map.lookup(VarTypes, Var, Type), - instmap.bind_var_to_functor(Var, Type, ConsId, InstMap, InstMap1, - !ModuleInfo), + Case = case(MainConsId, OtherConsIds, Goal), + bind_var_to_functors(Var, Type, MainConsId, OtherConsIds, + InstMap0, InstMap1, !ModuleInfo), goal_to_conj_list(Goal, GoalList), examine_branch(!.ModuleInfo, ProcArgInfo, BranchNo, GoalList, VarTypes, InstMap1, !Vars), NextBranch = BranchNo + 1, - examine_case_list(ProcArgInfo, NextBranch, Var, Goals, - VarTypes, InstMap, !Vars, !ModuleInfo). + examine_case_list(ProcArgInfo, NextBranch, Var, Cases, + VarTypes, InstMap0, !Vars, !ModuleInfo). :- pred examine_branch(module_info::in, pd_arg_info::in, int::in, hlds_goals::in, vartypes::in, instmap::in, diff --git a/compiler/peephole.m b/compiler/peephole.m index 39b9de812..e9aeb4570 100644 --- a/compiler/peephole.m +++ b/compiler/peephole.m @@ -102,17 +102,18 @@ peephole_opt_instr(Instr0, Instrs0, InvalidPatterns, Instrs, Mod) :- % Build a map that associates each label in a computed goto with the % values of the switch rval that cause a jump to it. % -:- pred build_peephole_jump_label_map(list(label)::in, int::in, - map(label, list(int))::in, map(label, list(int))::out) is det. +:- pred build_peephole_jump_label_map(list(maybe(label))::in, int::in, + map(label, list(int))::in, map(label, list(int))::out) is semidet. build_peephole_jump_label_map([], _, !LabelMap). -build_peephole_jump_label_map([Label | Labels], Val, !LabelMap) :- +build_peephole_jump_label_map([MaybeLabel | MaybeLabels], Val, !LabelMap) :- + MaybeLabel = yes(Label), ( map.search(!.LabelMap, Label, Vals0) -> map.det_update(!.LabelMap, Label, [Val | Vals0], !:LabelMap) ; map.det_insert(!.LabelMap, Label, [Val], !:LabelMap) ), - build_peephole_jump_label_map(Labels, Val + 1, !LabelMap). + build_peephole_jump_label_map(MaybeLabels, Val + 1, !LabelMap). % If one of the two labels has only one associated value, return it and % the associated value as the first two output arguments, and the diff --git a/compiler/polymorphism.m b/compiler/polymorphism.m index 3b4c3d9f8..c744bcb10 100644 --- a/compiler/polymorphism.m +++ b/compiler/polymorphism.m @@ -1690,9 +1690,9 @@ polymorphism_process_goal_list([Goal0 | Goals0], [Goal | Goals], !Info) :- polymorphism_process_case_list([], [], !Info). polymorphism_process_case_list([Case0 | Cases0], [Case | Cases], !Info) :- - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), polymorphism_process_goal(Goal0, Goal, !Info), - Case = case(ConsId, Goal), + Case = case(MainConsId, OtherConsIds, Goal), polymorphism_process_case_list(Cases0, Cases, !Info). %-----------------------------------------------------------------------------% diff --git a/compiler/post_term_analysis.m b/compiler/post_term_analysis.m index ba5d3def7..40d993cf5 100644 --- a/compiler/post_term_analysis.m +++ b/compiler/post_term_analysis.m @@ -211,7 +211,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 621cd8f25..9976c7dd9 100644 --- a/compiler/post_typecheck.m +++ b/compiler/post_typecheck.m @@ -1366,7 +1366,7 @@ get_constructor_containing_field(ModuleInfo, TermType, FieldName, map.lookup(Types, 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(Ctors, FieldName, ConsId, FieldNumber) ; diff --git a/compiler/prog_rep.m b/compiler/prog_rep.m index 75eb6fe51..41d3a9850 100644 --- a/compiler/prog_rep.m +++ b/compiler/prog_rep.m @@ -95,8 +95,8 @@ represent_proc_as_bytecodes(HeadVars, Goal, InstMap0, VarTypes, VarNumMap, Info = info(FileName, VarTypes, VarNumMap, VarNumRep, ModuleInfo), var_num_rep_byte(VarNumRep, VarNumRepByte), - string_to_byte_list(FileName, !StackInfo, FileNameBytes), - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), + string_to_byte_list(FileName, FileNameBytes, !StackInfo), + goal_to_byte_list(Goal, InstMap0, Info, GoalBytes, !StackInfo), ProcRepBytes0 = [VarNumRepByte] ++ FileNameBytes ++ vars_to_byte_list(Info, HeadVars) ++ GoalBytes, int32_to_byte_list(list.length(ProcRepBytes0) + 4, LimitBytes), @@ -116,187 +116,191 @@ max_var_num(_, VarNum1 - _, VarNum2) = Max :- %---------------------------------------------------------------------------% :- pred goal_to_byte_list(hlds_goal::in, instmap::in, prog_rep_info::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. + list(int)::out, stack_layout_info::in, stack_layout_info::out) is det. -goal_to_byte_list(hlds_goal(GoalExpr, GoalInfo), InstMap0, Info, - !StackInfo, Bytes) :- - goal_expr_to_byte_list(GoalExpr, GoalInfo, InstMap0, Info, !StackInfo, - Bytes). +goal_to_byte_list(hlds_goal(GoalExpr, GoalInfo), InstMap0, Info, Bytes, + !StackInfo) :- + goal_expr_to_byte_list(GoalExpr, GoalInfo, InstMap0, Info, Bytes, + !StackInfo). :- pred goal_expr_to_byte_list(hlds_goal_expr::in, hlds_goal_info::in, - instmap::in, prog_rep_info::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. + instmap::in, prog_rep_info::in, list(int)::out, + stack_layout_info::in, stack_layout_info::out) is det. -goal_expr_to_byte_list(conj(ConjType, Goals), _, InstMap0, Info, !StackInfo, - Bytes) :- - expect(unify(ConjType, plain_conj), this_file, - "non-plain conjunction and declarative debugging"), - conj_to_byte_list(Goals, InstMap0, Info, !StackInfo, ConjBytes), - Bytes = [goal_type_to_byte(goal_conj)] ++ - length_to_byte_list(Goals) ++ ConjBytes. -goal_expr_to_byte_list(disj(Goals), _, InstMap0, Info, !StackInfo, Bytes) :- - disj_to_byte_list(Goals, InstMap0, Info, !StackInfo, DisjBytes), - Bytes = [goal_type_to_byte(goal_disj)] ++ - length_to_byte_list(Goals) ++ DisjBytes. -goal_expr_to_byte_list(negation(Goal), _GoalInfo, InstMap0, Info, !StackInfo, - Bytes) :- - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), - Bytes = [goal_type_to_byte(goal_neg)] ++ GoalBytes. -goal_expr_to_byte_list(if_then_else(_, Cond, Then, Else), _, InstMap0, Info, - !StackInfo, Bytes) :- - Cond = hlds_goal(_, CondGoalInfo), - InstMapDelta = goal_info_get_instmap_delta(CondGoalInfo), - instmap.apply_instmap_delta(InstMap0, InstMapDelta, InstMap1), - goal_to_byte_list(Cond, InstMap0, Info, !StackInfo, CondBytes), - goal_to_byte_list(Then, InstMap1, Info, !StackInfo, ThenBytes), - goal_to_byte_list(Else, InstMap0, Info, !StackInfo, ElseBytes), - Bytes = [goal_type_to_byte(goal_ite)] ++ - CondBytes ++ ThenBytes ++ ElseBytes. -goal_expr_to_byte_list(unify(_, _, _, Uni, _), GoalInfo, InstMap0, Info, - !StackInfo, Bytes) :- - atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, - AtomicBytes, BoundVars), +goal_expr_to_byte_list(GoalExpr, GoalInfo, InstMap0, Info, Bytes, + !StackInfo) :- ( - Uni = assign(Target, Source), - Bytes = [goal_type_to_byte(goal_assign)] ++ - var_to_byte_list(Info, Target) ++ - var_to_byte_list(Info, Source) ++ - AtomicBytes + GoalExpr = conj(ConjType, Goals), + expect(unify(ConjType, plain_conj), this_file, + "non-plain conjunction and declarative debugging"), + conj_to_byte_list(Goals, InstMap0, Info, ConjBytes, !StackInfo), + Bytes = [goal_type_to_byte(goal_conj)] ++ + length_to_byte_list(Goals) ++ ConjBytes ; - Uni = construct(Var, ConsId, Args, ArgModes, _, _, _), - cons_id_to_byte_list(ConsId, !StackInfo, ConsIdBytes), - ( list.all_true(lhs_final_is_ground(Info), ArgModes) -> - Bytes = [goal_type_to_byte(goal_construct)] ++ - var_to_byte_list(Info, Var) ++ - ConsIdBytes ++ - vars_to_byte_list(Info, Args) ++ + GoalExpr = disj(Goals), + disj_to_byte_list(Goals, InstMap0, Info, DisjBytes, !StackInfo), + Bytes = [goal_type_to_byte(goal_disj)] ++ + length_to_byte_list(Goals) ++ DisjBytes + ; + GoalExpr = negation(SubGoal), + goal_to_byte_list(SubGoal, InstMap0, Info, SubGoalBytes, !StackInfo), + Bytes = [goal_type_to_byte(goal_neg)] ++ SubGoalBytes + ; + GoalExpr = if_then_else(_, Cond, Then, Else), + Cond = hlds_goal(_, CondGoalInfo), + InstMapDelta = goal_info_get_instmap_delta(CondGoalInfo), + instmap.apply_instmap_delta(InstMap0, InstMapDelta, InstMap1), + goal_to_byte_list(Cond, InstMap0, Info, CondBytes, !StackInfo), + goal_to_byte_list(Then, InstMap1, Info, ThenBytes, !StackInfo), + goal_to_byte_list(Else, InstMap0, Info, ElseBytes, !StackInfo), + Bytes = [goal_type_to_byte(goal_ite)] ++ + CondBytes ++ ThenBytes ++ ElseBytes + ; + GoalExpr = unify(_, _, _, Uni, _), + atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, + AtomicBytes, BoundVars, !StackInfo), + ( + Uni = assign(Target, Source), + Bytes = [goal_type_to_byte(goal_assign)] ++ + var_to_byte_list(Info, Target) ++ + var_to_byte_list(Info, Source) ++ AtomicBytes ; - filter_input_args(Info, ArgModes, Args, MaybeArgs), - Bytes = [goal_type_to_byte(goal_partial_construct)] ++ - var_to_byte_list(Info, Var) ++ - ConsIdBytes ++ - maybe_vars_to_byte_list(Info, MaybeArgs) ++ - AtomicBytes - ) - ; - Uni = deconstruct(Var, ConsId, Args, ArgModes, _, _), - cons_id_to_byte_list(ConsId, !StackInfo, ConsIdBytes), - ( list.member(Var, BoundVars) -> - filter_input_args(Info, ArgModes, Args, MaybeArgs), - Bytes = [goal_type_to_byte(goal_partial_deconstruct)]++ - var_to_byte_list(Info, Var) ++ - ConsIdBytes ++ - maybe_vars_to_byte_list(Info, MaybeArgs) ++ + Uni = construct(Var, ConsId, Args, ArgModes, _, _, _), + cons_id_to_byte_list(ConsId, ConsIdBytes, !StackInfo), + ( list.all_true(lhs_final_is_ground(Info), ArgModes) -> + Bytes = [goal_type_to_byte(goal_construct)] ++ + var_to_byte_list(Info, Var) ++ + ConsIdBytes ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ; + filter_input_args(Info, ArgModes, Args, MaybeArgs), + Bytes = [goal_type_to_byte(goal_partial_construct)] ++ + var_to_byte_list(Info, Var) ++ + ConsIdBytes ++ + maybe_vars_to_byte_list(Info, MaybeArgs) ++ + AtomicBytes + ) + ; + Uni = deconstruct(Var, ConsId, Args, ArgModes, _, _), + cons_id_to_byte_list(ConsId, ConsIdBytes, !StackInfo), + ( list.member(Var, BoundVars) -> + filter_input_args(Info, ArgModes, Args, MaybeArgs), + Bytes = [goal_type_to_byte(goal_partial_deconstruct)]++ + var_to_byte_list(Info, Var) ++ + ConsIdBytes ++ + maybe_vars_to_byte_list(Info, MaybeArgs) ++ + AtomicBytes + ; + Bytes = [goal_type_to_byte(goal_deconstruct)] ++ + var_to_byte_list(Info, Var) ++ + ConsIdBytes ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ) + ; + Uni = simple_test(Var1, Var2), + Bytes = [goal_type_to_byte(goal_simple_test)] ++ + var_to_byte_list(Info, Var1) ++ + var_to_byte_list(Info, Var2) ++ AtomicBytes ; - Bytes = [goal_type_to_byte(goal_deconstruct)] ++ - var_to_byte_list(Info, Var) ++ - ConsIdBytes ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes + Uni = complicated_unify(_, _, _), + unexpected(this_file, "goal_expr_to_byte_list: complicated_unify") ) ; - Uni = simple_test(Var1, Var2), - Bytes = [goal_type_to_byte(goal_simple_test)] ++ - var_to_byte_list(Info, Var1) ++ - var_to_byte_list(Info, Var2) ++ - AtomicBytes + GoalExpr = switch(SwitchVar, _, Cases), + cases_to_byte_list(Cases, InstMap0, Info, CasesBytes, !StackInfo), + Bytes = [goal_type_to_byte(goal_switch)] ++ + var_to_byte_list(Info, SwitchVar) ++ + length_to_byte_list(Cases) ++ CasesBytes ; - Uni = complicated_unify(_, _, _), - unexpected(this_file, "goal_expr_to_byte_list: complicated_unify") - ). -goal_expr_to_byte_list(switch(SwitchVar, _, Cases), _, InstMap0, Info, - !StackInfo, Bytes) :- - cases_to_byte_list(Cases, InstMap0, Info, !StackInfo, CasesBytes), - Bytes = [goal_type_to_byte(goal_switch)] ++ - var_to_byte_list(Info, SwitchVar) ++ - length_to_byte_list(Cases) ++ CasesBytes. -goal_expr_to_byte_list(scope(_, Goal), GoalInfo, InstMap0, Info, !StackInfo, - Bytes) :- - Goal = hlds_goal(_, InnerGoalInfo), - OuterDetism = goal_info_get_determinism(GoalInfo), - InnerDetism = goal_info_get_determinism(InnerGoalInfo), - ( InnerDetism = OuterDetism -> - MaybeCut = 0 - ; - MaybeCut = 1 - ), - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), - Bytes = [goal_type_to_byte(goal_scope)] ++ - [MaybeCut] ++ GoalBytes. -goal_expr_to_byte_list(generic_call(GenericCall, Args, _, _), - GoalInfo, InstMap0, Info, !StackInfo, Bytes) :- - atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, - AtomicBytes, _), - ( - GenericCall = higher_order(PredVar, _, _, _), - Bytes = [goal_type_to_byte(goal_ho_call)] ++ - var_to_byte_list(Info, PredVar) ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes - ; - GenericCall = class_method(Var, MethodNum, _, _), - Bytes = [goal_type_to_byte(goal_method_call)] ++ - var_to_byte_list(Info, Var) ++ - method_num_to_byte_list(MethodNum) ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes - ; - GenericCall = event_call(EventName), - string_to_byte_list(EventName, !StackInfo, EventNameBytes), - Bytes = [goal_type_to_byte(goal_event_call)] ++ - EventNameBytes ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes - ; - GenericCall = cast(_), - ( Args = [InputArg, OutputArg] -> - Bytes = [goal_type_to_byte(goal_cast)] ++ - var_to_byte_list(Info, OutputArg) ++ - var_to_byte_list(Info, InputArg) ++ - AtomicBytes + GoalExpr = scope(_, SubGoal), + SubGoal = hlds_goal(_, SuboalInfo), + OuterDetism = goal_info_get_determinism(GoalInfo), + InnerDetism = goal_info_get_determinism(SuboalInfo), + ( InnerDetism = OuterDetism -> + MaybeCut = 0 ; - unexpected(this_file, "goal_expr_to_byte_list: cast arity != 2") - ) - ). -goal_expr_to_byte_list(plain_call(PredId, _, Args, Builtin, _, _), - GoalInfo, InstMap0, Info, !StackInfo, Bytes) :- - atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, - AtomicBytes, _), - module_info_pred_info(Info ^ module_info, PredId, PredInfo), - ModuleSymName = pred_info_module(PredInfo), - ModuleName = sym_name_to_string(ModuleSymName), - PredName = pred_info_name(PredInfo), - string_to_byte_list(ModuleName, !StackInfo, ModuleNameBytes), - string_to_byte_list(PredName, !StackInfo, PredNameBytes), - ( - Builtin = not_builtin, - Bytes = [goal_type_to_byte(goal_plain_call)] ++ - ModuleNameBytes ++ - PredNameBytes ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes - ; - ( Builtin = inline_builtin - ; Builtin = out_of_line_builtin + MaybeCut = 1 ), - Bytes = [goal_type_to_byte(goal_builtin_call)] ++ - ModuleNameBytes ++ - PredNameBytes ++ - vars_to_byte_list(Info, Args) ++ - AtomicBytes + goal_to_byte_list(SubGoal, InstMap0, Info, GoalBytes, !StackInfo), + Bytes = [goal_type_to_byte(goal_scope)] ++ [MaybeCut] ++ GoalBytes + ; + GoalExpr = generic_call(GenericCall, Args, _, _), + atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, + AtomicBytes, _BoundVars, !StackInfo), + ( + GenericCall = higher_order(PredVar, _, _, _), + Bytes = [goal_type_to_byte(goal_ho_call)] ++ + var_to_byte_list(Info, PredVar) ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ; + GenericCall = class_method(Var, MethodNum, _, _), + Bytes = [goal_type_to_byte(goal_method_call)] ++ + var_to_byte_list(Info, Var) ++ + method_num_to_byte_list(MethodNum) ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ; + GenericCall = event_call(EventName), + string_to_byte_list(EventName, EventNameBytes, !StackInfo), + Bytes = [goal_type_to_byte(goal_event_call)] ++ + EventNameBytes ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ; + GenericCall = cast(_), + ( Args = [InputArg, OutputArg] -> + Bytes = [goal_type_to_byte(goal_cast)] ++ + var_to_byte_list(Info, OutputArg) ++ + var_to_byte_list(Info, InputArg) ++ + AtomicBytes + ; + unexpected(this_file, "goal_expr_to_byte_list: cast arity != 2") + ) + ) + ; + GoalExpr = plain_call(PredId, _, Args, Builtin, _, _), + atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, + AtomicBytes, _BoundVars, !StackInfo), + module_info_pred_info(Info ^ module_info, PredId, PredInfo), + ModuleSymName = pred_info_module(PredInfo), + ModuleName = sym_name_to_string(ModuleSymName), + PredName = pred_info_name(PredInfo), + string_to_byte_list(ModuleName, ModuleNameBytes, !StackInfo), + string_to_byte_list(PredName, PredNameBytes, !StackInfo), + ( + Builtin = not_builtin, + Bytes = [goal_type_to_byte(goal_plain_call)] ++ + ModuleNameBytes ++ + PredNameBytes ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ; + ( Builtin = inline_builtin + ; Builtin = out_of_line_builtin + ), + Bytes = [goal_type_to_byte(goal_builtin_call)] ++ + ModuleNameBytes ++ + PredNameBytes ++ + vars_to_byte_list(Info, Args) ++ + AtomicBytes + ) + ; + GoalExpr = call_foreign_proc(_, _PredId, _, Args, _, _, _), + ArgVars = list.map(foreign_arg_var, Args), + atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, + AtomicBytes, _BoundVars, !StackInfo), + Bytes = [goal_type_to_byte(goal_foreign)] ++ + vars_to_byte_list(Info, ArgVars) ++ AtomicBytes + ; + GoalExpr = shorthand(_), + % these should have been expanded out by now + unexpected(this_file, "goal_expr_to_byte_list: unexpected shorthand") ). -goal_expr_to_byte_list(call_foreign_proc(_, _PredId, _, Args, _, _, _), - GoalInfo, InstMap0, Info, !StackInfo, Bytes) :- - ArgVars = list.map(foreign_arg_var, Args), - atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, - AtomicBytes, _), - Bytes = [goal_type_to_byte(goal_foreign)] ++ - vars_to_byte_list(Info, ArgVars) ++ AtomicBytes. -goal_expr_to_byte_list(shorthand(_), _, _, _, !StackInfo, _) :- - % these should have been expanded out by now - unexpected(this_file, "goal_expr_to_byte_list: unexpected shorthand"). :- pred lhs_final_is_ground(prog_rep_info::in, uni_mode::in) is semidet. @@ -328,11 +332,11 @@ filter_input_args(_, [_ | _], [], _) :- %---------------------------------------------------------------------------% :- pred atomic_goal_info_to_byte_list(hlds_goal_info::in, instmap::in, - prog_rep_info::in, stack_layout_info::in, stack_layout_info::out, - list(int)::out, list(prog_var)::out) is det. + prog_rep_info::in, list(int)::out, list(prog_var)::out, + stack_layout_info::in, stack_layout_info::out) is det. -atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, Bytes, - BoundVars) :- +atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, Bytes, BoundVars, + !StackInfo) :- Detism = goal_info_get_determinism(GoalInfo), Context = goal_info_get_context(GoalInfo), term.context_file(Context, FileName0), @@ -347,17 +351,32 @@ atomic_goal_info_to_byte_list(GoalInfo, InstMap0, Info, !StackInfo, Bytes, instmap_changed_vars(InstMap0, InstMap, Info ^ vartypes, Info ^ module_info, ChangedVars), set.to_sorted_list(ChangedVars, BoundVars), - string_to_byte_list(FileName, !StackInfo, FileNameBytes), + string_to_byte_list(FileName, FileNameBytes, !StackInfo), Bytes = [represent_determinism(Detism)] ++ FileNameBytes ++ lineno_to_byte_list(LineNo) ++ vars_to_byte_list(Info, BoundVars). -:- pred cons_id_to_byte_list(cons_id::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. +:- pred cons_id_and_arity_to_byte_list(cons_id::in, list(int)::out, + stack_layout_info::in, stack_layout_info::out) is det. -cons_id_to_byte_list(SymName, !StackInfo, Bytes) :- - string_to_byte_list(cons_id_rep(SymName), !StackInfo, Bytes). +cons_id_and_arity_to_byte_list(ConsId, ConsIdBytes, !StackInfo) :- + cons_id_to_byte_list(ConsId, FunctorBytes, !StackInfo), + MaybeArity = cons_id_maybe_arity(ConsId), + ( + MaybeArity = yes(Arity) + ; + MaybeArity = no, + Arity = 0 + ), + short_to_byte_list(Arity, ArityBytes), + ConsIdBytes = FunctorBytes ++ ArityBytes. + +:- pred cons_id_to_byte_list(cons_id::in, list(int)::out, + stack_layout_info::in, stack_layout_info::out) is det. + +cons_id_to_byte_list(SymName, Bytes, !StackInfo) :- + string_to_byte_list(cons_id_rep(SymName), Bytes, !StackInfo). :- func cons_id_rep(cons_id) = string. @@ -384,48 +403,45 @@ sym_base_name_to_string(qualified(_, String)) = String. %---------------------------------------------------------------------------% :- pred conj_to_byte_list(hlds_goals::in, instmap::in, prog_rep_info::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. + list(int)::out, stack_layout_info::in, stack_layout_info::out) is det. -conj_to_byte_list([], _, _, !StackInfo, []). -conj_to_byte_list([Goal | Goals], InstMap0, Info, !StackInfo, Bytes) :- - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), +conj_to_byte_list([], _, _, [], !StackInfo). +conj_to_byte_list([Goal | Goals], InstMap0, Info, Bytes, !StackInfo) :- + goal_to_byte_list(Goal, InstMap0, Info, GoalBytes, !StackInfo), Goal = hlds_goal(_, GoalInfo), InstMapDelta = goal_info_get_instmap_delta(GoalInfo), instmap.apply_instmap_delta(InstMap0, InstMapDelta, InstMap1), - conj_to_byte_list(Goals, InstMap1, Info, !StackInfo, GoalsBytes), + conj_to_byte_list(Goals, InstMap1, Info, GoalsBytes, !StackInfo), Bytes = GoalBytes ++ GoalsBytes. %---------------------------------------------------------------------------% :- pred disj_to_byte_list(hlds_goals::in, instmap::in, prog_rep_info::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. + list(int)::out, stack_layout_info::in, stack_layout_info::out) is det. -disj_to_byte_list([], _, _, !StackInfo, []). -disj_to_byte_list([Goal | Goals], InstMap0, Info, !StackInfo, Bytes) :- - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), - disj_to_byte_list(Goals, InstMap0, Info, !StackInfo, GoalsBytes), +disj_to_byte_list([], _, _, [], !StackInfo). +disj_to_byte_list([Goal | Goals], InstMap0, Info, Bytes, !StackInfo) :- + goal_to_byte_list(Goal, InstMap0, Info, GoalBytes, !StackInfo), + disj_to_byte_list(Goals, InstMap0, Info, GoalsBytes, !StackInfo), Bytes = GoalBytes ++ GoalsBytes. %---------------------------------------------------------------------------% :- pred cases_to_byte_list(list(case)::in, instmap::in, prog_rep_info::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. + list(int)::out, stack_layout_info::in, stack_layout_info::out) is det. -cases_to_byte_list([], _, _, !StackInfo, []). -cases_to_byte_list([case(ConsId, Goal) | Cases], InstMap0, Info, !StackInfo, - Bytes) :- - cons_id_to_byte_list(ConsId, !StackInfo, ConsIdBytes), - MaybeArity = cons_id_maybe_arity(ConsId), - ( - MaybeArity = yes(Arity) - ; - MaybeArity = no, - Arity = 0 - ), - short_to_byte_list(Arity, ArityBytes), - goal_to_byte_list(Goal, InstMap0, Info, !StackInfo, GoalBytes), - cases_to_byte_list(Cases, InstMap0, Info, !StackInfo, CasesBytes), - Bytes = ConsIdBytes ++ ArityBytes ++ GoalBytes ++ CasesBytes. +cases_to_byte_list([], _, _, [], !StackInfo). +cases_to_byte_list([Case | Cases], InstMap0, Info, Bytes, !StackInfo) :- + Case = case(MainConsId, OtherConsIds, Goal), + cons_id_and_arity_to_byte_list(MainConsId, MainConsIdBytes, !StackInfo), + list.map_foldl(cons_id_and_arity_to_byte_list, OtherConsIds, + OtherConsIdsByteLists, !StackInfo), + list.condense(OtherConsIdsByteLists, OtherConsIdsBytes), + NumOtherConsIdBytes = length_to_byte_list(OtherConsIds), + goal_to_byte_list(Goal, InstMap0, Info, GoalBytes, !StackInfo), + cases_to_byte_list(Cases, InstMap0, Info, CasesBytes, !StackInfo), + Bytes = MainConsIdBytes ++ NumOtherConsIdBytes ++ OtherConsIdsBytes + ++ GoalBytes ++ CasesBytes. %---------------------------------------------------------------------------% @@ -440,10 +456,10 @@ cases_to_byte_list([case(ConsId, Goal) | Cases], InstMap0, Info, !StackInfo, % but we here use them to represent unsigned quantities. This effectively % halves their range. -:- pred string_to_byte_list(string::in, - stack_layout_info::in, stack_layout_info::out, list(int)::out) is det. +:- pred string_to_byte_list(string::in, list(int)::out, + stack_layout_info::in, stack_layout_info::out) is det. -string_to_byte_list(String, !StackInfo, Bytes) :- +string_to_byte_list(String, Bytes, !StackInfo) :- stack_layout.lookup_string_in_table(String, Index, !StackInfo), int32_to_byte_list(Index, Bytes). diff --git a/compiler/purity.m b/compiler/purity.m index 05a8cdcaf..4e39caefb 100644 --- a/compiler/purity.m +++ b/compiler/purity.m @@ -927,9 +927,11 @@ compute_goals_purity([Goal0 | Goals0], [Goal | Goals], !Purity, !ContainsTrace, purity_info::in, purity_info::out) is det. compute_cases_purity([], [], !Purity, !ContainsTrace, !Info). -compute_cases_purity([case(Ctor, Goal0) | Cases0], [case(Ctor, Goal) | Cases], - !Purity, !ContainsTrace, !Info) :- +compute_cases_purity([Case0 | Cases0], [Case | Cases], !Purity, !ContainsTrace, + !Info) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), compute_goal_purity(Goal0, Goal, GoalPurity, GoalContainsTrace, !Info), + Case = case(MainConsId, OtherConsIds, Goal), !:Purity = worst_purity(GoalPurity, !.Purity), !:ContainsTrace = worst_contains_trace(GoalContainsTrace, !.ContainsTrace), compute_cases_purity(Cases0, Cases, !Purity, !ContainsTrace, !Info). diff --git a/compiler/quantification.m b/compiler/quantification.m index 7c813e862..17bd596a2 100644 --- a/compiler/quantification.m +++ b/compiler/quantification.m @@ -893,9 +893,11 @@ implicitly_quantify_disj([Goal0 | Goals0], [Goal | Goals], !Info, list(set_of_var)::in, list(set_of_var)::out) is det. implicitly_quantify_cases([], [], !Info, !NonLocalVarSets). -implicitly_quantify_cases([case(Cons, Goal0) | Cases0], - [case(Cons, Goal) | Cases], !Info, !NonLocalVarSets) :- +implicitly_quantify_cases([Case0 | Cases0], [Case | Cases], + !Info, !NonLocalVarSets) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), implicitly_quantify_goal_quant_info(Goal0, Goal, !Info), + Case = case(MainConsId, OtherConsIds, Goal), get_nonlocals(!.Info, GoalNonLocalVars), !:NonLocalVarSets = [GoalNonLocalVars | !.NonLocalVarSets], implicitly_quantify_cases(Cases0, Cases, !Info, !NonLocalVarSets). @@ -1043,10 +1045,10 @@ case_vars(NonLocalsToRecompute, Cases, !Set, !LambdaSet) :- compute_case_vars(_, [], !Sets, !LambdaSets). compute_case_vars(NonLocalsToRecompute, [Case | Cases], !Sets, !LambdaSets) :- - Case = case(_Cons, hlds_goal(Goal, _GoalInfo)), + Case = case(_MainConsId, _OtherConsIds, hlds_goal(GoalExpr, _GoalInfo)), EmptySet = init, EmptyLambdaSet = init, - goal_vars_2(NonLocalsToRecompute, Goal, + goal_vars_2(NonLocalsToRecompute, GoalExpr, EmptySet, GoalSet, EmptyLambdaSet, GoalLambdaSet), !:Sets = [GoalSet | !.Sets], !:LambdaSets = [GoalLambdaSet | !.LambdaSets], diff --git a/compiler/rbmm.actual_region_arguments.m b/compiler/rbmm.actual_region_arguments.m index 6831175ba..d42398bd7 100644 --- a/compiler/rbmm.actual_region_arguments.m +++ b/compiler/rbmm.actual_region_arguments.m @@ -200,7 +200,7 @@ record_actual_region_arguments_expr(shorthand(_), _, _, _, _, _, _, _, record_actual_region_arguments_case(ModuleInfo, PPId, RptaInfoTable, ConstantRTable, DeadRTable, BornRTable, Case, !ActualRegionArgProc) :- - Case = case(_, Goal), + Case = case(_, _, Goal), record_actual_region_arguments_goal(ModuleInfo, PPId, RptaInfoTable, ConstantRTable, DeadRTable, BornRTable, Goal, !ActualRegionArgProc). diff --git a/compiler/rbmm.add_rbmm_goal_infos.m b/compiler/rbmm.add_rbmm_goal_infos.m index bd7117db2..f00f61f5e 100644 --- a/compiler/rbmm.add_rbmm_goal_infos.m +++ b/compiler/rbmm.add_rbmm_goal_infos.m @@ -282,7 +282,7 @@ collect_rbmm_goal_info_goal_expr(ModuleInfo, ProcInfo, Graph, ; % The process here is similar to the above code for disjunctions. Cases = [Case | _], - Case = case(_, Goal), + Case = case(_, _, Goal), Goal = hlds_goal(_, CaseInfo), CaseRbmmInfo = goal_info_get_rbmm(CaseInfo), CaseRbmmInfo = rbmm_goal_info(Created, Removed, Carried, _, _), @@ -290,8 +290,8 @@ collect_rbmm_goal_info_goal_expr(ModuleInfo, ProcInfo, Graph, set.init), list.foldl( (pred(C::in, Gs0::in, Gs::out) is det :- - C = case(_, G), - Gs = [G | Gs0] + C = case(_, _, G), + Gs = [G | Gs0] ), Cases, [], Goals), compute_rbmm_info_goals(Goals, SwitchRbmmInfo0, SwitchRbmmInfo), goal_info_set_maybe_rbmm(yes(SwitchRbmmInfo), !Info) @@ -489,11 +489,11 @@ is_create_region_call(plain_call(PredId, _ProcId, Args, _, _, _), collect_rbmm_goal_info_case(ModuleInfo, ProcInfo, Graph, ActualRegionsArgsProc, ResurRenamingProc, IteRenamingProc, NameToRegionVarProc, !Case) :- - !.Case = case(Functor, Goal0), + !.Case = case(MainConsId, OtherConsIds, Goal0), collect_rbmm_goal_info_goal(ModuleInfo, ProcInfo, Graph, ActualRegionsArgsProc, ResurRenamingProc, IteRenamingProc, NameToRegionVarProc, Goal0, Goal), - !:Case = case(Functor, Goal). + !:Case = case(MainConsId, OtherConsIds, Goal). %-----------------------------------------------------------------------------% diff --git a/compiler/rbmm.condition_renaming.m b/compiler/rbmm.condition_renaming.m index 754f51851..10746c64a 100644 --- a/compiler/rbmm.condition_renaming.m +++ b/compiler/rbmm.condition_renaming.m @@ -320,7 +320,7 @@ collect_non_local_and_in_cond_regions_expr(_, _, _, _, _, shorthand(_), collect_non_local_and_in_cond_regions_case(Graph, LRBeforeProc, LRAfterProc, ResurRenamingProc, ResurRenamingAnnoProc, Case, !NonLocalRegionProc, !InCondRegionsProc) :- - Case = case(_, Goal), + Case = case(_, _, Goal), collect_non_local_and_in_cond_regions_goal(Graph, LRBeforeProc, LRAfterProc, ResurRenamingProc, ResurRenamingAnnoProc, Goal, !NonLocalRegionProc, !InCondRegionsProc). @@ -538,7 +538,7 @@ collect_non_local_regions_in_ite_compound_goal(Graph, LRBeforeProc, collect_non_local_regions_in_ite_case(Graph, LRBeforeProc, LRAfterProc, ResurRenamingProc, ResurRenamingAnnoProc, Case, !NonLocalRegionProc) :- - Case = case(_, Goal), + Case = case(_, _, Goal), collect_non_local_regions_in_ite(Graph, LRBeforeProc, LRAfterProc, ResurRenamingProc, ResurRenamingAnnoProc, Goal, !NonLocalRegionProc). @@ -711,7 +711,7 @@ collect_regions_created_in_condition_compound_goal(Graph, collect_regions_created_in_condition_case(Graph, LRBeforeProc, LRAfterProc, ResurRenamingProc, ResurRenamingAnnoProc, Case, !InCondRegionsProc) :- - Case = case(_, Goal), + Case = case(_, _, Goal), collect_regions_created_in_condition(Graph, LRBeforeProc, LRAfterProc, ResurRenamingProc, ResurRenamingAnnoProc, Goal, !InCondRegionsProc). @@ -859,7 +859,7 @@ collect_ite_renaming_expr(Expr, IteRenamedRegionProc, Graph, collect_ite_renaming_case(IteRenamedRegionProc, Graph, Case, !IteRenamingProc) :- - Case = case(_, Goal), + Case = case(_, _, Goal), collect_ite_renaming_goal(IteRenamedRegionProc, Graph, Goal, !IteRenamingProc). @@ -969,7 +969,7 @@ collect_ite_renaming_in_condition_compound_goal(IteRenamedRegionProc, collect_ite_renaming_in_condition_case(IteRenamedRegionProc, Graph, Case, !IteRenamingProc) :- - Case = case(_, Goal), + Case = case(_, _, Goal), collect_ite_renaming_in_condition(IteRenamedRegionProc, Graph, Goal, !IteRenamingProc). diff --git a/compiler/rbmm.execution_path.m b/compiler/rbmm.execution_path.m index 1177ccabf..8804405c7 100644 --- a/compiler/rbmm.execution_path.m +++ b/compiler/rbmm.execution_path.m @@ -211,14 +211,16 @@ execution_paths_covered_disj(ProcInfo, [Disj | Disjs], !ExecPaths) :- execution_paths_covered_cases(_, _, [], _, []). execution_paths_covered_cases(ProcInfo, Switch, [Case | Cases], !ExecPaths) :- - Case = case(ConsId, CaseGoal), + Case = case(MainConsId, OtherConsIds, CaseGoal), + expect(unify(OtherConsIds, []), this_file, + "NYI: execution_paths_covered_cases for multi-cons-id cases"), Switch = hlds_goal(_SwitchExpr, Info), ProgPoint = program_point_init(Info), % Handle the unification on the switch var if it has been removed. % We add a dummy program point for this unification. ( - ConsId = cons(_SymName, Arity), + MainConsId = cons(_SymName, Arity), ( Arity = 0 -> append_to_each_execution_path(!.ExecPaths, [[pair(ProgPoint, Switch)]], ExecPathsBeforeCase) @@ -226,25 +228,25 @@ execution_paths_covered_cases(ProcInfo, Switch, [Case | Cases], !ExecPaths) :- ExecPathsBeforeCase = !.ExecPaths ) ; - ( ConsId = int_const(_Int) - ; ConsId = string_const(_String) - ; ConsId = float_const(_Float) + ( MainConsId = int_const(_Int) + ; MainConsId = string_const(_String) + ; MainConsId = float_const(_Float) ), % need to add a dummy pp append_to_each_execution_path(!.ExecPaths, [[pair(ProgPoint, Switch)]], ExecPathsBeforeCase) ; - ( ConsId = pred_const(_, _) - ; ConsId = type_ctor_info_const(_, _, _) - ; ConsId = base_typeclass_info_const(_, _, _, _) - ; ConsId = type_info_cell_constructor(_) - ; ConsId = typeclass_info_cell_constructor - ; ConsId = tabling_info_const(_) - ; ConsId = deep_profiling_proc_layout(_) - ; ConsId = table_io_decl(_) + ( MainConsId = pred_const(_, _) + ; MainConsId = type_ctor_info_const(_, _, _) + ; MainConsId = base_typeclass_info_const(_, _, _, _) + ; MainConsId = type_info_cell_constructor(_) + ; MainConsId = typeclass_info_cell_constructor + ; MainConsId = tabling_info_const(_) + ; MainConsId = deep_profiling_proc_layout(_) + ; MainConsId = table_io_decl(_) ), - unexpected(this_file, "execution_paths_covered_cases: new cons_id " - ++ "encountered") + unexpected(this_file, + "execution_paths_covered_cases: new cons_id encountered") ), execution_paths_covered_goal(ProcInfo, CaseGoal, ExecPathsBeforeCase, ExecPathsCase), @@ -252,8 +254,8 @@ execution_paths_covered_cases(ProcInfo, Switch, [Case | Cases], !ExecPaths) :- !.ExecPaths, ExecPathsCases), !:ExecPaths = ExecPathsCase ++ ExecPathsCases. - % extend each execution path in the first list with each in the - % second list, all the extended execution paths are put in the third list + % Extend each execution path in the first list with each in the + % second list, all the extended execution paths are put in the third list. % :- pred append_to_each_execution_path(list(execution_path)::in, list(execution_path)::in, list(execution_path)::out) is det. diff --git a/compiler/rbmm.points_to_analysis.m b/compiler/rbmm.points_to_analysis.m index c2a80d27b..b74b2fe76 100644 --- a/compiler/rbmm.points_to_analysis.m +++ b/compiler/rbmm.points_to_analysis.m @@ -173,7 +173,7 @@ intra_analyse_goal_expr(shorthand(_), _, _) :- :- pred intra_analyse_case(case::in, rpta_info::in, rpta_info::out) is det. intra_analyse_case(Case, !RptaInfo) :- - Case = case(_, Goal), + Case = case(_, _, Goal), intra_analyse_goal(Goal, !RptaInfo). %-----------------------------------------------------------------------------% @@ -432,7 +432,7 @@ inter_analyse_goal_expr(switch(_, _, Cases), _, ModuleInfo, InfoTable, rpta_fixpoint_table::out, rpta_info::in, rpta_info::out) is det. inter_analyse_case(ModuleInfo, InfoTable, Case, !FPtable, !RptaInfo) :- - Case = case(_, Goal), + Case = case(_, _, Goal), inter_analyse_goal(ModuleInfo, InfoTable, Goal, !FPtable, !RptaInfo). % Unifications are ignored in interprocedural analysis diff --git a/compiler/rbmm.region_transformation.m b/compiler/rbmm.region_transformation.m index feb4e4743..c0d89132f 100644 --- a/compiler/rbmm.region_transformation.m +++ b/compiler/rbmm.region_transformation.m @@ -628,13 +628,16 @@ annotate_constructions_unification(_, _, _, _, !Unification, !VarSet, region_transform_case(ModuleInfo, Graph, ResurRenamingProc, IteRenamingProc, ActualRegionArgProc, RegionInstructionProc, ResurRenamingAnnoProc, IteRenamingAnnoProc, Switch, - case(ConsId, !.Goal), case(ConsId, !:Goal), + case(MainConsId, OtherConsIds, !.Goal), + case(MainConsId, OtherConsIds, !:Goal), !NameToVar, !VarSet, !VarTypes) :- + expect(unify(OtherConsIds, []), this_file, + "NYI: region_transform_case for multi-cons-id cases"), ( - ( ConsId = cons(_, 0) - ; ConsId = int_const(_) - ; ConsId = string_const(_) - ; ConsId = float_const(_) + ( MainConsId = cons(_, 0) + ; MainConsId = int_const(_) + ; MainConsId = string_const(_) + ; MainConsId = float_const(_) ), Switch = hlds_goal(switch(_, _, _), Info) -> diff --git a/compiler/recompilation.usage.m b/compiler/recompilation.usage.m index c2c38ea7c..c00463dfd 100644 --- a/compiler/recompilation.usage.m +++ b/compiler/recompilation.usage.m @@ -1055,7 +1055,8 @@ 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, _, _, _, _, _, _), !Info) :- +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) :- find_items_used_by_type(Type, !Info). diff --git a/compiler/saved_vars.m b/compiler/saved_vars.m index 20f846d47..788a670df 100644 --- a/compiler/saved_vars.m +++ b/compiler/saved_vars.m @@ -481,9 +481,11 @@ push_into_goals_rename([Goal0 | Goals0], [Goal | Goals], Construct, Var, prog_var::in, slot_info::in, slot_info::out) is det. push_into_cases_rename([], [], _Construct, _Var, !SlotInfo). -push_into_cases_rename([case(ConsId, Goal0) | Cases0], - [case(ConsId, Goal) | Cases], Construct, Var, !SlotInfo) :- +push_into_cases_rename([Case0 | Cases0], [Case | Cases], Construct, Var, + !SlotInfo) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), push_into_goal_rename(Goal0, Goal, Construct, Var, !SlotInfo), + Case = case(MainConsId, OtherConsIds, Goal), push_into_cases_rename(Cases0, Cases, Construct, Var, !SlotInfo). %-----------------------------------------------------------------------------% @@ -505,9 +507,10 @@ saved_vars_in_independent_goals([Goal0 | Goals0], [Goal | Goals], slot_info::in, slot_info::out) is det. saved_vars_in_switch([], [], !SlotInfo). -saved_vars_in_switch([case(Cons, Goal0) | Cases0], - [case(Cons, Goal) | Cases], !SlotInfo) :- +saved_vars_in_switch([Case0 | Cases0], [Case | Cases], !SlotInfo) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), saved_vars_in_goal(Goal0, Goal, !SlotInfo), + Case = case(MainConsId, OtherConsIds, Goal), saved_vars_in_switch(Cases0, Cases, !SlotInfo). %-----------------------------------------------------------------------------% diff --git a/compiler/simplify.m b/compiler/simplify.m index 213f1e000..ffe72301a 100644 --- a/compiler/simplify.m +++ b/compiler/simplify.m @@ -593,9 +593,10 @@ do_process_clause_body_goal(Goal0, Goal, !Info, !IO) :- PredInfo, ProcInfo, ModuleInfo2, ModuleInfo3), simplify_info_set_module_info(ModuleInfo3, !Info), - simplify_info_get_det_info(!.Info, DetInfo), - det_infer_goal(Goal3, Goal, InstMap0, SolnContext, [], no, DetInfo, - _, _, [], _) + simplify_info_get_det_info(!.Info, DetInfo0), + det_infer_goal(Goal3, Goal, InstMap0, SolnContext, [], no, + _, _, DetInfo0, DetInfo, [], _), + simplify_info_set_det_info(DetInfo, !Info) ; Goal = Goal3 ). @@ -1024,13 +1025,14 @@ simplify_goal_2_switch(GoalExpr0, GoalExpr, GoalInfo0, GoalInfo, !Info, !IO) :- Context = goal_info_get_context(GoalInfo0), hlds_goal(GoalExpr, GoalInfo) = fail_goal_with_context(Context) ; - Cases = [case(ConsId, SingleGoal)], + Cases = [case(MainConsId, OtherConsIds, SingleGoal)], % A singleton switch is equivalent to the goal itself with a % possibly can_fail unification with the functor on the front. - Arity = cons_id_arity(ConsId), + MainConsIdArity = cons_id_arity(MainConsId), ( SwitchCanFail = can_fail, - MaybeConsIds \= yes([ConsId]) + OtherConsIds = [], + MaybeConsIds \= yes([MainConsId]) -> % Don't optimize in the case of an existentially typed constructor % because currently create_test_unification does not handle the @@ -1040,7 +1042,7 @@ simplify_goal_2_switch(GoalExpr0, GoalExpr, GoalInfo0, GoalInfo, !Info, !IO) :- simplify_info_get_var_types(!.Info, VarTypes1), map.lookup(VarTypes1, Var, Type), simplify_info_get_module_info(!.Info, ModuleInfo1), - ( type_util.is_existq_cons(ModuleInfo1, Type, ConsId) -> + ( type_util.is_existq_cons(ModuleInfo1, Type, MainConsId) -> GoalExpr = switch(Var, SwitchCanFail, Cases), NonLocals = goal_info_get_nonlocals(GoalInfo0), simplify_info_get_var_types(!.Info, VarTypes), @@ -1049,7 +1051,8 @@ simplify_goal_2_switch(GoalExpr0, GoalExpr, GoalInfo0, GoalInfo, !Info, !IO) :- simplify_info_set_module_info(ModuleInfo2, !Info), goal_info_set_instmap_delta(NewDelta, GoalInfo0, GoalInfo) ; - create_test_unification(Var, ConsId, Arity, UnifyGoal, !Info), + create_test_unification(Var, MainConsId, MainConsIdArity, + UnifyGoal, !Info), % Conjoin the test and the rest of the case. goal_to_conj_list(SingleGoal, SingleGoalConj), @@ -1061,8 +1064,9 @@ simplify_goal_2_switch(GoalExpr0, GoalExpr, GoalInfo0, GoalInfo, !Info, !IO) :- set.insert(NonLocals0, Var, NonLocals), InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0), simplify_info_get_instmap(!.Info, InstMap), - instmap_delta_bind_var_to_functor(Var, Type, ConsId, InstMap, - InstMapDelta0, InstMapDelta, ModuleInfo1, ModuleInfo), + instmap_delta_bind_var_to_functor(Var, Type, MainConsId, + InstMap, InstMapDelta0, InstMapDelta, + ModuleInfo1, ModuleInfo), simplify_info_set_module_info(ModuleInfo, !Info), CaseDetism = goal_info_get_determinism(GoalInfo0), det_conjunction_detism(detism_semi, CaseDetism, Detism), @@ -1101,7 +1105,7 @@ simplify_goal_2_switch(GoalExpr0, GoalExpr, GoalInfo0, GoalInfo, !Info, !IO) :- list.length(Cases, CasesLength), ( CasesLength \= Cases0Length -> % If we pruned some cases, variables used by those cases may no longer - % be non-local to the switch. Also, the determinism may have changed + % be nonlocal to the switch. Also, the determinism may have changed % (especially if we pruned all the cases). If the switch now can't % succeed, it is necessary to recompute instmap_deltas and rerun % determinism analysis to avoid aborts in the code generator because @@ -1616,8 +1620,9 @@ warn_switch_for_ite_cond(ModuleInfo, VarTypes, Cond, !CondCanSwitch) :- can_switch_on_type(TypeBody) = CanSwitchOnType :- ( - TypeBody = hlds_du_type(_Ctors, _TagValues, IsEnumOrDummy, - _UserEq, _ReservedTag, _ReservedAddr, _MaybeForeignType), + TypeBody = hlds_du_type(_Ctors, _TagValues, _CheaperTagTest, + IsEnumOrDummy, _UserEq, _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 % representation, not the logical value. @@ -2997,12 +3002,12 @@ simplify_switch(_, [], RevCases, Cases, !InstMaps, !CanFail, _, !Info, !IO) :- simplify_switch(Var, [Case0 | Cases0], RevCases0, Cases, !InstMaps, !CanFail, Info0, !Info, !IO) :- simplify_info_get_instmap(Info0, InstMap0), - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), simplify_info_get_module_info(!.Info, ModuleInfo0), simplify_info_get_var_types(!.Info, VarTypes), map.lookup(VarTypes, Var, Type), - instmap.bind_var_to_functor(Var, Type, ConsId, InstMap0, InstMap1, - ModuleInfo0, ModuleInfo1), + bind_var_to_functors(Var, Type, MainConsId, OtherConsIds, + InstMap0, InstMap1, ModuleInfo0, ModuleInfo1), simplify_info_set_module_info(ModuleInfo1, !Info), simplify_info_set_instmap(InstMap1, !Info), simplify_goal(Goal0, Goal, !Info, !IO), @@ -3012,7 +3017,7 @@ simplify_switch(Var, [Case0 | Cases0], RevCases0, Cases, !InstMaps, RevCases = RevCases0, !:CanFail = can_fail ; - Case = case(ConsId, Goal), + Case = case(MainConsId, OtherConsIds, Goal), Goal = hlds_goal(_, GoalInfo), % Make sure the switched on variable appears in the instmap delta. @@ -3023,7 +3028,7 @@ simplify_switch(Var, [Case0 | Cases0], RevCases0, Cases, !InstMaps, InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo), simplify_info_get_module_info(!.Info, ModuleInfo2), - instmap_delta_bind_var_to_functor(Var, Type, ConsId, + instmap_delta_bind_var_to_functors(Var, Type, MainConsId, OtherConsIds, InstMap0, InstMapDelta0, InstMapDelta, ModuleInfo2, ModuleInfo), simplify_info_set_module_info(ModuleInfo, !Info), @@ -3340,9 +3345,9 @@ goal_list_contains_trace([Goal0 | Goals0], [Goal | Goals], !ContainsTrace) :- case_list_contains_trace([], [], !ContainsTrace). case_list_contains_trace([Case0 | Cases0], [Case | Cases], !ContainsTrace) :- - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), goal_contains_trace(Goal0, Goal, GoalContainsTrace), - Case = case(ConsId, Goal), + Case = case(MainConsId, OtherConsIds, Goal), !:ContainsTrace = worst_contains_trace(GoalContainsTrace, !.ContainsTrace), case_list_contains_trace(Cases0, Cases, !ContainsTrace). @@ -3561,7 +3566,7 @@ simplify_info_set_instmap(InstMap, Info, Info ^ instmap := InstMap). simplify_info_set_common_info(Common, Info, Info ^ common_info := Common). simplify_info_set_varset(VarSet, Info, Info ^ varset := VarSet). simplify_info_set_var_types(VarTypes, Info, Info ^ det_info := DetInfo) :- - det_info_set_vartypes(Info ^ det_info, VarTypes, DetInfo). + det_info_set_vartypes(VarTypes, Info ^ det_info, DetInfo). simplify_info_set_requantify(Info, Info ^ requantify := yes). simplify_info_set_recompute_atomic(Info, Info ^ recompute_atomic := yes). simplify_info_set_rerun_det(Info, Info ^ rerun_det := yes). @@ -3605,7 +3610,7 @@ simplify_info_inside_lambda(Info) :- simplify_info_set_module_info(ModuleInfo, !Info) :- simplify_info_get_det_info(!.Info, DetInfo0), - det_info_set_module_info(DetInfo0, ModuleInfo, DetInfo), + det_info_set_module_info(ModuleInfo, DetInfo0, DetInfo), simplify_info_set_det_info(DetInfo, !Info). simplify_info_apply_type_substitution(TSubst, !Info) :- diff --git a/compiler/size_prof.m b/compiler/size_prof.m index 958637a8c..7bbd472ea 100644 --- a/compiler/size_prof.m +++ b/compiler/size_prof.m @@ -578,11 +578,11 @@ process_switch(First0, First, Later0, Later, !Info, TargetTypeInfoMap, !:Info = !.Info ^ type_ctor_map := TypeCtorMap0, !:Info = !.Info ^ rev_type_ctor_map := RevTypeCtorMap0, !:Info = !.Info ^ known_size_map := KnownSizeMap0, - First0 = case(FirstConsId, FirstGoal0), + First0 = case(FirstMainConsId, FirstOtherConsIds, FirstGoal0), process_goal(FirstGoal0, FirstGoal, !Info), TypeInfoMapFirst = !.Info ^ type_info_map, KnownSizeMapFirst = !.Info ^ known_size_map, - First = case(FirstConsId, FirstGoal), + First = case(FirstMainConsId, FirstOtherConsIds, FirstGoal), ( Later0 = [Head0 | Tail0], map.union(select_first, TargetTypeInfoMap, diff --git a/compiler/ssdebug.m b/compiler/ssdebug.m index 2ecabc56b..7cc35c0a3 100755 --- a/compiler/ssdebug.m +++ b/compiler/ssdebug.m @@ -812,8 +812,8 @@ make_switch_goal(SwitchVar, DoRetryGoal, DoNotRetryGoal, GoalInfo, SSDBModule = mercury_ssdb_builtin_module, ConsIdDoRetry = cons(qualified(SSDBModule, "do_retry"), 0), ConsIdDoNotRetry = cons(qualified(SSDBModule, "do_not_retry"), 0), - CaseDoRetry = case(ConsIdDoRetry, DoRetryGoal), - CaseDoNotRetry = case(ConsIdDoNotRetry, DoNotRetryGoal), + CaseDoRetry = case(ConsIdDoRetry, [], DoRetryGoal), + CaseDoNotRetry = case(ConsIdDoNotRetry, [], DoNotRetryGoal), SwitchGoal = hlds_goal( switch(SwitchVar, cannot_fail, [CaseDoRetry, CaseDoNotRetry]), GoalInfo). diff --git a/compiler/store_alloc.m b/compiler/store_alloc.m index 6c8a0b577..0062b6d87 100644 --- a/compiler/store_alloc.m +++ b/compiler/store_alloc.m @@ -317,13 +317,14 @@ store_alloc_in_disj([Goal0 | Goals0], [Goal | Goals], Liveness0, Liveness, set(prog_var)::in, store_alloc_info::in) is det. store_alloc_in_cases([], [], !Liveness, _, [], _, _). -store_alloc_in_cases([case(Cons, Goal0) | Goals0], [case(Cons, Goal) | Goals], - Liveness0, Liveness, +store_alloc_in_cases([Case0 | Cases0], [Case | Cases], Liveness0, Liveness, LastLocns0, [LastLocnsGoal | LastLocnsCases], ResumeVars0, StoreAllocInfo) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), store_alloc_in_goal(Goal0, Goal, Liveness0, Liveness, LastLocns0, LastLocnsGoal, ResumeVars0, StoreAllocInfo), - store_alloc_in_cases(Goals0, Goals, Liveness0, _Liveness1, + Case = case(MainConsId, OtherConsIds, Goal), + store_alloc_in_cases(Cases0, Cases, Liveness0, _Liveness1, LastLocns0, LastLocnsCases, ResumeVars0, StoreAllocInfo). %-----------------------------------------------------------------------------% diff --git a/compiler/stratify.m b/compiler/stratify.m index 2daab53d5..42eae9292 100644 --- a/compiler/stratify.m +++ b/compiler/stratify.m @@ -251,7 +251,7 @@ first_order_check_goal_list([hlds_goal(GoalExpr, GoalInfo) | Goals], Negated, first_order_check_case_list([], _, _, _, _, !ModuleInfo, !IO). first_order_check_case_list([Case | Goals], Negated, WholeScc, ThisPredProcId, Error, !ModuleInfo, !IO) :- - Case = case(_ConsId, hlds_goal(GoalExpr, GoalInfo)), + Case = case(_, _, hlds_goal(GoalExpr, GoalInfo)), first_order_check_goal(GoalExpr, GoalInfo, Negated, WholeScc, ThisPredProcId, Error, !ModuleInfo, !IO), first_order_check_case_list(Goals, Negated, WholeScc, ThisPredProcId, @@ -407,7 +407,7 @@ higher_order_check_goal_list([hlds_goal(GoalExpr, GoalInfo) | Goals], Negated, higher_order_check_case_list([], _, _, _, _, _, !ModuleInfo, !IO). higher_order_check_case_list([Case | Goals], Negated, WholeScc, ThisPredProcId, HighOrderLoops, Error, !ModuleInfo, !IO) :- - Case = case(_ConsId, hlds_goal(GoalExpr, GoalInfo)), + Case = case(_, _, hlds_goal(GoalExpr, GoalInfo)), higher_order_check_goal(GoalExpr, GoalInfo, Negated, WholeScc, ThisPredProcId, HighOrderLoops, Error, !ModuleInfo, !IO), higher_order_check_case_list(Goals, Negated, WholeScc, ThisPredProcId, @@ -780,7 +780,7 @@ check_goal_list([hlds_goal(GoalExpr, _) | Goals], !Calls, !HasAT, !CallsHO) :- check_case_list([], !Calls, !HasAT, !CallsHO). check_case_list([Case | Goals], !Calls, !HasAT, !CallsHO) :- - Case = case(_ConsId, hlds_goal(GoalExpr, _)), + Case = case(_, _, hlds_goal(GoalExpr, _)), check_goal1(GoalExpr, !Calls, !HasAT, !CallsHO), check_case_list(Goals, !Calls, !HasAT, !CallsHO). @@ -859,7 +859,7 @@ check_goal_list([hlds_goal(GoalExpr, _) | Goals], !Calls) :- check_case_list([], !Calls). check_case_list([Case | Goals], !Calls) :- - Case = case(_ConsId, hlds_goal(GoalExpr, _)), + Case = case(_, _, hlds_goal(GoalExpr, _)), get_called_procs(GoalExpr, !Calls), check_case_list(Goals, !Calls). diff --git a/compiler/string_switch.m b/compiler/string_switch.m index 2fa12f76f..080f305f7 100644 --- a/compiler/string_switch.m +++ b/compiler/string_switch.m @@ -17,15 +17,16 @@ :- module ll_backend.string_switch. :- interface. -:- import_module backend_libs.switch_util. :- import_module hlds.code_model. :- import_module hlds.hlds_goal. :- import_module ll_backend.code_info. :- import_module ll_backend.llds. :- import_module parse_tree.prog_data. -:- pred generate_string_switch(cases_list::in, prog_var::in, code_model::in, - can_fail::in, hlds_goal_info::in, label::in, +:- import_module list. + +:- pred generate_string_switch(list(tagged_case)::in, rval::in, string::in, + code_model::in, can_fail::in, hlds_goal_info::in, label::in, branch_end::in, branch_end::out, code_tree::out, code_info::in, code_info::out) is det. @@ -35,16 +36,17 @@ :- implementation. :- import_module backend_libs.builtin_ops. +:- import_module backend_libs.switch_util. :- import_module hlds.hlds_data. :- import_module hlds.hlds_goal. :- import_module hlds.hlds_llds. :- import_module libs.compiler_util. :- import_module libs.tree. :- import_module ll_backend.code_gen. +:- import_module ll_backend.switch_case. :- import_module ll_backend.trace_gen. :- import_module int. -:- import_module list. :- import_module map. :- import_module maybe. :- import_module pair. @@ -52,11 +54,22 @@ %-----------------------------------------------------------------------------% -generate_string_switch(Cases, Var, CodeModel, _CanFail, SwitchGoalInfo, - EndLabel, !MaybeEnd, Code, !CI) :- - produce_variable(Var, VarCode, VarRval, !CI), +generate_string_switch(Cases, VarRval, VarName, CodeModel, _CanFail, + SwitchGoalInfo, EndLabel, !MaybeEnd, Code, !CI) :- + % We get the registers we use as working storage in the hash table lookup + % code now, before we generate the code of the switch arms, since the set + % of free registers will in general be different before and after that + % action. However, it is safe to release them immediately, even though + % we haven't yet generated all the code which uses them, because that + % code will *only* be executed before the code for the cases, and because + % that code is generated manually below. Releasing the registers early + % allows the code of the cases to make use of them. + acquire_reg(reg_r, SlotReg, !CI), acquire_reg(reg_r, StringReg, !CI), + release_reg(SlotReg, !CI), + release_reg(StringReg, !CI), + get_next_label(LoopLabel, !CI), get_next_label(FailLabel, !CI), get_next_label(JumpLabel, !CI), @@ -71,144 +84,112 @@ generate_string_switch(Cases, Var, CodeModel, _CanFail, SwitchGoalInfo, TableSize = 2 * RoundedNumCases, HashMask = TableSize - 1, + remember_position(!.CI, BranchStart), + Params = represent_params(VarName, SwitchGoalInfo, CodeModel, BranchStart, + EndLabel), + % Compute the hash table. - switch_util.string_hash_cases(Cases, HashMask, HashValsMap), + map.init(CaseLabelMap0), + switch_util.string_hash_cases(Cases, HashMask, + represent_tagged_case_for_llds(Params), + CaseLabelMap0, CaseLabelMap, !MaybeEnd, !CI, HashValsMap), map.to_assoc_list(HashValsMap, HashValsList), - switch_util.calc_hash_slots(HashValsList, HashValsMap, HashSlotsMap), + switch_util.calc_string_hash_slots(HashValsList, HashValsMap, + HashSlotsMap), - % Note that it is safe to release the registers now, even though we haven't - % yet generated all the code which uses them, because that code will be - % executed before the code for the cases (which might reuse those - % registers), and because that code is generated manually (below) - % so we don't need the reg info to be valid when we generate it. - - release_reg(SlotReg, !CI), - release_reg(StringReg, !CI), - - % Generate the code for when the hash lookup fails. This must be done - % before gen_hash_slots, since we want to use the exprn_info corresponding - % to the start of the switch, not to the end of the last case. + % We must generate the failure code in the context in which none of the + % switch arms have been executed yet. + reset_to_position(BranchStart, !CI), generate_failure(FailCode, !CI), - % Generate the code etc. for the hash table. - gen_hash_slots(0, TableSize, HashSlotsMap, CodeModel, SwitchGoalInfo, - FailLabel, EndLabel, !MaybeEnd, Strings, Labels, NextSlots, - SlotsCode, !CI), + % Generate the data structures for the hash table. + gen_string_hash_slots(0, TableSize, HashSlotsMap, FailLabel, + Strings, NextSlots, Targets), + + % Generate the code for the cases. + map.foldl(add_remaining_case, CaseLabelMap, empty, CasesCode), + EndLabelCode = node([ + llds_instr(label(EndLabel), "end of hashed string switch") + ]), + + % Generate the code for the hash table lookup. + % XXX We should be using one vector cell, not two scalar cells. + add_scalar_static_cell_natural_types(NextSlots, NextSlotsTableAddr, !CI), + add_scalar_static_cell_natural_types(Strings, StringTableAddr, !CI), + NextSlotsTable = const(llconst_data_addr(NextSlotsTableAddr, no)), + StringTable = const(llconst_data_addr(StringTableAddr, no)), + HashLookupCode = node([ + llds_instr(comment("hashed string switch"), ""), + llds_instr(assign(SlotReg, + binop(bitwise_and, unop(hash_string, VarRval), + const(llconst_int(HashMask)))), + "compute the hash value of the input string"), + llds_instr(label(LoopLabel), "begin hash chain loop"), + llds_instr(assign(StringReg, + binop(array_index(elem_type_string), + StringTable, lval(SlotReg))), + "lookup the string for this hash slot"), + llds_instr(if_val(binop(logical_and, lval(StringReg), + binop(str_eq, lval(StringReg), VarRval)), + code_label(JumpLabel)), + "did we find a match?"), + llds_instr(assign(SlotReg, + binop(array_index(elem_type_int), + NextSlotsTable, lval(SlotReg))), + "not yet, so get next slot in hash chain"), + llds_instr( + if_val(binop(int_ge, lval(SlotReg), const(llconst_int(0))), + code_label(LoopLabel)), + "keep searching until we reach the end of the chain"), + llds_instr(label(FailLabel), "no match, so fail") + ]), - % Generate code which does the hash table lookup - ( - add_scalar_static_cell_natural_types(NextSlots, NextSlotsTableAddr, - !CI), - NextSlotsTable = const(llconst_data_addr(NextSlotsTableAddr, no)), - add_scalar_static_cell_natural_types(Strings, StringTableAddr, !CI), - StringTable = const(llconst_data_addr(StringTableAddr, no)), - HashLookupCode = node([ - llds_instr(comment("hashed string switch"), ""), - llds_instr(assign(SlotReg, - binop(bitwise_and, unop(hash_string, VarRval), - const(llconst_int(HashMask)))), - "compute the hash value of the input string"), - llds_instr(label(LoopLabel), "begin hash chain loop"), - llds_instr(assign(StringReg, - binop(array_index(elem_type_string), - StringTable, lval(SlotReg))), - "lookup the string for this hash slot"), - llds_instr(if_val(binop(logical_and, lval(StringReg), - binop(str_eq, lval(StringReg), VarRval)), - code_label(JumpLabel)), - "did we find a match?"), - llds_instr(assign(SlotReg, - binop(array_index(elem_type_int), - NextSlotsTable, lval(SlotReg))), - "not yet, so get next slot in hash chain"), - llds_instr( - if_val(binop(int_ge, lval(SlotReg), const(llconst_int(0))), - code_label(LoopLabel)), - "keep searching until we reach the end of the chain"), - llds_instr(label(FailLabel), "no match, so fail") - ]) - ), JumpCode = node([ llds_instr(label(JumpLabel), "we found a match"), - llds_instr(computed_goto(lval(SlotReg), Labels), + llds_instr(computed_goto(lval(SlotReg), Targets), "jump to the corresponding code") ]), - Code = tree_list([VarCode, HashLookupCode, FailCode, JumpCode, SlotsCode]). + Code = tree_list([HashLookupCode, FailCode, JumpCode, CasesCode, + EndLabelCode]). -:- pred gen_hash_slots(int::in, int::in, - map(int, hash_slot)::in, code_model::in, hlds_goal_info::in, label::in, - label::in, branch_end::in, branch_end::out, - list(rval)::out, list(label)::out, list(rval)::out, code_tree::out, - code_info::in, code_info::out) is det. +:- pred gen_string_hash_slots(int::in, int::in, + map(int, string_hash_slot(label))::in, label::in, + list(rval)::out, list(rval)::out, list(maybe(label))::out) is det. -gen_hash_slots(Slot, TableSize, HashSlotMap, CodeModel, SwitchGoalInfo, - FailLabel, EndLabel, !MaybeEnd, Strings, Labels, NextSlots, - Code, !CI) :- +gen_string_hash_slots(Slot, TableSize, HashSlotMap, FailLabel, + Strings, NextSlots, Targets) :- ( Slot = TableSize -> Strings = [], - Labels = [], NextSlots = [], - Code = node([ - llds_instr(label(EndLabel), "end of hashed string switch") - ]) + Targets = [] ; - gen_hash_slot(Slot, TableSize, HashSlotMap, CodeModel, SwitchGoalInfo, - FailLabel, EndLabel, !MaybeEnd, String, Label, NextSlot, - SlotCode, !CI), - Slot1 = Slot + 1, - gen_hash_slots(Slot1, TableSize, HashSlotMap, CodeModel, - SwitchGoalInfo, FailLabel, EndLabel, !MaybeEnd, Strings0, Labels0, - NextSlots0, Code0, !CI), - Strings = [String | Strings0], - Labels = [Label | Labels0], - NextSlots = [NextSlot | NextSlots0], - Code = tree(SlotCode, Code0) + gen_string_hash_slot(Slot, HashSlotMap, FailLabel, + String, NextSlot, Target), + gen_string_hash_slots(Slot + 1, TableSize, HashSlotMap, FailLabel, + TailStrings, TailNextSlots, TailTargets), + Strings = [String | TailStrings], + NextSlots = [NextSlot | TailNextSlots], + Targets = [Target | TailTargets] ). -:- pred gen_hash_slot(int::in, int::in, map(int, hash_slot)::in, - code_model::in, hlds_goal_info::in, label::in, label::in, - branch_end::in, branch_end::out, rval::out, label::out, rval::out, - code_tree::out, code_info::in, code_info::out) is det. +:- pred gen_string_hash_slot(int::in, map(int, string_hash_slot(label))::in, + label::in, rval::out, rval::out, maybe(label)::out) is det. -gen_hash_slot(Slot, TblSize, HashSlotMap, CodeModel, SwitchGoalInfo, FailLabel, - EndLabel, !MaybeEnd, StringRval, Label, NextSlotRval, Code, !CI) :- - ( map.search(HashSlotMap, Slot, hash_slot(Case, Next)) -> +gen_string_hash_slot(Slot, HashSlotMap, FailLabel, + StringRval, NextSlotRval, Target) :- + ( map.search(HashSlotMap, Slot, SlotInfo) -> + SlotInfo = string_hash_slot(Next, String, CaseLabel), NextSlotRval = const(llconst_int(Next)), - Case = extended_case(_, ConsTag, _, Goal), - ( ConsTag = string_tag(String0) -> - String = String0 - ; - unexpected(this_file, "gen_hash_slots: string expected") - ), StringRval = const(llconst_string(String)), - get_next_label(Label, !CI), - string.append_list(["case """, String, """"], Comment), - LabelCode = node([llds_instr(label(Label), Comment)]), - remember_position(!.CI, BranchStart), - maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, - !CI), - code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), - goal_info_get_store_map(SwitchGoalInfo, StoreMap), - generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), - ( this_is_last_case(Slot, TblSize, HashSlotMap) -> - true - ; - reset_to_position(BranchStart, !CI) - ), - FinishCode = node([ - llds_instr(goto(code_label(EndLabel)), "jump to end of switch") - ]), - Code = tree_list([LabelCode, TraceCode, GoalCode, SaveCode, - FinishCode]) + Target = yes(CaseLabel) ; StringRval = const(llconst_int(0)), - Label = FailLabel, NextSlotRval = const(llconst_int(-2)), - Code = empty + Target = yes(FailLabel) ). -:- pred this_is_last_case(int::in, int::in, map(int, hash_slot)::in) - is semidet. +:- pred this_is_last_case(int::in, int::in, + map(int, string_hash_slot(label))::in) is semidet. this_is_last_case(Slot, TableSize, Table) :- Slot1 = Slot + 1, diff --git a/compiler/structure_reuse.direct.choose_reuse.m b/compiler/structure_reuse.direct.choose_reuse.m index 54a89f2f3..42584966c 100644 --- a/compiler/structure_reuse.direct.choose_reuse.m +++ b/compiler/structure_reuse.direct.choose_reuse.m @@ -1007,7 +1007,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(_) @@ -1139,9 +1139,9 @@ annotate_reuses_in_goal(Background, Match, !Goal) :- :- pred annotate_reuses_in_case(background_info::in, match::in, case::in, case::out) is det. annotate_reuses_in_case(Background, Match, !Case) :- - !.Case = case(A, Goal0), + !.Case = case(MainConsId, OtherConsIds, Goal0), annotate_reuses_in_goal(Background, Match, Goal0, Goal), - !:Case = case(A, Goal). + !:Case = case(MainConsId, OtherConsIds, Goal). :- pred annotate_reuse_for_unification(background_info::in, match::in, unification::in, hlds_goal_info::in, hlds_goal_info::out) is det. @@ -1414,9 +1414,9 @@ check_for_cell_caching_2(DeadCellTable, !Goal):- case::in, case::out) is det. check_for_cell_caching_in_case(DeadCellTable, !Case) :- - !.Case = case(A, Goal0), + !.Case = case(MainConsId, OtherConsIds, Goal0), check_for_cell_caching_2(DeadCellTable, Goal0, Goal), - !:Case = case(A, Goal). + !:Case = case(MainConsId, OtherConsIds, Goal). :- pred check_for_cell_caching_in_unification(dead_cell_table::in, unification::in, unification::out, diff --git a/compiler/structure_reuse.indirect.m b/compiler/structure_reuse.indirect.m index b2fb75785..4eb8e126d 100644 --- a/compiler/structure_reuse.indirect.m +++ b/compiler/structure_reuse.indirect.m @@ -408,13 +408,13 @@ indirect_reuse_analyse_disj(BaseInfo, AnalysisInfo0, Goal0, Goal, AnalysisInfo, indirect_reuse_analyse_case(BaseInfo, AnalysisInfo0, Case0, Case, AnalysisInfo, !FixpointTable, !IO) :- - Case0 = case(ConsId, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), % Replace the state of the fixpoint_table in AnalysisInfo0: NewAnalysisInfo = AnalysisInfo0 ^ fptable := !.FixpointTable, indirect_reuse_analyse_goal(BaseInfo, Goal0, Goal, NewAnalysisInfo, AnalysisInfo, !IO), !:FixpointTable = AnalysisInfo ^ fptable, - Case = case(ConsId, Goal). + Case = case(MainConsId, OtherConsIds, Goal). %-----------------------------------------------------------------------------% diff --git a/compiler/structure_reuse.lbu.m b/compiler/structure_reuse.lbu.m index de48a3dcd..acf27b4e7 100644 --- a/compiler/structure_reuse.lbu.m +++ b/compiler/structure_reuse.lbu.m @@ -203,9 +203,9 @@ backward_use_in_cases(VarTypes, !Cases, !LBU) :- case::out, set(prog_var)::in, set(prog_var)::out) is det. backward_use_in_case(LBU0, VarTypes, !Case, !LBU):- - !.Case = case(Cons, Goal0), + !.Case = case(MainConsId, OtherConsIds, Goal0), backward_use_in_goal(VarTypes, Goal0, Goal, LBU0, NewLBU), - !:Case = case(Cons, Goal), + !:Case = case(MainConsId, OtherConsIds, Goal), set.union(NewLBU, !LBU). :- pred backward_use_in_disj(vartypes::in, list(hlds_goal)::in, diff --git a/compiler/structure_reuse.lfu.m b/compiler/structure_reuse.lfu.m index efc1aad72..c319d1af7 100644 --- a/compiler/structure_reuse.lfu.m +++ b/compiler/structure_reuse.lfu.m @@ -181,9 +181,9 @@ forward_use_in_cases(VarTypes, !Cases, !InstantiatedVars, !DeadVars) :- forward_use_in_case(VarTypes, Inst0, Dead0, !Case, !InstantiatedVars, !DeadVars) :- - !.Case = case(Cons, Goal0), + !.Case = case(MainConsId, OtherConsIds, Goal0), forward_use_in_goal(VarTypes, Goal0, Goal, Inst0, Inst, Dead0, Dead), - !:Case = case(Cons, Goal), + !:Case = case(MainConsId, OtherConsIds, Goal), set.union(Inst, !InstantiatedVars), set.union(Dead, !DeadVars). diff --git a/compiler/structure_reuse.versions.m b/compiler/structure_reuse.versions.m index 403911e1f..1bcfe5329 100644 --- a/compiler/structure_reuse.versions.m +++ b/compiler/structure_reuse.versions.m @@ -313,9 +313,9 @@ determine_reuse_version(ReuseMap, PredId, ProcId, PredName, io::di, io::uo) is det. process_case(ReuseMap, !Case, !IO) :- - !.Case = case(ConsId, Goal0), + !.Case = case(MainConsId, OtherConsIds, Goal0), process_goal(ReuseMap, Goal0, Goal, !IO), - !:Case = case(ConsId, Goal). + !:Case = case(MainConsId, OtherConsIds, Goal). %------------------------------------------------------------------------------% diff --git a/compiler/structure_sharing.analysis.m b/compiler/structure_sharing.analysis.m index ea0e43239..3246eee5a 100644 --- a/compiler/structure_sharing.analysis.m +++ b/compiler/structure_sharing.analysis.m @@ -439,7 +439,7 @@ analyse_disj(ModuleInfo, PredInfo, ProcInfo, SharingTable, SharingBeforeDisj, analyse_case(ModuleInfo, PredInfo, ProcInfo, SharingTable, Sharing0, Case, !FixpointTable, !Sharing, !IO) :- - Case = case(_, Goal), + Case = case(_, _, Goal), analyse_goal(ModuleInfo, PredInfo, ProcInfo, SharingTable, Goal, !FixpointTable, Sharing0, CaseSharing, !IO), !:Sharing = sharing_as_least_upper_bound(ModuleInfo, ProcInfo, !.Sharing, diff --git a/compiler/switch_case.m b/compiler/switch_case.m new file mode 100644 index 000000000..6a08f1121 --- /dev/null +++ b/compiler/switch_case.m @@ -0,0 +1,141 @@ +%-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%-----------------------------------------------------------------------------% +% Copyright (C) 2007 The University of Melbourne. +% This file may only be copied under the terms of the GNU General +% Public License - see the file COPYING in the Mercury distribution. +%-----------------------------------------------------------------------------% +% +% File: switch_case.m. +% Author: zs. +% +% Utility predicates for handling switch cases, especially those representing +% more than one cons_id, for the LLDS backend. +% +%-----------------------------------------------------------------------------% + +:- module ll_backend.switch_case. + +:- interface. + +:- import_module hlds.code_model. +:- import_module hlds.hlds_goal. +:- import_module ll_backend.code_info. +:- import_module ll_backend.llds. + +:- import_module map. + +:- type represent_params + ---> represent_params( + switch_var_name :: string, + switch_goal_info :: hlds_goal_info, + switch_code_model :: code_model, + starting_position :: position_info, + switch_end_label :: label + ). + +:- type case_code_included + ---> case_code_not_yet_included + ; case_code_already_included. + +:- type case_label_info + ---> case_label_info( + case_description :: string, + case_code :: code_tree, + case_code_included :: case_code_included + ). + +:- type case_label_map == map(label, case_label_info). + + % represent_tagged_case_for_llds(Params, TaggedCase, Label, + % !CaseLabelMap, !MaybeEnd, !CI): + % + % Given TaggedCase, generate code for it (using the information in Params, + % and updating MaybeEnd and CI). The code will start with the newly + % allocated label Label. This label will represent the case in + % CaseLabelMap. The corresponding case_label_info will contain a comment + % describing the case in terms of the cons_ids it handles, the generated + % code (starting with the label instruction for Label and ending with + % the jump to the end label of the switch), and an indication that this + % code has not yet been included anywhere. + % +:- pred represent_tagged_case_for_llds(represent_params::in, + tagged_case::in, label::out, case_label_map::in, case_label_map::out, + branch_end::in, branch_end::out, code_info::in, code_info::out) is det. + + % generate_case_code_or_jump(CaseLabel, Code, !CaseLabelMap): + % +:- pred generate_case_code_or_jump(label::in, code_tree::out, + case_label_map::in, case_label_map::out) is det. + +:- pred add_remaining_case(label::in, case_label_info::in, + code_tree::in, code_tree::out) is det. + +%-----------------------------------------------------------------------------% + +:- implementation. + +:- import_module backend_libs.switch_util. +:- import_module hlds.hlds_goal. +:- import_module hlds.hlds_llds. +:- import_module hlds.hlds_out. +:- import_module libs.tree. +:- import_module ll_backend.code_gen. +:- import_module ll_backend.trace_gen. + +:- import_module list. +:- import_module string. +:- import_module svmap. + +represent_tagged_case_for_llds(Params, TaggedCase, Label, !CaseLabelMap, + !MaybeEnd, !CI) :- + Params = represent_params(SwitchVarName, SwitchGoalInfo, CodeModel, + BranchStart, EndLabel), + TaggedCase = tagged_case(MainTaggedConsId, OtherTaggedConsIds, Goal), + project_cons_name_and_tag(MainTaggedConsId, MainConsName, _), + list.map2(project_cons_name_and_tag, OtherTaggedConsIds, + OtherConsNames, _), + Comment = case_comment(SwitchVarName, MainConsName, OtherConsNames), + reset_to_position(BranchStart, !CI), + get_next_label(Label, !CI), + LabelCode = node([llds_instr(label(Label), Comment)]), + maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, !CI), + generate_goal(CodeModel, Goal, GoalCode, !CI), + goal_info_get_store_map(SwitchGoalInfo, StoreMap), + generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), + GotoEndCode = node([ + llds_instr(goto(code_label(EndLabel)), + "goto end of switch on " ++ SwitchVarName) + ]), + Code = tree_list([LabelCode, TraceCode, GoalCode, SaveCode, GotoEndCode]), + CaseInfo = case_label_info(Comment, Code, case_code_not_yet_included), + svmap.det_insert(Label, CaseInfo, !CaseLabelMap). + +generate_case_code_or_jump(CaseLabel, Code, !CaseLabelMap) :- + map.lookup(!.CaseLabelMap, CaseLabel, CaseInfo0), + CaseInfo0 = case_label_info(Comment, CaseCode, CaseIncluded), + ( + CaseIncluded = case_code_not_yet_included, + Code = CaseCode, + CaseInfo = CaseInfo0 ^ case_code_included + := case_code_already_included, + svmap.det_update(CaseLabel, CaseInfo, !CaseLabelMap) + ; + CaseIncluded = case_code_already_included, + % We cannot include the case's code, since it has already been included + % somewhere else. + Code = node([ + llds_instr(goto(code_label(CaseLabel)), "goto " ++ Comment) + ]) + ). + +add_remaining_case(_Label, CaseInfo, !Code) :- + CaseInfo = case_label_info(_Comment, CaseCode, CaseIncluded), + ( + CaseIncluded = case_code_not_yet_included, + !:Code = tree(!.Code, CaseCode) + ; + CaseIncluded = case_code_already_included + ). + +%-----------------------------------------------------------------------------% diff --git a/compiler/switch_detection.m b/compiler/switch_detection.m index d47da4c28..31fa09a59 100644 --- a/compiler/switch_detection.m +++ b/compiler/switch_detection.m @@ -7,7 +7,7 @@ %-----------------------------------------------------------------------------% % % File: switch_detection.m. -% Main author: fjh. +% Main authors: fjh, zs. % % Switch detection - when a disjunction contains disjuncts that unify the % same input variable with different function symbols, replace (part of) @@ -25,7 +25,6 @@ :- import_module parse_tree. :- import_module parse_tree.prog_data. -:- import_module bool. :- import_module io. :- import_module list. @@ -37,6 +36,10 @@ :- pred detect_switches_in_proc(proc_id::in, pred_id::in, module_info::in, module_info::out) is det. +:- type found_deconstruct + ---> did_find_deconstruct + ; did_not_find_deconstruct. + % find_bind_var(Var, ProcessUnify, Goal0, Goal, !Result, !Info, % FoundDeconstruct): % @@ -51,7 +54,7 @@ :- pred find_bind_var(prog_var::in, process_unify(Result, Info)::in(process_unify), hlds_goal::in, hlds_goal::out, Result::in, Result::out, - Info::in, Info::out, bool::out) is det. + Info::in, Info::out, found_deconstruct::out) is det. :- type process_unify(Result, Info) == pred(prog_var, hlds_goal, list(hlds_goal), Result, Result, Info, Info). @@ -72,61 +75,99 @@ :- import_module hlds.quantification. :- import_module libs. :- import_module libs.compiler_util. +:- import_module libs.globals. +:- import_module libs.options. :- import_module parse_tree.prog_data. :- import_module parse_tree.prog_mode. :- import_module assoc_list. +:- import_module bool. +:- import_module cord. :- import_module int. :- import_module map. :- import_module maybe. :- import_module pair. :- import_module set. +:- import_module set_tree234. +:- import_module string. +:- import_module svmap. :- import_module term. :- import_module unit. %-----------------------------------------------------------------------------% +:- type allow_multi_arm + ---> allow_multi_arm + ; dont_allow_multi_arm. + +:- pred lookup_allow_multi_arm(module_info::in, allow_multi_arm::out) is det. + +lookup_allow_multi_arm(ModuleInfo, AllowMulti) :- + module_info_get_globals(ModuleInfo, Globals), + globals.lookup_bool_option(Globals, allow_multi_arm_switches, Allow), + ( + Allow = yes, + AllowMulti = allow_multi_arm + ; + Allow = no, + AllowMulti = dont_allow_multi_arm + ). + detect_switches(!ModuleInfo, !IO) :- % Traverse the module structure, calling `detect_switches_in_goal' % for each procedure body. + lookup_allow_multi_arm(!.ModuleInfo, AllowMulti), module_info_predids(PredIds, !ModuleInfo), - detect_switches_in_preds(PredIds, !ModuleInfo, !IO). + detect_switches_in_preds_allow(PredIds, AllowMulti, !ModuleInfo, !IO). -:- pred detect_switches_in_preds(list(pred_id)::in, +:- pred detect_switches_in_preds_allow(list(pred_id)::in, allow_multi_arm::in, module_info::in, module_info::out, io::di, io::uo) is det. -detect_switches_in_preds([], !ModuleInfo, !IO). -detect_switches_in_preds([PredId | PredIds], !ModuleInfo, !IO) :- +detect_switches_in_preds_allow([], _, !ModuleInfo, !IO). +detect_switches_in_preds_allow([PredId | PredIds], AllowMulti, !ModuleInfo, + !IO) :- module_info_preds(!.ModuleInfo, PredTable), map.lookup(PredTable, PredId, PredInfo), - detect_switches_in_pred(PredId, PredInfo, !ModuleInfo, !IO), - detect_switches_in_preds(PredIds, !ModuleInfo, !IO). + detect_switches_in_pred_allow(PredId, PredInfo, AllowMulti, !ModuleInfo, + !IO), + detect_switches_in_preds_allow(PredIds, AllowMulti, !ModuleInfo, !IO). -:- pred detect_switches_in_pred(pred_id::in, pred_info::in, - module_info::in, module_info::out, io::di, io::uo) is det. +:- pred detect_switches_in_pred_allow(pred_id::in, pred_info::in, + allow_multi_arm::in, module_info::in, module_info::out, + io::di, io::uo) is det. -detect_switches_in_pred(PredId, PredInfo0, !ModuleInfo, !IO) :- +detect_switches_in_pred_allow(PredId, PredInfo0, AllowMulti, !ModuleInfo, + !IO) :- ProcIds = pred_info_non_imported_procids(PredInfo0), ( ProcIds = [_ | _], write_pred_progress_message("% Detecting switches in ", PredId, !.ModuleInfo, !IO), - detect_switches_in_procs(ProcIds, PredId, !ModuleInfo) + detect_switches_in_procs_allow(ProcIds, PredId, AllowMulti, + !ModuleInfo) % This is where we should print statistics, if we ever need % to debug the performance of switch detection. ; ProcIds = [] ). -:- pred detect_switches_in_procs(list(proc_id)::in, pred_id::in, - module_info::in, module_info::out) is det. +:- pred detect_switches_in_procs_allow(list(proc_id)::in, pred_id::in, + allow_multi_arm::in, module_info::in, module_info::out) is det. -detect_switches_in_procs([], _PredId, !ModuleInfo). -detect_switches_in_procs([ProcId | ProcIds], PredId, !ModuleInfo) :- - detect_switches_in_proc(ProcId, PredId, !ModuleInfo), - detect_switches_in_procs(ProcIds, PredId, !ModuleInfo). +detect_switches_in_procs_allow([], _PredId, _AllowMulti, !ModuleInfo). +detect_switches_in_procs_allow([ProcId | ProcIds], PredId, AllowMulti, + !ModuleInfo) :- + detect_switches_in_proc_allow(ProcId, PredId, AllowMulti, !ModuleInfo), + detect_switches_in_procs_allow(ProcIds, PredId, AllowMulti, !ModuleInfo). detect_switches_in_proc(ProcId, PredId, !ModuleInfo) :- + lookup_allow_multi_arm(!.ModuleInfo, AllowMulti), + detect_switches_in_proc_allow(ProcId, PredId, AllowMulti, !ModuleInfo). + +:- pred detect_switches_in_proc_allow(proc_id::in, pred_id::in, + allow_multi_arm::in, module_info::in, module_info::out) is det. + +detect_switches_in_proc_allow(ProcId, PredId, AllowMulti, !ModuleInfo) :- module_info_preds(!.ModuleInfo, PredTable0), map.lookup(PredTable0, PredId, PredInfo0), pred_info_get_procedures(PredInfo0, ProcTable0), @@ -138,15 +179,15 @@ detect_switches_in_proc(ProcId, PredId, !ModuleInfo) :- proc_info_get_goal(ProcInfo0, Goal0), proc_info_get_vartypes(ProcInfo0, VarTypes), proc_info_get_initial_instmap(ProcInfo0, !.ModuleInfo, InstMap0), - detect_switches_in_goal(!.ModuleInfo, VarTypes, InstMap0, Goal0, Goal, - no, Requant), + detect_switches_in_goal(VarTypes, AllowMulti, InstMap0, + Goal0, Goal, !ModuleInfo, dont_need_to_requantify, Requant), proc_info_set_goal(Goal, ProcInfo0, ProcInfo1), ( - Requant = yes, + Requant = need_to_requantify, requantify_proc(ProcInfo1, ProcInfo) ; - Requant = no, + Requant = dont_need_to_requantify, ProcInfo = ProcInfo1 ), map.det_update(ProcTable0, ProcId, ProcInfo, ProcTable), @@ -156,124 +197,296 @@ detect_switches_in_proc(ProcId, PredId, !ModuleInfo) :- %-----------------------------------------------------------------------------% +:- type need_to_requantify + ---> dont_need_to_requantify + ; need_to_requantify. + % Given a goal, and the instmap on entry to that goal, % replace disjunctions with switches whereever possible. % -:- pred detect_switches_in_goal(module_info::in, vartypes::in, - instmap::in, hlds_goal::in, hlds_goal::out, bool::in, bool::out) is det. +:- pred detect_switches_in_goal(vartypes::in, allow_multi_arm::in, instmap::in, + hlds_goal::in, hlds_goal::out, module_info::in, module_info::out, + need_to_requantify::in, need_to_requantify::out) is det. -detect_switches_in_goal(ModuleInfo, VarTypes, InstMap0, !Goal, !Requant) :- - detect_switches_in_goal_1(ModuleInfo, VarTypes, InstMap0, _InstMap, - !Goal, !Requant). +detect_switches_in_goal(VarTypes, AllowMulti, InstMap0, + !Goal, !ModuleInfo, !Requant) :- + detect_switches_in_goal_update_instmap(VarTypes, AllowMulti, + InstMap0, _InstMap, !Goal, !ModuleInfo, !Requant). % This version is the same as the above except that it returns the % resulting instmap on exit from the goal, which is computed by applying % the instmap delta specified in the goal's goalinfo. % -:- pred detect_switches_in_goal_1(module_info::in, vartypes::in, - instmap::in, instmap::out, hlds_goal::in, hlds_goal::out, - bool::in, bool::out) is det. +:- pred detect_switches_in_goal_update_instmap(vartypes::in, + allow_multi_arm::in, instmap::in, instmap::out, + hlds_goal::in, hlds_goal::out, module_info::in, module_info::out, + need_to_requantify::in, need_to_requantify::out) is det. -detect_switches_in_goal_1(ModuleInfo, VarTypes, !InstMap, - Goal0, Goal, !Requant) :- +detect_switches_in_goal_update_instmap(VarTypes, AllowMulti, + !InstMap, Goal0, Goal, !ModuleInfo, !Requant) :- Goal0 = hlds_goal(GoalExpr0, GoalInfo), - detect_switches_in_goal_2(ModuleInfo, VarTypes, !.InstMap, GoalInfo, - GoalExpr0, GoalExpr, !Requant), + detect_switches_in_goal_expr(VarTypes, AllowMulti, !.InstMap, + GoalInfo, GoalExpr0, GoalExpr, !ModuleInfo, !Requant), Goal = hlds_goal(GoalExpr, GoalInfo), update_instmap(Goal0, !InstMap). % Here we process each of the different sorts of goals. % -:- pred detect_switches_in_goal_2(module_info::in, vartypes::in, instmap::in, - hlds_goal_info::in, hlds_goal_expr::in, hlds_goal_expr::out, - bool::in, bool::out) is det. +:- pred detect_switches_in_goal_expr(vartypes::in, allow_multi_arm::in, + instmap::in, hlds_goal_info::in, hlds_goal_expr::in, hlds_goal_expr::out, + module_info::in, module_info::out, + need_to_requantify::in, need_to_requantify::out) is det. -detect_switches_in_goal_2(ModuleInfo, VarTypes, InstMap0, GoalInfo, - Goal0, Goal, !Requant) :- +detect_switches_in_goal_expr(VarTypes, AllowMulti, InstMap0, + GoalInfo, GoalExpr0, GoalExpr, !ModuleInfo, !Requant) :- ( - Goal0 = disj(Goals0), + GoalExpr0 = disj(Disjuncts0), ( - Goals0 = [], - Goal = disj([]) + Disjuncts0 = [], + GoalExpr = disj([]) ; - Goals0 = [_ | _], + Disjuncts0 = [_ | _], NonLocals = goal_info_get_nonlocals(GoalInfo), set.to_sorted_list(NonLocals, NonLocalsList), - detect_switches_in_disj(NonLocalsList, Goals0, GoalInfo, InstMap0, - VarTypes, NonLocalsList, ModuleInfo, [], Goal, !Requant) + detect_switches_in_disj(GoalInfo, NonLocalsList, + VarTypes, AllowMulti, Disjuncts0, NonLocalsList, InstMap0, + [], GoalExpr, !ModuleInfo, !Requant) ) ; - Goal0 = conj(ConjType, Goals0), - detect_switches_in_conj(ModuleInfo, VarTypes, InstMap0, - Goals0, Goals, !Requant), - Goal = conj(ConjType, Goals) + GoalExpr0 = conj(ConjType, Goals0), + detect_switches_in_conj(VarTypes, AllowMulti, InstMap0, + Goals0, Goals, !ModuleInfo, !Requant), + GoalExpr = conj(ConjType, Goals) ; - Goal0 = negation(SubGoal0), - detect_switches_in_goal(ModuleInfo, VarTypes, InstMap0, - SubGoal0, SubGoal, !Requant), - Goal = negation(SubGoal) + GoalExpr0 = negation(SubGoal0), + detect_switches_in_goal(VarTypes, AllowMulti, InstMap0, + SubGoal0, SubGoal, !ModuleInfo, !Requant), + GoalExpr = negation(SubGoal) ; - Goal0 = if_then_else(Vars, Cond0, Then0, Else0), - detect_switches_in_goal_1(ModuleInfo, VarTypes, InstMap0, InstMap1, - Cond0, Cond, !Requant), - detect_switches_in_goal(ModuleInfo, VarTypes, InstMap1, Then0, Then, - !Requant), - detect_switches_in_goal(ModuleInfo, VarTypes, InstMap0, Else0, Else, - !Requant), - Goal = if_then_else(Vars, Cond, Then, Else) + GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0), + detect_switches_in_goal_update_instmap(VarTypes, AllowMulti, + InstMap0, InstMap1, Cond0, Cond, !ModuleInfo, !Requant), + detect_switches_in_goal(VarTypes, AllowMulti, + InstMap1, Then0, Then, !ModuleInfo, !Requant), + detect_switches_in_goal(VarTypes, AllowMulti, + InstMap0, Else0, Else, !ModuleInfo, !Requant), + GoalExpr = if_then_else(Vars, Cond, Then, Else) ; - Goal0 = switch(Var, CanFail, Cases0), - detect_switches_in_cases(ModuleInfo, VarTypes, InstMap0, - Cases0, Cases, !Requant), - Goal = switch(Var, CanFail, Cases) + GoalExpr0 = switch(Var, CanFail, Cases0), + detect_switches_in_cases(Var, VarTypes, AllowMulti, InstMap0, + Cases0, Cases, !ModuleInfo, !Requant), + GoalExpr = switch(Var, CanFail, Cases) ; - Goal0 = scope(Reason, SubGoal0), - detect_switches_in_goal(ModuleInfo, VarTypes, InstMap0, - SubGoal0, SubGoal, !Requant), - Goal = scope(Reason, SubGoal) + GoalExpr0 = scope(Reason, SubGoal0), + detect_switches_in_goal(VarTypes, AllowMulti, InstMap0, + SubGoal0, SubGoal, !ModuleInfo, !Requant), + GoalExpr = scope(Reason, SubGoal) ; - Goal0 = unify(_, RHS0, _, _, _), + GoalExpr0 = unify(_, RHS0, _, _, _), ( RHS0 = rhs_lambda_goal(_, _, _, _, Vars, Modes, _, LambdaGoal0), % We need to insert the initial insts for the lambda variables % in the instmap before processing the lambda goal. - instmap.pre_lambda_update(ModuleInfo, Vars, Modes, + instmap.pre_lambda_update(!.ModuleInfo, Vars, Modes, InstMap0, InstMap1), - detect_switches_in_goal(ModuleInfo, VarTypes, InstMap1, - LambdaGoal0, LambdaGoal, !Requant), + detect_switches_in_goal(VarTypes, AllowMulti, InstMap1, + LambdaGoal0, LambdaGoal, !ModuleInfo, !Requant), RHS = RHS0 ^ rhs_lambda_goal := LambdaGoal, - Goal = Goal0 ^ unify_rhs := RHS + GoalExpr = GoalExpr0 ^ unify_rhs := RHS ; ( RHS0 = rhs_var(_) ; RHS0 = rhs_functor(_, _, _) ), - Goal = Goal0 + GoalExpr = GoalExpr0 ) ; - Goal0 = generic_call(_, _, _, _), - Goal = Goal0 + ( GoalExpr0 = generic_call(_, _, _, _) + ; GoalExpr0 = plain_call(_, _, _, _, _, _) + ; GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _) + ), + GoalExpr = GoalExpr0 ; - Goal0 = plain_call(_, _, _, _, _, _), - Goal = Goal0 - ; - Goal0 = call_foreign_proc(_, _, _, _, _, _, _), - Goal = Goal0 - ; - Goal0 = shorthand(_), + GoalExpr0 = shorthand(_), % These should have been expanded out by now. unexpected(this_file, "detect_switches_in_goal_2: shorthand") ). %-----------------------------------------------------------------------------% -:- type cases == map(cons_id, list(hlds_goal)). +:- type case_arm + ---> single_cons_id_arm(cons_id, hlds_goal) + ; multi_cons_id_arm(cons_id, list(cons_id), hlds_goal). -:- type sorted_case_list == list(case). - % The sorted_case_list should always be sorted on cons_id - - % `delete_unreachable_cases' relies on this. +:- type cons_id_state + ---> cons_id_has_all_singles + ; cons_id_has_one_multi + ; cons_id_has_conflict. + +:- type cons_id_entry + ---> cons_id_entry( + cons_id_state :: cons_id_state, + cons_id_arms :: cord(case_arm) + ). + +:- type cases_table + ---> cases_table( + cases_map :: map(cons_id, cons_id_entry), + conflict_cons_ids :: set_tree234(cons_id) + ). + +:- func convert_cases_table(hlds_goal_info, cases_table) = list(case). + +convert_cases_table(GoalInfo, CasesTable) = SortedCases :- + CasesTable = cases_table(CasesMap, ConflictIds), + map.to_assoc_list(CasesMap, CasesAssocList), + list.foldl2(convert_case(GoalInfo, ConflictIds), CasesAssocList, [], Cases, + set_tree234.init, _AlreadyHandledConsIds), + list.sort(Cases, SortedCases). + +:- pred convert_case(hlds_goal_info::in, set_tree234(cons_id)::in, + pair(cons_id, cons_id_entry)::in, list(case)::in, list(case)::out, + set_tree234(cons_id)::in, set_tree234(cons_id)::out) is det. + +convert_case(GoalInfo, ConflictConsIds, ConsId - Entry, !Cases, + !AlreadyHandledConsIds) :- + ( set_tree234.member(!.AlreadyHandledConsIds, ConsId) -> + Entry = cons_id_entry(State, _ArmCord), + expect(unify(State, cons_id_has_one_multi), this_file, + "convert_case: already handled but not cons_id_has_one_multi") + ; + Entry = cons_id_entry(State, ArmsCord), + Arms = cord.list(ArmsCord), + ( + State = cons_id_has_conflict, + set_tree234.is_member(ConflictConsIds, ConsId, IsMember), + expect(unify(IsMember, yes), this_file, + "convert_case: conflict status but not in ConflictConsIds"), + Disjuncts = list.map(project_arm_goal, Arms), + disj_list_to_goal(Disjuncts, GoalInfo, Goal), + Case = case(ConsId, [], Goal), + !:Cases = [Case | !.Cases] + ; + State = cons_id_has_all_singles, + set_tree234.is_member(ConflictConsIds, ConsId, IsMember), + expect(unify(IsMember, no), this_file, + "convert_case: singles status but in ConflictConsIds"), + Disjuncts = list.map(project_single_arm_goal, Arms), + disj_list_to_goal(Disjuncts, GoalInfo, Goal), + Case = case(ConsId, [], Goal), + !:Cases = [Case | !.Cases] + ; + State = cons_id_has_one_multi, + ( Arms = [multi_cons_id_arm(MainConsId, OtherConsIds0, Goal)] -> + ( ConsId = MainConsId -> + list.filter(set_tree234.contains(ConflictConsIds), + OtherConsIds0, _, OtherConsIds), + Case = case(MainConsId, OtherConsIds, Goal), + set_tree234.insert_list(OtherConsIds, + !AlreadyHandledConsIds), + !:Cases = [Case | !.Cases] + ; + % The code that creates multi_cons_id_arms should ensure + % that [MainConsId | OtherConsIds] is sorted, and + % convert_cases_table should call convert_case for + % ConsIds in the same sorted order. If the first elements + % of the two lists don't match, something has gone wrong. + unexpected(this_file, "convert_case: " ++ + "cons_id_has_one_multi: ConsId != MainConsId") + ) + ; + unexpected(this_file, + "convert_case: misleading cons_id_has_one_multi") + ) + ) + ). + +:- func project_arm_goal(case_arm) = hlds_goal. + +project_arm_goal(single_cons_id_arm(_, Goal)) = Goal. +project_arm_goal(multi_cons_id_arm(_, _, Goal)) = Goal. + +:- func project_single_arm_goal(case_arm) = hlds_goal. + +project_single_arm_goal(single_cons_id_arm(_, Goal)) = Goal. +project_single_arm_goal(multi_cons_id_arm(_, _, _)) = _ :- + unexpected(this_file, "project_single_arm_goal: multi arm"). + +:- func num_cases_in_table(cases_table) = int. + +num_cases_in_table(cases_table(CasesMap, _)) = map.count(CasesMap). + +:- pred add_single_entry(cons_id::in, hlds_goal::in, + cases_table::in, cases_table::out) is det. + +add_single_entry(ConsId, Goal, CasesTable0, CasesTable) :- + CasesTable0 = cases_table(CasesMap0, ConflictConsIds0), + Arm = single_cons_id_arm(ConsId, Goal), + ( map.search(CasesMap0, ConsId, Entry0) -> + Entry0 = cons_id_entry(State0, Arms0), + ( + State0 = cons_id_has_all_singles, + State = cons_id_has_all_singles, + ConflictConsIds = ConflictConsIds0 + ; + State0 = cons_id_has_one_multi, + State = cons_id_has_conflict, + set_tree234.insert(ConsId, ConflictConsIds0, ConflictConsIds) + ; + State0 = cons_id_has_conflict, + State = cons_id_has_conflict, + ConflictConsIds = ConflictConsIds0 + ), + Arms = cord.snoc(Arms0, Arm), + Entry = cons_id_entry(State, Arms), + map.det_update(CasesMap0, ConsId, Entry, CasesMap) + ; + State = cons_id_has_all_singles, + Arms = cord.singleton(Arm), + Entry = cons_id_entry(State, Arms), + map.det_insert(CasesMap0, ConsId, Entry, CasesMap), + ConflictConsIds = ConflictConsIds0 + ), + CasesTable = cases_table(CasesMap, ConflictConsIds). + +:- pred add_multi_entry(cons_id::in, list(cons_id)::in, hlds_goal::in, + cases_table::in, cases_table::out) is det. + +add_multi_entry(MainConsId, OtherConsIds, Goal, CasesTable0, CasesTable) :- + Arm = multi_cons_id_arm(MainConsId, OtherConsIds, Goal), + list.foldl(add_multi_entry_for_cons_id(Arm), [MainConsId | OtherConsIds], + CasesTable0, CasesTable). + +:- pred add_multi_entry_for_cons_id(case_arm::in, cons_id::in, + cases_table::in, cases_table::out) is det. + +add_multi_entry_for_cons_id(Arm, ConsId, CasesTable0, CasesTable) :- + CasesTable0 = cases_table(CasesMap0, ConflictConsIds0), + ( map.search(CasesMap0, ConsId, Entry0) -> + Entry0 = cons_id_entry(State0, Arms0), + ( + ( State0 = cons_id_has_all_singles + ; State0 = cons_id_has_one_multi + ), + set_tree234.insert(ConsId, ConflictConsIds0, ConflictConsIds) + ; + State0 = cons_id_has_conflict, + ConflictConsIds = ConflictConsIds0 + ), + State = cons_id_has_conflict, + Arms = cord.snoc(Arms0, Arm), + Entry = cons_id_entry(State, Arms), + map.det_update(CasesMap0, ConsId, Entry, CasesMap) + ; + State = cons_id_has_one_multi, + Arms = cord.singleton(Arm), + Entry = cons_id_entry(State, Arms), + map.det_insert(CasesMap0, ConsId, Entry, CasesMap), + ConflictConsIds = ConflictConsIds0 + ), + CasesTable = cases_table(CasesMap, ConflictConsIds). :- type again - ---> again(prog_var, list(hlds_goal), sorted_case_list). + ---> again(prog_var, list(hlds_goal), list(case)). % This is the interesting bit - we've found a non-empty disjunction, % and we've got a list of the non-local variables of that disjunction. @@ -281,18 +494,20 @@ detect_switches_in_goal_2(ModuleInfo, VarTypes, InstMap0, GoalInfo, % of the disjuncts such that each group of disjunctions can only succeed % if the variable is bound to a different functor. % -:- pred detect_switches_in_disj(list(prog_var)::in, list(hlds_goal)::in, - hlds_goal_info::in, instmap::in, vartypes::in, - list(prog_var)::in, module_info::in, list(again)::in, - hlds_goal_expr::out, bool::in, bool::out) is det. +:- pred detect_switches_in_disj(hlds_goal_info::in, + list(prog_var)::in, vartypes::in, allow_multi_arm::in, + list(hlds_goal)::in, list(prog_var)::in, instmap::in, list(again)::in, + hlds_goal_expr::out, module_info::in, module_info::out, + need_to_requantify::in, need_to_requantify::out) is det. -detect_switches_in_disj([Var | Vars], Goals0, GoalInfo, InstMap, - VarTypes, AllVars, ModuleInfo, Again0, Goal, !Requant) :- +detect_switches_in_disj(GoalInfo, AllVars, VarTypes, AllowMulti, Disjuncts0, + [Var | Vars], InstMap, AgainList0, GoalExpr, !ModuleInfo, !Requant) :- % Can we do at least a partial switch on this variable? ( instmap.lookup_var(InstMap, Var, VarInst0), - inst_is_bound(ModuleInfo, VarInst0), - partition_disj(Goals0, Var, GoalInfo, Left, CasesList, !Requant) + inst_is_bound(!.ModuleInfo, VarInst0), + partition_disj(AllowMulti, Disjuncts0, Var, GoalInfo, Left, CasesList, + !Requant) -> % A switch needs to have at least two cases. % @@ -305,12 +520,12 @@ detect_switches_in_disj([Var | Vars], Goals0, GoalInfo, InstMap, % Are there any disjuncts that are not part of the switch? No. Left = [], ( CasesList = [_, _ | _] -> - cases_to_switch(CasesList, Var, VarTypes, GoalInfo, InstMap, - ModuleInfo, Goal, !Requant) + cases_to_switch(Var, VarTypes, AllowMulti, + CasesList, InstMap, GoalExpr, !ModuleInfo, !Requant) ; - detect_sub_switches_in_disj(ModuleInfo, VarTypes, InstMap, - Goals0, Goals, !Requant), - Goal = disj(Goals) + detect_sub_switches_in_disj(VarTypes, AllowMulti, + InstMap, Disjuncts0, Disjuncts, !ModuleInfo, !Requant), + GoalExpr = disj(Disjuncts) ) ; % Are there any disjuncts that are not part of the switch? Yes. @@ -318,34 +533,36 @@ detect_switches_in_disj([Var | Vars], Goals0, GoalInfo, InstMap, % Insert this switch into the list of incomplete switches % only if it has at least two cases. ( CasesList = [_, _ | _] -> - Again1 = [again(Var, Left, CasesList) | Again0] + AgainList1 = [again(Var, Left, CasesList) | AgainList0] ; - Again1 = Again0 + AgainList1 = AgainList0 ), % Try to find a switch. - detect_switches_in_disj(Vars, Goals0, GoalInfo, InstMap, VarTypes, - AllVars, ModuleInfo, Again1, Goal, !Requant) + detect_switches_in_disj(GoalInfo, AllVars, VarTypes, + AllowMulti, Disjuncts0, Vars, InstMap, AgainList1, GoalExpr, + !ModuleInfo, !Requant) ) ; - detect_switches_in_disj(Vars, Goals0, GoalInfo, InstMap, - VarTypes, AllVars, ModuleInfo, Again0, Goal, !Requant) + detect_switches_in_disj(GoalInfo, AllVars, VarTypes, + AllowMulti, Disjuncts0, Vars, InstMap, AgainList0, GoalExpr, + !ModuleInfo, !Requant) ). -detect_switches_in_disj([], Goals0, GoalInfo, InstMap, - VarTypes, AllVars, ModuleInfo, AgainList0, disj(Goals), !Requant) :- +detect_switches_in_disj(GoalInfo, AllVars, VarTypes, AllowMulti, Disjuncts0, + [], InstMap, AgainList0, disj(Disjuncts), !ModuleInfo, !Requant) :- ( AgainList0 = [], - detect_sub_switches_in_disj(ModuleInfo, VarTypes, InstMap, - Goals0, Goals, !Requant) + detect_sub_switches_in_disj(VarTypes, AllowMulti, InstMap, + Disjuncts0, Disjuncts, !ModuleInfo, !Requant) ; AgainList0 = [Again | AgainList1], select_best_switch(AgainList1, Again, BestAgain), BestAgain = again(Var, Left0, CasesList), - cases_to_switch(CasesList, Var, VarTypes, GoalInfo, InstMap, - ModuleInfo, SwitchGoal, !Requant), - detect_switches_in_disj(AllVars, Left0, GoalInfo, InstMap, - VarTypes, AllVars, ModuleInfo, [], Left, !Requant), + cases_to_switch(Var, VarTypes, AllowMulti, + CasesList, InstMap, SwitchGoalExpr, !ModuleInfo, !Requant), + detect_switches_in_disj(GoalInfo, AllVars, VarTypes, AllowMulti, + Left0, AllVars, InstMap, [], Left, !ModuleInfo, !Requant), goal_to_disj_list(hlds_goal(Left, GoalInfo), LeftList), - Goals = [hlds_goal(SwitchGoal, GoalInfo) | LeftList] + Disjuncts = [hlds_goal(SwitchGoalExpr, GoalInfo) | LeftList] ). :- pred select_best_switch(list(again)::in, again::in, again::out) is det. @@ -365,47 +582,58 @@ select_best_switch([Again | AgainList], BestAgain0, BestAgain) :- ), select_best_switch(AgainList, BestAgain1, BestAgain). -:- pred detect_sub_switches_in_disj(module_info::in, vartypes::in, instmap::in, - list(hlds_goal)::in, list(hlds_goal)::out, bool::in, bool::out) is det. +:- pred detect_sub_switches_in_disj(vartypes::in, + allow_multi_arm::in, instmap::in, + list(hlds_goal)::in, list(hlds_goal)::out, + module_info::in, module_info::out, + need_to_requantify::in, need_to_requantify::out) is det. -detect_sub_switches_in_disj(_ModuleInfo, _VarTypes, _InstMap, [], [], - !Requant). -detect_sub_switches_in_disj(ModuleInfo, VarTypes, InstMap, - [Goal0 | Goals0], [Goal | Goals], !Requant) :- - detect_switches_in_goal(ModuleInfo, VarTypes, InstMap, Goal0, Goal, - !Requant), - detect_sub_switches_in_disj(ModuleInfo, VarTypes, InstMap, - Goals0, Goals, !Requant). +detect_sub_switches_in_disj(_, _, _, [], [], !ModuleInfo, !Requant). +detect_sub_switches_in_disj(VarTypes, AllowMulti, InstMap, + [Goal0 | Goals0], [Goal | Goals], !ModuleInfo, !Requant) :- + detect_switches_in_goal(VarTypes, AllowMulti, InstMap, + Goal0, Goal, !ModuleInfo, !Requant), + detect_sub_switches_in_disj(VarTypes, AllowMulti, InstMap, + Goals0, Goals, !ModuleInfo, !Requant). -:- pred detect_switches_in_cases(module_info::in, vartypes::in, instmap::in, - list(case)::in, list(case)::out, bool::in, bool::out) is det. +:- pred detect_switches_in_cases(prog_var::in, vartypes::in, + allow_multi_arm::in, instmap::in, list(case)::in, list(case)::out, + module_info::in, module_info::out, + need_to_requantify::in, need_to_requantify::out) is det. -detect_switches_in_cases(_, _, _, [], [], !Requant). -detect_switches_in_cases(ModuleInfo, VarTypes, InstMap, - [Case0 | Cases0], [Case | Cases], !Requant) :- - Case0 = case(Functor, Goal0), - detect_switches_in_goal(ModuleInfo, VarTypes, InstMap, Goal0, Goal, - !Requant), - Case = case(Functor, Goal), - detect_switches_in_cases(ModuleInfo, VarTypes, InstMap, Cases0, Cases, - !Requant). +detect_switches_in_cases(_, _, _, _, [], [], !ModuleInfo, !Requant). +detect_switches_in_cases(Var, VarTypes, AllowMulti, InstMap0, + [Case0 | Cases0], [Case | Cases], !ModuleInfo, !Requant) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), + map.lookup(VarTypes, Var, VarType), + bind_var_to_functors(Var, VarType, MainConsId, OtherConsIds, + InstMap0, InstMap1, !ModuleInfo), + detect_switches_in_goal(VarTypes, AllowMulti, InstMap1, + Goal0, Goal, !ModuleInfo, !Requant), + Case = case(MainConsId, OtherConsIds, Goal), + detect_switches_in_cases(Var, VarTypes, AllowMulti, InstMap0, + Cases0, Cases, !ModuleInfo, !Requant). -:- pred detect_switches_in_conj(module_info::in, vartypes::in, instmap::in, - list(hlds_goal)::in, list(hlds_goal)::out, bool::in, bool::out) is det. +:- pred detect_switches_in_conj(vartypes::in, + allow_multi_arm::in, instmap::in, + list(hlds_goal)::in, list(hlds_goal)::out, + module_info::in, module_info::out, + need_to_requantify::in, need_to_requantify::out) is det. -detect_switches_in_conj(_, _, _, [], [], !Requant). -detect_switches_in_conj(ModuleInfo, VarTypes, InstMap0, - [Goal0 | Goals0], [Goal | Goals], !Requant) :- - detect_switches_in_goal_1(ModuleInfo, VarTypes, InstMap0, InstMap1, - Goal0, Goal, !Requant), - detect_switches_in_conj(ModuleInfo, VarTypes, InstMap1, Goals0, Goals, - !Requant). +detect_switches_in_conj(_, _, _, [], [], !ModuleInfo, !Requant). +detect_switches_in_conj(VarTypes, AllowMulti, InstMap0, + [Goal0 | Goals0], [Goal | Goals], !ModuleInfo, !Requant) :- + detect_switches_in_goal_update_instmap(VarTypes, AllowMulti, + InstMap0, InstMap1, Goal0, Goal, !ModuleInfo, !Requant), + detect_switches_in_conj(VarTypes, AllowMulti, + InstMap1, Goals0, Goals, !ModuleInfo, !Requant). %-----------------------------------------------------------------------------% - % partition_disj(Goals, Var, GoalInfo, VarTypes, ModuleInfo, Left, Cases): + % partition_disj(AllowMulti, Disjuncts, Var, GoalInfo, VarTypes, + % ModuleInfo, Left, Cases): % - % Attempts to partition the disjunction `Goals' into a switch on `Var'. + % Attempts to partition the disjunction `Disjuncts' into a switch on `Var'. % If at least partially successful, returns the resulting `Cases', with % any disjunction goals not fitting into the switch in Left. % @@ -416,95 +644,134 @@ detect_switches_in_conj(ModuleInfo, VarTypes, InstMap0, % unifications at the start of each disjunction, to build up a % substitution. % -:- pred partition_disj(list(hlds_goal)::in, prog_var::in, hlds_goal_info::in, - list(hlds_goal)::out, sorted_case_list::out, bool::in, bool::out) - is semidet. +:- pred partition_disj(allow_multi_arm::in, list(hlds_goal)::in, + prog_var::in, hlds_goal_info::in, list(hlds_goal)::out, list(case)::out, + need_to_requantify::in, need_to_requantify::out) is semidet. -partition_disj(Goals0, Var, GoalInfo, Left, CasesList, !Requant) :- - map.init(Cases0), - partition_disj_trial(Goals0, Var, [], Left1, Cases0, Cases1), - map.to_assoc_list(Cases1, CasesAssocList1), +partition_disj(AllowMulti, Disjuncts0, Var, GoalInfo, Left, Cases, !Requant) :- + CasesTable0 = cases_table(map.init, set_tree234.init), + partition_disj_trial(Disjuncts0, Var, [], Left1, CasesTable0, CasesTable1), ( Left1 = [], - CasesAssocList1 = [_ | _], % There must be at least one case. + % There must be at least one case in CasesTable1. + num_cases_in_table(CasesTable1) >= 1, Left = Left1, - fix_case_list(CasesAssocList1, GoalInfo, CasesList) + Cases = convert_cases_table(GoalInfo, CasesTable1) ; Left1 = [_ | _], - % We don't insist on CasesAssocList1 not being empty, to allow for - % switches in which *all* cases contain subsidiary disjunctions. - ( expand_sub_disjs(Var, Left1, Cases1, Cases) -> + % We don't insist on there being at least one case in CasesTable1, + % to allow for switches in which *all* cases contain subsidiary + % disjunctions. + ( expand_sub_disjs(AllowMulti, Var, Left1, CasesTable1, CasesTable) -> Left = [], - map.to_assoc_list(Cases, CasesAssocList), - CasesAssocList = [_ | _], % There must be at least one case. - fix_case_list(CasesAssocList, GoalInfo, CasesList), - !:Requant = yes + num_cases_in_table(CasesTable) >= 1, + Cases = convert_cases_table(GoalInfo, CasesTable), + !:Requant = need_to_requantify ; Left = Left1, - fix_case_list(CasesAssocList1, GoalInfo, CasesList) + Cases = convert_cases_table(GoalInfo, CasesTable1) ) ). %-----------------------------------------------------------------------------% -:- pred expand_sub_disjs(prog_var::in, list(hlds_goal)::in, - cases::in, cases::out) is semidet. +:- pred expand_sub_disjs(allow_multi_arm::in, prog_var::in, + list(hlds_goal)::in, cases_table::in, cases_table::out) is semidet. -expand_sub_disjs(_Var, [], !Cases). -expand_sub_disjs(Var, [LeftGoal | LeftGoals], !Cases) :- - expand_sub_disj(Var, LeftGoal, !Cases), - expand_sub_disjs(Var, LeftGoals, !Cases). +expand_sub_disjs(_AllowMulti, _Var, [], !CasesTable). +expand_sub_disjs(AllowMulti, Var, [LeftGoal | LeftGoals], !CasesTable) :- + expand_sub_disj(AllowMulti, Var, LeftGoal, !CasesTable), + expand_sub_disjs(AllowMulti, Var, LeftGoals, !CasesTable). -:- pred expand_sub_disj(prog_var::in, hlds_goal::in, cases::in, cases::out) - is semidet. +:- pred expand_sub_disj(allow_multi_arm::in, prog_var::in, hlds_goal::in, + cases_table::in, cases_table::out) is semidet. -expand_sub_disj(Var, Goal, !Cases) :- +expand_sub_disj(AllowMulti, Var, Goal, !CasesTable) :- Goal = hlds_goal(GoalExpr, GoalInfo0), goal_info_add_feature(feature_duplicated_for_switch, GoalInfo0, GoalInfo), ( GoalExpr = conj(plain_conj, SubGoals) -> - expand_sub_disj_process_conj(Var, SubGoals, [], GoalInfo, !Cases) + expand_sub_disj_process_conj(AllowMulti, Var, SubGoals, [], GoalInfo, + !CasesTable) ; GoalExpr = disj(_) -> - expand_sub_disj_process_conj(Var, [Goal], [], GoalInfo, !Cases) + expand_sub_disj_process_conj(AllowMulti, Var, [Goal], [], GoalInfo, + !CasesTable) ; fail ). -:- pred expand_sub_disj_process_conj(prog_var::in, list(hlds_goal)::in, - list(hlds_goal)::in, hlds_goal_info::in, cases::in, cases::out) is semidet. +:- pred expand_sub_disj_process_conj(allow_multi_arm::in, prog_var::in, + list(hlds_goal)::in, list(hlds_goal)::in, hlds_goal_info::in, + cases_table::in, cases_table::out) is semidet. -expand_sub_disj_process_conj(Var, ConjGoals, !.RevUnifies, GoalInfo, - !Cases) :- +expand_sub_disj_process_conj(AllowMulti, Var, ConjGoals, !.RevUnifies, + GoalInfo, !CasesTable) :- ( ConjGoals = [], fail ; - ConjGoals = [FirstGoal | RestGoals], - FirstGoal = hlds_goal(FirstGoalExpr, _), + ConjGoals = [FirstGoal | LaterGoals], + FirstGoal = hlds_goal(FirstGoalExpr, FirstGoalInfo), ( FirstGoalExpr = unify(_, _, _, _, _), !:RevUnifies = [FirstGoal | !.RevUnifies], - expand_sub_disj_process_conj(Var, RestGoals, !.RevUnifies, - GoalInfo, !Cases) + expand_sub_disj_process_conj(AllowMulti, Var, LaterGoals, + !.RevUnifies, GoalInfo, !CasesTable) ; FirstGoalExpr = disj(Disjuncts), Disjuncts = [_ | _], - list.reverse(!.RevUnifies, Unifies), - list.map( - create_expanded_conjunction(Unifies, RestGoals, GoalInfo), - Disjuncts, ExpandedConjunctions), - partition_disj_trial(ExpandedConjunctions, Var, [], Left, !Cases), - Left = [] + ( + AllowMulti = allow_multi_arm, + !.RevUnifies = [], + + % If the unifications pick up the values of variables, + % we would need to include in the switch arm of each cons_id + % not just LaterGoals, but also the disjunct in FirstGoal + % that does this picking up. This disjunct would have to be + % specific to each cons_id, so it could not be shared with + % other cons_ids. + NonLocals = goal_info_get_nonlocals(FirstGoalInfo), + set.delete(NonLocals, Var, OtherNonLocals), + set.empty(OtherNonLocals), + + all_disjuncts_are_switch_var_unifies(Var, Disjuncts, + DisjConsIds), + list.sort(DisjConsIds, SortedDisjConsIds), + SortedDisjConsIds = [MainConsId | OtherConsIds] + -> + SharedGoal = hlds_goal(conj(plain_conj, LaterGoals), GoalInfo), + add_multi_entry(MainConsId, OtherConsIds, SharedGoal, + !CasesTable) + ; + list.reverse(!.RevUnifies, Unifies), + list.map( + create_expanded_conjunction(Unifies, LaterGoals, GoalInfo), + Disjuncts, ExpandedConjunctions), + partition_disj_trial(ExpandedConjunctions, Var, [], Left, + !CasesTable), + Left = [] + ) ) ). +:- pred all_disjuncts_are_switch_var_unifies(prog_var::in, + list(hlds_goal)::in, list(cons_id)::out) is semidet. + +all_disjuncts_are_switch_var_unifies(_Var, [], []). +all_disjuncts_are_switch_var_unifies(Var, [Goal | Goals], + [ConsId | ConsIds]) :- + Goal = hlds_goal(GoalExpr, _GoalInfo), + GoalExpr = unify(_LHS, _RHS, _, UnifyInfo0, _), + UnifyInfo0 = deconstruct(Var, ConsId, _, _, _, _), + all_disjuncts_are_switch_var_unifies(Var, Goals, ConsIds). + :- pred create_expanded_conjunction(list(hlds_goal)::in, list(hlds_goal)::in, hlds_goal_info::in, hlds_goal::in, hlds_goal::out) is det. -create_expanded_conjunction(Unifies, RestGoals, GoalInfo, Disjunct, Goal) :- +create_expanded_conjunction(Unifies, LaterGoals, GoalInfo, Disjunct, Goal) :- ( Disjunct = hlds_goal(conj(plain_conj, DisjunctGoals), _) -> - Conjuncts = Unifies ++ DisjunctGoals ++ RestGoals + Conjuncts = Unifies ++ DisjunctGoals ++ LaterGoals ; - Conjuncts = Unifies ++ [Disjunct] ++ RestGoals + Conjuncts = Unifies ++ [Disjunct] ++ LaterGoals ), Goal = hlds_goal(conj(plain_conj, Conjuncts), GoalInfo). @@ -512,26 +779,20 @@ create_expanded_conjunction(Unifies, RestGoals, GoalInfo, Disjunct, Goal) :- :- pred partition_disj_trial(list(hlds_goal)::in, prog_var::in, list(hlds_goal)::in, list(hlds_goal)::out, - cases::in, cases::out) is det. + cases_table::in, cases_table::out) is det. -partition_disj_trial([], _Var, !Left, !Cases). -partition_disj_trial([Goal0 | Goals], Var, !Left, !Cases) :- - find_bind_var(Var, find_bind_var_for_switch_in_deconstruct, Goal0, Goal, - no, MaybeFunctor, unit, _, _), +partition_disj_trial([], _Var, !Left, !CasesTable). +partition_disj_trial([Disjunct0 | Disjuncts0], Var, !Left, !CasesTable) :- + find_bind_var(Var, find_bind_var_for_switch_in_deconstruct, Disjunct0, + Disjunct, no, MaybeConsId, unit, _, _), ( - MaybeFunctor = yes(Functor), - ( map.search(!.Cases, Functor, DisjList0) -> - DisjList = [Goal | DisjList0], - map.det_update(!.Cases, Functor, DisjList, !:Cases) - ; - DisjList = [Goal], - map.det_insert(!.Cases, Functor, DisjList, !:Cases) - ) + MaybeConsId = yes(ConsId), + add_single_entry(ConsId, Disjunct, !CasesTable) ; - MaybeFunctor = no, - !:Left = [Goal0 | !.Left] + MaybeConsId = no, + !:Left = [Disjunct0 | !.Left] ), - partition_disj_trial(Goals, Var, !Left, !Cases). + partition_disj_trial(Disjuncts0, Var, !Left, !CasesTable). :- pred find_bind_var_for_switch_in_deconstruct(prog_var::in, hlds_goal::in, list(hlds_goal)::out, maybe(cons_id)::in, maybe(cons_id)::out, @@ -575,13 +836,13 @@ find_bind_var(Var, ProcessUnify, !Goal, !Result, !Info, FoundDeconstruct) :- DeconstructSearch), ( DeconstructSearch = before_deconstruct, - FoundDeconstruct = no + FoundDeconstruct = did_not_find_deconstruct ; DeconstructSearch = found_deconstruct, - FoundDeconstruct = yes + FoundDeconstruct = did_find_deconstruct ; DeconstructSearch = given_up_search, - FoundDeconstruct = no + FoundDeconstruct = did_not_find_deconstruct ). :- type deconstruct_search @@ -694,33 +955,36 @@ conj_find_bind_var(Var, ProcessUnify, [Goal0 | Goals0], [Goal | Goals], %-----------------------------------------------------------------------------% -:- pred cases_to_switch(sorted_case_list::in, prog_var::in, vartypes::in, - hlds_goal_info::in, instmap::in, module_info::in, hlds_goal_expr::out, - bool::in, bool::out) is det. +:- pred cases_to_switch(prog_var::in, vartypes::in, allow_multi_arm::in, + list(case)::in, instmap::in, hlds_goal_expr::out, + module_info::in, module_info::out, + need_to_requantify::in, need_to_requantify::out) is det. -cases_to_switch(CasesList, Var, VarTypes, _GoalInfo, InstMap, ModuleInfo, - Goal, !Requant) :- +cases_to_switch(Var, VarTypes, AllowMulti, Cases0, InstMap, GoalExpr, + !ModuleInfo, !Requant) :- instmap.lookup_var(InstMap, Var, VarInst), - ( inst_is_bound_to_functors(ModuleInfo, VarInst, Functors) -> - functors_to_cons_ids(Functors, ConsIds0), - list.sort(ConsIds0, ConsIds), - delete_unreachable_cases(CasesList, ConsIds, CasesList1), - ( list.same_length(Functors, CasesList1) -> - CanFail = cannot_fail - ; - CanFail = can_fail - ) + ( inst_is_bound_to_functors(!.ModuleInfo, VarInst, Functors) -> + functors_to_cons_ids(Functors, ConsIds), + delete_unreachable_cases(Cases0, ConsIds, Cases1), + CanFail = compute_can_fail(ConsIds, Cases1) ; + Cases1 = Cases0, map.lookup(VarTypes, Var, Type), - CasesList1 = CasesList, - ( switch_covers_all_cases(ModuleInfo, Type, CasesList1) -> - CanFail = cannot_fail + ( switch_type_num_functors(!.ModuleInfo, Type, NumFunctors) -> + % We could check for each cons_id of the type whether a case covers + % it, but given that type checking ensures that the set of covered + % cons_ids is a subset of the set of cons_ids of the type, checking + % whether the cardinalities of the two sets match is *equivalent* + % to checking whether they are the same set. + CanFail = switch_covers_n_cases(NumFunctors, Cases1) ; + % switch_type_num_functors fails only for types on which + % you cannot have a complete switch, e.g. integers and strings. CanFail = can_fail ) ), - detect_switches_in_cases(ModuleInfo, VarTypes, InstMap, - CasesList1, Cases, !Requant), + detect_switches_in_cases(Var, VarTypes, AllowMulti, InstMap, + Cases1, Cases, !ModuleInfo, !Requant), % We turn switches with no arms into fail, since this avoids having % the code generator flush the control variable of the switch. @@ -730,36 +994,54 @@ cases_to_switch(CasesList, Var, VarTypes, _GoalInfo, InstMap, ModuleInfo, % nonexistent anyway. ( Cases = [], - Goal = disj([]) + GoalExpr = disj([]) ; Cases = [_ | _], - Goal = switch(Var, CanFail, Cases) + GoalExpr = switch(Var, CanFail, Cases) ). - % Check whether a switch handles all the possible constants/functors - % for the type. +:- func compute_can_fail(list(cons_id), list(case)) = can_fail. + +compute_can_fail(Functors, Cases) = SwitchCanFail :- + UncoveredFunctors0 = set_tree234.list_to_set(Functors), + delete_covered_functors(Cases, UncoveredFunctors0, UncoveredFunctors), + ( set_tree234.empty(UncoveredFunctors) -> + SwitchCanFail = cannot_fail + ; + SwitchCanFail = can_fail + ). + + % Delete from !UncoveredConsIds all cons_ids mentioned in any of the cases. % -:- pred switch_covers_all_cases(module_info::in, mer_type::in, - sorted_case_list::in) is semidet. +:- pred delete_covered_functors(list(case)::in, + set_tree234(cons_id)::in, set_tree234(cons_id)::out) is det. -switch_covers_all_cases(ModuleInfo, Type, CasesList) :- - switch_type_num_functors(ModuleInfo, Type, NumFunctors), - list.length(CasesList, NumCases), - NumCases = NumFunctors. +delete_covered_functors([], !UncoveredConsIds). +delete_covered_functors([Case | Cases], !UncoveredConsIds) :- + Case = case(MainConsId, OtherConsIds, _Goal), + set_tree234.delete(MainConsId, !UncoveredConsIds), + list.foldl(set_tree234.delete, OtherConsIds, !UncoveredConsIds), + delete_covered_functors(Cases, !UncoveredConsIds). - % Convert the assoc_list(cons_id, list(hlds_goal)) back into a plain - % list(case). + % Check whether a switch handles the given number of cons_ids. % -:- pred fix_case_list(assoc_list(cons_id, list(hlds_goal))::in, - hlds_goal_info::in, list(case)::out) is det. +:- func switch_covers_n_cases(int, list(case)) = can_fail. -fix_case_list([], _, []). -fix_case_list([Functor - DisjList0 | Cases0], GoalInfo, - [case(Functor, Goal) | Cases]) :- - % We need to put the list back the right way around. - list.reverse(DisjList0, DisjList), - disj_list_to_goal(DisjList, GoalInfo, Goal), - fix_case_list(Cases0, GoalInfo, Cases). +switch_covers_n_cases(NumFunctors, Cases) = SwitchCanFail :- + NumCoveredConsIds = count_covered_cons_ids(Cases), + ( NumCoveredConsIds = NumFunctors -> + SwitchCanFail = cannot_fail + ; + SwitchCanFail = can_fail + ). + +:- func count_covered_cons_ids(list(case)) = int. + +count_covered_cons_ids([]) = 0. +count_covered_cons_ids([Case | Cases]) = CaseCount + CasesCount :- + Case = case(_MainConsId, OtherConsIds, _Goal), + CaseCount = 1 + list.length(OtherConsIds), + CasesCount = count_covered_cons_ids(Cases). %-----------------------------------------------------------------------------% diff --git a/compiler/switch_gen.m b/compiler/switch_gen.m index 40b9c1184..28740acca 100644 --- a/compiler/switch_gen.m +++ b/compiler/switch_gen.m @@ -69,6 +69,8 @@ :- import_module hlds.hlds_data. :- import_module hlds.hlds_llds. :- import_module hlds.hlds_module. +:- import_module hlds.hlds_out. +:- import_module libs.compiler_util. :- import_module libs.globals. :- import_module libs.options. :- import_module libs.tree. @@ -81,48 +83,56 @@ :- import_module ll_backend.unify_gen. :- import_module parse_tree.prog_type. +:- import_module assoc_list. :- import_module bool. :- import_module int. :- import_module map. :- import_module maybe. :- import_module pair. +:- import_module string. %-----------------------------------------------------------------------------% -generate_switch(CodeModel, CaseVar, CanFail, Cases, GoalInfo, Code, !CI) :- +generate_switch(CodeModel, Var, CanFail, Cases, GoalInfo, Code, !CI) :- % Choose which method to use to generate the switch. % CanFail says whether the switch covers all cases. goal_info_get_store_map(GoalInfo, StoreMap), get_next_label(EndLabel, !CI), - lookup_tags(!.CI, Cases, CaseVar, TaggedCases0), + get_module_info(!.CI, ModuleInfo), + VarType = variable_type(!.CI, Var), + tag_cases(ModuleInfo, VarType, Cases, TaggedCases0, MaybeIntSwitchInfo), list.sort_and_remove_dups(TaggedCases0, TaggedCases), get_globals(!.CI, Globals), globals.lookup_bool_option(Globals, smart_indexing, Indexing), - CaseVarType = variable_type(!.CI, CaseVar), - type_to_ctor_det(CaseVarType, CaseVarTypeCtor), - get_module_info(!.CI, ModuleInfo), - TypeCategory = classify_type(ModuleInfo, CaseVarType), + type_to_ctor_det(VarType, VarTypeCtor), + TypeCategory = classify_type(ModuleInfo, VarType), SwitchCategory = switch_util.type_cat_to_switch_cat(TypeCategory), + + VarName = variable_name(!.CI, Var), + produce_variable(Var, VarCode, VarRval, !CI), ( ( Indexing = no ; module_info_get_type_table(ModuleInfo, TypeTable), % The search will fail for builtin types. - map.search(TypeTable, CaseVarTypeCtor, CaseVarTypeDefn), - hlds_data.get_type_defn_body(CaseVarTypeDefn, CaseVarTypeBody), - CaseVarTypeBody ^ du_type_reserved_addr = uses_reserved_address + map.search(TypeTable, VarTypeCtor, VarTypeDefn), + hlds_data.get_type_defn_body(VarTypeDefn, VarTypeBody), + VarTypeBody ^ du_type_reserved_addr = uses_reserved_address ) -> - order_and_generate_cases(TaggedCases, CaseVar, CodeModel, CanFail, - GoalInfo, EndLabel, no, MaybeEnd, Code, !CI) + order_and_generate_cases(TaggedCases, VarRval, VarType, VarName, + CodeModel, CanFail, GoalInfo, EndLabel, no, MaybeEnd, SwitchCode, + !CI) ; ( SwitchCategory = atomic_switch, list.length(TaggedCases, NumCases), ( + MaybeIntSwitchInfo = + int_switch(LowerLimit, UpperLimit, NumValues), get_maybe_trace_info(!.CI, MaybeTraceInfo), MaybeTraceInfo = no, globals.lookup_int_option(Globals, lookup_switch_size, @@ -130,57 +140,67 @@ generate_switch(CodeModel, CaseVar, CanFail, Cases, GoalInfo, Code, !CI) :- NumCases >= LookupSize, globals.lookup_int_option(Globals, lookup_switch_req_density, ReqDensity), - is_lookup_switch(CaseVar, TaggedCases, GoalInfo, CanFail, - ReqDensity, StoreMap, no, MaybeEndPrime, CodeModel, - LookupSwitchInfo, !CI) + is_lookup_switch(VarType, TaggedCases, LowerLimit, UpperLimit, + NumValues, GoalInfo, CanFail, ReqDensity, StoreMap, + no, MaybeEndPrime, CodeModel, LookupSwitchInfo, !CI) -> MaybeEnd = MaybeEndPrime, - generate_lookup_switch(CaseVar, StoreMap, no, LookupSwitchInfo, - Code, !CI) + generate_lookup_switch(VarRval, StoreMap, no, LookupSwitchInfo, + SwitchCode, !CI) ; + MaybeIntSwitchInfo = + int_switch(LowerLimit, UpperLimit, NumValues), globals.lookup_int_option(Globals, dense_switch_size, DenseSize), NumCases >= DenseSize, globals.lookup_int_option(Globals, dense_switch_req_density, ReqDensity), - cases_list_is_dense_switch(!.CI, CaseVar, TaggedCases, CanFail, - ReqDensity, FirstVal, LastVal, CanFail1) + tagged_case_list_is_dense_switch(!.CI, VarType, TaggedCases, + LowerLimit, UpperLimit, NumValues, ReqDensity, CanFail, + DenseSwitchInfo) -> - generate_dense_switch(TaggedCases, FirstVal, LastVal, CaseVar, - CodeModel, CanFail1, GoalInfo, EndLabel, no, MaybeEnd, - Code, !CI) + generate_dense_switch(TaggedCases, VarRval, VarName, CodeModel, + GoalInfo, DenseSwitchInfo, EndLabel, + no, MaybeEnd, SwitchCode, !CI) ; - order_and_generate_cases(TaggedCases, CaseVar, CodeModel, - CanFail, GoalInfo, EndLabel, no, MaybeEnd, Code, !CI) + order_and_generate_cases(TaggedCases, VarRval, VarType, + VarName, CodeModel, CanFail, GoalInfo, EndLabel, + no, MaybeEnd, SwitchCode, !CI) ) ; SwitchCategory = string_switch, list.length(TaggedCases, NumCases), globals.lookup_int_option(Globals, string_switch_size, StringSize), ( NumCases >= StringSize -> - generate_string_switch(TaggedCases, CaseVar, CodeModel, - CanFail, GoalInfo, EndLabel, no, MaybeEnd, Code, !CI) + generate_string_switch(TaggedCases, VarRval, VarName, + CodeModel, CanFail, GoalInfo, EndLabel, + no, MaybeEnd, SwitchCode, !CI) ; - order_and_generate_cases(TaggedCases, CaseVar, CodeModel, - CanFail, GoalInfo, EndLabel, no, MaybeEnd, Code, !CI) + order_and_generate_cases(TaggedCases, VarRval, VarType, + VarName, CodeModel, CanFail, GoalInfo, EndLabel, + no, MaybeEnd, SwitchCode, !CI) ) ; SwitchCategory = tag_switch, list.length(TaggedCases, NumCases), globals.lookup_int_option(Globals, tag_switch_size, TagSize), ( NumCases >= TagSize -> - generate_tag_switch(TaggedCases, CaseVar, CodeModel, CanFail, - GoalInfo, EndLabel, no, MaybeEnd, Code, !CI) + generate_tag_switch(TaggedCases, VarRval, VarType, VarName, + CodeModel, CanFail, GoalInfo, EndLabel, no, MaybeEnd, + SwitchCode, !CI) ; - order_and_generate_cases(TaggedCases, CaseVar, CodeModel, - CanFail, GoalInfo, EndLabel, no, MaybeEnd, Code, !CI) + order_and_generate_cases(TaggedCases, VarRval, VarType, + VarName, CodeModel, CanFail, GoalInfo, EndLabel, + no, MaybeEnd, SwitchCode, !CI) ) ; SwitchCategory = other_switch, - order_and_generate_cases(TaggedCases, CaseVar, CodeModel, - CanFail, GoalInfo, EndLabel, no, MaybeEnd, Code, !CI) + order_and_generate_cases(TaggedCases, VarRval, VarType, + VarName, CodeModel, CanFail, GoalInfo, EndLabel, + no, MaybeEnd, SwitchCode, !CI) ) ), + Code = tree(VarCode, SwitchCode), after_all_branches(StoreMap, MaybeEnd, !CI). %-----------------------------------------------------------------------------% @@ -190,25 +210,12 @@ generate_switch(CodeModel, CaseVar, CanFail, Cases, GoalInfo, Code, !CI) :- % :- func determine_switch_category(code_info, prog_var) = switch_category. -determine_switch_category(CI, CaseVar) = SwitchCategory :- - Type = variable_type(CI, CaseVar), +determine_switch_category(CI, Var) = SwitchCategory :- + Type = variable_type(CI, Var), get_module_info(CI, ModuleInfo), classify_type(ModuleInfo, Type) = TypeCategory, SwitchCategory = switch_util.type_cat_to_switch_cat(TypeCategory). -%-----------------------------------------------------------------------------% - -:- pred lookup_tags(code_info::in, list(case)::in, prog_var::in, - cases_list::out) is det. - -lookup_tags(_, [], _, []). -lookup_tags(CI, [Case | Cases], Var, [TaggedCase | TaggedCases]) :- - Case = case(ConsId, Goal), - Tag = cons_id_to_tag_for_var(CI, Var, ConsId), - Priority = switch_util.switch_priority(Tag), - TaggedCase = extended_case(Priority, Tag, ConsId, Goal), - lookup_tags(CI, Cases, Var, TaggedCases). - %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% @@ -237,27 +244,33 @@ lookup_tags(CI, [Case | Cases], Var, [TaggedCase | TaggedCases]) :- % and put that one first. This minimizes the number of pipeline % breaks caused by taken branches. % -:- pred order_and_generate_cases(list(extended_case)::in, prog_var::in, - code_model::in, can_fail::in, hlds_goal_info::in, label::in, +:- pred order_and_generate_cases(list(tagged_case)::in, rval::in, mer_type::in, + string::in, code_model::in, can_fail::in, hlds_goal_info::in, label::in, branch_end::in, branch_end::out, code_tree::out, code_info::in, code_info::out) is det. -order_and_generate_cases(Cases0, Var, CodeModel, CanFail, GoalInfo, EndLabel, - !MaybeEnd, Code, !CI) :- - % XXX We should use _VarRval below; we shouldn't produce the variable - % again. - produce_variable(Var, VarCode, _VarRval, !CI), - VarType = variable_type(!.CI, Var), - order_cases(Cases0, Cases, VarType, CodeModel, CanFail, !.CI), - generate_if_then_else_chain_cases(Cases, Var, CodeModel, CanFail, GoalInfo, - EndLabel, !MaybeEnd, CasesCode, !CI), - Code = tree(VarCode, CasesCode). +order_and_generate_cases(TaggedCases, VarRval, VarType, VarName, CodeModel, + CanFail, GoalInfo, EndLabel, !MaybeEnd, Code, !CI) :- + order_cases(TaggedCases, OrderedTaggedCases, VarType, CodeModel, CanFail, + !.CI), + type_to_ctor_det(VarType, TypeCtor), + get_module_info(!.CI, ModuleInfo), + module_info_get_type_table(ModuleInfo, TypeTable), + ( map.search(TypeTable, TypeCtor, TypeDefn) -> + get_type_defn_body(TypeDefn, TypeBody), + CheaperTagTest = get_maybe_cheaper_tag_test(TypeBody) + ; + CheaperTagTest = no_cheaper_tag_test + ), + generate_if_then_else_chain_cases(OrderedTaggedCases, VarRval, VarType, + VarName, CheaperTagTest, CodeModel, CanFail, GoalInfo, EndLabel, + !MaybeEnd, Code, !CI). -:- pred order_cases(list(extended_case)::in, list(extended_case)::out, +:- pred order_cases(list(tagged_case)::in, list(tagged_case)::out, mer_type::in, code_model::in, can_fail::in, code_info::in) is det. order_cases(Cases0, Cases, VarType, CodeModel, CanFail, CI) :- - % We do ordering here based on three out of four considerations. + % We do ordering here based on five considerations. % % - We try to put tests against reserved addresses first, so later cases % can assume those tests have already been done. @@ -266,17 +279,25 @@ order_cases(Cases0, Cases, VarType, CodeModel, CanFail, CI) :- % - If the recursion structure of the predicate is sufficiently simple that % we can make a good guess at which case will be executed more % frequently, we try to put the frequent case first. - % - We try to put cheap-to-execute tests first. + % - We try to put cheap-to-execute tests first; for arms with more than one + % cons_id, we sum the costs of their tests. The main aim of this is to + % reduce the average cost at runtime. For cannot_fail switches, putting + % the most expensive-to-test case last has the additional benefit that + % we don't ever need to execute that test, since the failure of all the + % previous ones guarantees that it could not fail. This should be + % especially useful for switches in which many cons_ids share a single + % arm. % - % order_cases acts on the first consideration. order_cannot_succeed_cases - % acts on the second and indirectly (by calling order_recursive_cases) the - % third. + % Each consideration is implemented by its own predicate, which calls the + % predicate of the next consideration to decide ties. The predicates for + % the four considerations are % - % The fourth consideration has already been acted upon when the switch - % priorities were put into each extended case, and the list of cases sorted - % on that priority. That is why we take care not to upset the existing - % order except when one of the first three considerations dictate a need - % to do so. + % - order_cases, + % - order_cannot_succeed_cases, + % - order_recursive_cases, + % - order_tag_test_cost + % + % respectively. ( search_type_defn(CI, VarType, VarTypeDefn), @@ -285,31 +306,64 @@ order_cases(Cases0, Cases, VarType, CodeModel, CanFail, CI) :- -> separate_reserved_address_cases(Cases0, ReservedAddrCases0, NonReservedAddrCases0), - order_cannot_succeed_cases(ReservedAddrCases0, ReservedAddrCases, + order_can_and_cannot_succeed_cases( + ReservedAddrCases0, ReservedAddrCases, CodeModel, CanFail, CI), - order_cannot_succeed_cases(NonReservedAddrCases0, NonReservedAddrCases, + order_can_and_cannot_succeed_cases( + NonReservedAddrCases0, NonReservedAddrCases, CodeModel, CanFail, CI), Cases = ReservedAddrCases ++ NonReservedAddrCases ; % The type is either not a discriminated union type (e.g. in int or % string), or it is a discriminated union type that does not use % reserved addresses. - order_cannot_succeed_cases(Cases0, Cases, CodeModel, CanFail, CI) + order_can_and_cannot_succeed_cases(Cases0, Cases, + CodeModel, CanFail, CI) ). -:- pred separate_reserved_address_cases(list(extended_case)::in, - list(extended_case)::out, list(extended_case)::out) is det. +%-----------------------------------------------------------------------------% + +:- pred separate_reserved_address_cases(list(tagged_case)::in, + list(tagged_case)::out, list(tagged_case)::out) is det. separate_reserved_address_cases([], [], []). -separate_reserved_address_cases([Case | Cases], +separate_reserved_address_cases([TaggedCase | TaggedCases], ReservedAddrCases, NonReservedAddrCases) :- - separate_reserved_address_cases(Cases, - ReservedAddrCases1, NonReservedAddrCases1), - Case = extended_case(_, ConsTag, _, _), + separate_reserved_address_cases(TaggedCases, + ReservedAddrCasesTail, NonReservedAddrCasesTail), + TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, _), + TaggedConsIds = [TaggedMainConsId | TaggedOtherConsIds], + ContainsReservedAddr = list_contains_reserved_addr_tag(TaggedConsIds), + ( + ContainsReservedAddr = yes, + ReservedAddrCases = [TaggedCase | ReservedAddrCasesTail], + NonReservedAddrCases = NonReservedAddrCasesTail + ; + ContainsReservedAddr = no, + ReservedAddrCases = ReservedAddrCasesTail, + NonReservedAddrCases = [TaggedCase | NonReservedAddrCasesTail] + ). + +:- func list_contains_reserved_addr_tag(list(tagged_cons_id)) = bool. + +list_contains_reserved_addr_tag([]) = no. +list_contains_reserved_addr_tag([TaggedConsId | TaggedConsIds]) = Contains :- + HeadContains = is_reserved_addr_tag(TaggedConsId), + ( + HeadContains = yes, + Contains = yes + ; + HeadContains = no, + Contains = list_contains_reserved_addr_tag(TaggedConsIds) + ). + +:- func is_reserved_addr_tag(tagged_cons_id) = bool. + +is_reserved_addr_tag(TaggedConsId) = IsReservedAddr :- + TaggedConsId = tagged_cons_id(_, ConsTag), ( ConsTag = reserved_address_tag(_), - ReservedAddrCases = [Case | ReservedAddrCases1], - NonReservedAddrCases = NonReservedAddrCases1 + IsReservedAddr = yes ; ( ConsTag = no_tag ; ConsTag = base_typeclass_info_tag(_, _, _) @@ -328,15 +382,16 @@ separate_reserved_address_cases([Case | Cases], ; ConsTag = type_ctor_info_tag(_, _, _) ; ConsTag = unshared_tag(_) ), - ReservedAddrCases = ReservedAddrCases1, - NonReservedAddrCases = [Case | NonReservedAddrCases1] + IsReservedAddr = no ). -:- pred order_cannot_succeed_cases( - list(extended_case)::in, list(extended_case)::out, +%-----------------------------------------------------------------------------% + +:- pred order_can_and_cannot_succeed_cases( + list(tagged_case)::in, list(tagged_case)::out, code_model::in, can_fail::in, code_info::in) is det. -order_cannot_succeed_cases(Cases0, Cases, CodeModel, CanFail, CI) :- +order_can_and_cannot_succeed_cases(Cases0, Cases, CodeModel, CanFail, CI) :- separate_cannot_succeed_cases(Cases0, CanSucceedCases, CannotSucceedCases), ( CannotSucceedCases = [], @@ -347,15 +402,15 @@ order_cannot_succeed_cases(Cases0, Cases, CodeModel, CanFail, CI) :- Cases = CanSucceedCases ++ CannotSucceedCases ). -:- pred separate_cannot_succeed_cases(list(extended_case)::in, - list(extended_case)::out, list(extended_case)::out) is det. +:- pred separate_cannot_succeed_cases(list(tagged_case)::in, + list(tagged_case)::out, list(tagged_case)::out) is det. separate_cannot_succeed_cases([], [], []). separate_cannot_succeed_cases([Case | Cases], CanSucceedCases, CannotSucceedCases) :- separate_cannot_succeed_cases(Cases, CanSucceedCases1, CannotSucceedCases1), - Case = extended_case(_, _, _, Goal), + Case = tagged_case(_, _, Goal), Goal = hlds_goal(_, GoalInfo), Detism = goal_info_get_determinism(GoalInfo), determinism_components(Detism, _CanFail, SolnCount), @@ -372,8 +427,9 @@ separate_cannot_succeed_cases([Case | Cases], CannotSucceedCases = [Case | CannotSucceedCases1] ). -:- pred order_recursive_cases( - list(extended_case)::in, list(extended_case)::out, +%-----------------------------------------------------------------------------% + +:- pred order_recursive_cases(list(tagged_case)::in, list(tagged_case)::out, code_model::in, can_fail::in, code_info::in) is det. order_recursive_cases(Cases0, Cases, CodeModel, CanFail, CI) :- @@ -381,8 +437,8 @@ order_recursive_cases(Cases0, Cases, CodeModel, CanFail, CI) :- CodeModel = model_det, CanFail = cannot_fail, Cases0 = [Case1, Case2], - Case1 = extended_case(_, _, _, Goal1), - Case2 = extended_case(_, _, _, Goal2) + Case1 = tagged_case(_, _, Goal1), + Case2 = tagged_case(_, _, Goal2) -> get_module_info(CI, ModuleInfo), module_info_get_globals(ModuleInfo, Globals), @@ -443,24 +499,46 @@ order_recursive_cases(Cases0, Cases, CodeModel, CanFail, CI) :- Cases = [MultiRecCase, BaseCase] ) ; - Cases = Cases0 + order_tag_test_cost(Cases0, Cases) ) ; - Cases = Cases0 + order_tag_test_cost(Cases0, Cases) ). %-----------------------------------------------------------------------------% -:- pred generate_if_then_else_chain_cases(list(extended_case)::in, - prog_var::in, code_model::in, can_fail::in, hlds_goal_info::in, label::in, +:- pred order_tag_test_cost(list(tagged_case)::in, list(tagged_case)::out) + is det. + +order_tag_test_cost(Cases0, Cases) :- + CostedCases = list.map(estimate_cost_of_case_test, Cases0), + list.sort(CostedCases, SortedCostedCases), + assoc_list.values(SortedCostedCases, Cases). + +:- func estimate_cost_of_case_test(tagged_case) = pair(int, tagged_case). + +estimate_cost_of_case_test(TaggedCase) = Cost - TaggedCase :- + TaggedCase = tagged_case(MainTaggedConsId, OtherTaggedConsIds, _Goal), + MainTag = project_tagged_cons_id_tag(MainTaggedConsId), + MainCost = estimate_switch_tag_test_cost(MainTag), + OtherTags = list.map(project_tagged_cons_id_tag, OtherTaggedConsIds), + OtherCosts = list.map(estimate_switch_tag_test_cost, OtherTags), + Cost = list.foldl(int.plus, [MainCost | OtherCosts], 0). + +%-----------------------------------------------------------------------------% + +:- pred generate_if_then_else_chain_cases(list(tagged_case)::in, + rval::in, mer_type::in, string::in, maybe_cheaper_tag_test::in, + code_model::in, can_fail::in, hlds_goal_info::in, label::in, branch_end::in, branch_end::out, code_tree::out, code_info::in, code_info::out) is det. -generate_if_then_else_chain_cases(Cases, Var, CodeModel, CanFail, - SwitchGoalInfo, EndLabel, !MaybeEnd, Code, !CI) :- +generate_if_then_else_chain_cases(Cases, VarRval, VarType, VarName, + CheaperTagTest, CodeModel, CanFail, SwitchGoalInfo, EndLabel, + !MaybeEnd, Code, !CI) :- ( Cases = [HeadCase | TailCases], - HeadCase = extended_case(_, _, Cons, Goal), + HeadCase = tagged_case(MainTaggedConsId, OtherTaggedConsIds, Goal), remember_position(!.CI, BranchStart), goal_info_get_store_map(SwitchGoalInfo, StoreMap), ( @@ -468,29 +546,38 @@ generate_if_then_else_chain_cases(Cases, Var, CodeModel, CanFail, ; CanFail = can_fail ) -> - unify_gen.generate_tag_test(Var, Cons, branch_on_failure, - NextLabel, TestCode, !CI), - maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, - !CI), - code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), - generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), + generate_raw_tag_test_case(VarRval, VarType, VarName, + MainTaggedConsId, OtherTaggedConsIds, CheaperTagTest, + branch_on_failure, NextLabel, TestCode, !CI), ElseCode = node([ llds_instr(goto(code_label(EndLabel)), - "skip to the end of the switch"), + "skip to the end of the switch on " ++ VarName), llds_instr(label(NextLabel), "next case") - ]), - HeadCaseCode = tree_list([TestCode, TraceCode, GoalCode, SaveCode, - ElseCode]) + ]) ; - maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, - !CI), - code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), - generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), - HeadCaseCode = tree_list([TraceCode, GoalCode, SaveCode]) + % When debugging code generator output, need a way to tell which + % case's code is next. We normally hang this comment on the test, + % but in this case there is no test. + project_cons_name_and_tag(MainTaggedConsId, MainConsName, _), + list.map2(project_cons_name_and_tag, OtherTaggedConsIds, + OtherConsNames, _), + Comment = case_comment(VarName, MainConsName, OtherConsNames), + TestCode = node([ + llds_instr(comment(Comment), "") + ]), + ElseCode = empty ), + + maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, + !CI), + generate_goal(CodeModel, Goal, GoalCode, !CI), + generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), + HeadCaseCode = tree_list([TestCode, TraceCode, GoalCode, SaveCode, + ElseCode]), reset_to_position(BranchStart, !CI), - generate_if_then_else_chain_cases(TailCases, Var, CodeModel, CanFail, - SwitchGoalInfo, EndLabel, !MaybeEnd, TailCasesCode, !CI), + generate_if_then_else_chain_cases(TailCases, VarRval, VarType, VarName, + CheaperTagTest, CodeModel, CanFail, SwitchGoalInfo, EndLabel, + !MaybeEnd, TailCasesCode, !CI), Code = tree(HeadCaseCode, TailCasesCode) ; Cases = [], @@ -504,8 +591,15 @@ generate_if_then_else_chain_cases(Cases, Var, CodeModel, CanFail, CanFail = cannot_fail, FailCode = empty ), - EndCode = node([llds_instr(label(EndLabel), "end of switch")]), + EndCode = node([llds_instr(label(EndLabel), + "end of the switch on " ++ VarName)]), Code = tree(FailCode, EndCode) ). %-----------------------------------------------------------------------------% + +:- func this_file = string. + +this_file = "switch_gen.m". + +%-----------------------------------------------------------------------------% diff --git a/compiler/switch_util.m b/compiler/switch_util.m index 0e93b00d9..6af4a6a23 100644 --- a/compiler/switch_util.m +++ b/compiler/switch_util.m @@ -5,13 +5,13 @@ % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% -% +% % File: switch_util.m. -% Author: fjh. -% +% Authors: fjh, zs. +% % This module defines stuff for generating switches that is shared % between the MLDS and LLDS back-ends. -% +% %-----------------------------------------------------------------------------% :- module backend_libs.switch_util. @@ -30,18 +30,39 @@ :- import_module list. :- import_module map. :- import_module pair. +:- import_module unit. %-----------------------------------------------------------------------------% % -% Stuff for categorizing switches +% General stuff, for adding tags to cons_ids in switches and for representing +% switch arms. % -% An extended_case is an HLDS case annotated with some additional info. -% The first (int) field is the priority, as computed by switch_priority/2. +:- type maybe_int_switch_info + ---> int_switch( + lower_limit :: int, + upper_limit :: int, + num_values :: int + ) + ; not_int_switch. -:- type extended_case - ---> extended_case(int, cons_tag, cons_id, hlds_goal). -:- type cases_list == list(extended_case). + % tag_cases(ModuleInfo, Type, Cases, TaggedCases, MaybeIntSwitchInfo): + % + % Given a switch on a variable of type Type, tag each case in Cases + % with the tags corresponding to its cons_ids. If all tags are integers, + % return the lower and upper limits on these integers, as well as a count + % of how many of them there are. + % +:- pred tag_cases(module_info::in, mer_type::in, list(case)::in, + list(tagged_case)::out, maybe_int_switch_info::out) is det. + +:- pred represent_tagged_case_by_itself(tagged_case::in, tagged_case::out, + unit::in, unit::out, unit::in, unit::out, unit::in, unit::out) is det. + +%-----------------------------------------------------------------------------% +% +% Stuff for categorizing switches. +% :- type switch_category ---> atomic_switch % a switch on int/char/enum @@ -53,21 +74,27 @@ % :- func type_cat_to_switch_cat(type_category) = switch_category. - % Return the priority of a constructor test. - % A low number here indicates a high priority. - % We prioritize the tag tests so that the cheapest - % (most efficient) ones come first. + % Return an estimate of the runtime cost of a constructor test for the + % given tag. We try to put the cheap tests first. % -:- func switch_priority(cons_tag) = int. + % Abort on cons_tags that should never be switched on. + % +:- func estimate_switch_tag_test_cost(cons_tag) = int. - % type_range(TypeCategory, Type, ModuleInfo, Min, Max): +%-----------------------------------------------------------------------------% +% +% Stuff for dense switches. +% + + % type_range(ModuleInfo, TypeCategory, Type, Min, Max, NumValues): % - % Determine the range [Min..Max] of an atomic type. + % Determine the range [Min..Max] of an atomic type, and the number of + % values in that range (including both endpoints). % Fail if the type isn't the sort of type that has a range % or if the type's range is too big to switch on (e.g. int). % -:- pred type_range(type_category::in, mer_type::in, module_info::in, - int::out, int::out) is semidet. +:- pred type_range(module_info::in, type_category::in, mer_type::in, + int::out, int::out, int::out) is semidet. % Calculate the percentage density given the range and the number of cases. % @@ -75,19 +102,22 @@ %-----------------------------------------------------------------------------% % -% Stuff for string hash switches +% Stuff for string hash switches. % % For a string switch, compute the hash value for each case in the list % of cases, and store the cases in a map from hash values to cases. % -:- pred string_hash_cases(cases_list::in, int::in, map(int, cases_list)::out) - is det. +:- pred string_hash_cases(list(tagged_case)::in, int::in, + pred(tagged_case, CaseRep, StateA, StateA, StateB, StateB, StateC, StateC) + ::in(pred(in, out, in, out, in, out, in, out) is det), + StateA::in, StateA::out, StateB::in, StateB::out, StateC::in, StateC::out, + map(int, assoc_list(string, CaseRep))::out) is det. -:- type hash_slot - ---> hash_slot(extended_case, int). +:- type string_hash_slot(CaseRep) + ---> string_hash_slot(int, string, CaseRep). - % calc_hash_slots(AssocList, HashMap, Map): + % calc_string_hash_slots(AssocList, HashMap, Map): % % For each (HashVal - Case) pair in AssocList, allocate a hash slot in Map % for the case. If the hash slot corresponding to HashVal is not already @@ -96,55 +126,77 @@ % hash value for one of the other cases), and use it instead. % Keep track of the hash chains as we do this. % -:- pred calc_hash_slots(assoc_list(int, cases_list)::in, - map(int, cases_list)::in, map(int, hash_slot)::out) is det. + % XXX +:- pred calc_string_hash_slots( + assoc_list(int, assoc_list(string, CaseRep))::in, + map(int, assoc_list(string, CaseRep))::in, + map(int, string_hash_slot(CaseRep))::out) is det. %-----------------------------------------------------------------------------% % -% Stuff for tag switches +% Stuff for tag switches. % -% Map secondary tag values (-1 stands for none) to their goal. -:- type stag_goal ---> stag_goal(cons_id, hlds_goal). -:- type stag_goal_map == map(int, stag_goal). -:- type stag_goal_list == assoc_list(int, stag_goal). +% Map secondary tag values (-1 stands for none) to information about their +% switch arm. This "information about the switch arm" is polymorphic, because +% in the presence of switch arms that correspond to more than one cons_id, +% cons_ids whose tags may not all use the same primary tag, we will need to +% duplicate this information, with at least one copy per primary tag. +% +% In the LLDS backend, we can (and do) give a label to each goal. The +% predicates in this module will duplicate only the label, and our caller +% has the responsibility of ensuring that each label/goal pair is defined +% only once. +% +% With the MLDS, we don't (yet) do this, because some MLDS backends (e.g. Java) +% don't support labels. Instead, if need be we duplicate the HLDS goal, which +% means we will generate MLDS code for it more than once. -% Map primary tag values to the set of their goals. -:- type ptag_case ---> ptag_case(sectag_locn, stag_goal_map). -:- type ptag_case_map == map(tag_bits, ptag_case). -:- type ptag_case_list == assoc_list(tag_bits, ptag_case). +:- type stag_goal_map(CaseRep) == map(int, CaseRep). +:- type stag_goal_list(CaseRep) == assoc_list(int, CaseRep). + +% Map primary tag values to the set of their switch arms. + +:- type ptag_case(CaseRep) + ---> ptag_case(sectag_locn, stag_goal_map(CaseRep)). +:- type ptag_case_map(CaseRep) == map(tag_bits, ptag_case(CaseRep)). +:- type ptag_case_list(CaseRep) == assoc_list(tag_bits, ptag_case(CaseRep)). % Map primary tag values to the number of constructors sharing them. + :- type ptag_count_map == map(tag_bits, pair(sectag_locn, int)). :- type ptag_count_list == assoc_list(tag_bits, pair(sectag_locn, int)). % Group together all the cases that depend on the given variable % having the same primary tag value. % -:- pred group_cases_by_ptag(cases_list::in, ptag_case_map::in, - ptag_case_map::out) is det. + % XXX +:- pred group_cases_by_ptag(list(tagged_case)::in, + pred(tagged_case, CaseRep, StateA, StateA, StateB, StateB, StateC, StateC) + ::in(pred(in, out, in, out, in, out, in, out) is det), + StateA::in, StateA::out, StateB::in, StateB::out, StateC::in, StateC::out, + ptag_case_map(CaseRep)::in, ptag_case_map(CaseRep)::out) is det. - % Order the primary tags based on the number of secondary tags - % associated with them, putting the ones with the most secondary tags - % first. + % Order the primary tags based on the number of secondary tags associated + % with them, putting the ones with the most secondary tags first. % % Note that it is not an error for a primary tag to have no case list; % this can happen in semidet switches, or in det switches where the % initial inst of the switch variable is a bound(...) inst representing % a subtype. % -:- pred order_ptags_by_count(ptag_count_list::in, ptag_case_map::in, - ptag_case_list::out) is det. +:- pred order_ptags_by_count(ptag_count_list::in, + ptag_case_map(CaseRep)::in, ptag_case_list(CaseRep)::out) is det. - % order_ptags_by_value(FirstPtag, MaxPtag, PtagCaseMap0, PtagCaseList): + % order_ptags_by_value(FirstPtag, MaxPtag, !PtagCaseList): % % Order the primary tags based on their value, lowest value first. % We scan through the primary tags values from zero to maximum. % Note that it is not an error for a primary tag to have no case list, - % since this can happen in semidet switches. + % for the reason documented in the comment above for order_ptags_by_count. % -:- pred order_ptags_by_value(int::in, int::in, ptag_case_map::in, - ptag_case_list::out) is det. +:- pred order_ptags_by_value(int::in, int::in, + ptag_case_map(CaseRep)::in, ptag_case_list(CaseRep)::out) is det. % Find out how many secondary tags share each primary tag % of the given variable. @@ -156,99 +208,122 @@ :- implementation. +:- import_module hlds.hlds_code_util. +:- import_module hlds.hlds_out. :- import_module libs. :- import_module libs.compiler_util. :- import_module parse_tree.prog_type. :- import_module char. +:- import_module cord. :- import_module int. :- import_module string. :- import_module svmap. %-----------------------------------------------------------------------------% +% +% General stuff, for adding tags to cons_ids in switches and for representing +% switch arms. +% -string_hash_cases([], _, Map) :- - map.init(Map). -string_hash_cases([Case | Cases], HashMask, Map) :- - string_hash_cases(Cases, HashMask, Map0), - ( Case = extended_case(_, string_tag(String0), _, _) -> - String = String0 +:- type is_int_switch + ---> is_int_switch + ; is_not_int_switch. + +tag_cases(_ModuleInfo, _SwitchType, [], [], _) :- + unexpected(this_file, "tag_cases: no cases"). +tag_cases(ModuleInfo, SwitchVarType, [Case | Cases], + [TaggedCase | TaggedCases], MaybeIntSwitchLimits) :- + Case = case(MainConsId, OtherConsIds, Goal), + MainConsTag = cons_id_to_tag(ModuleInfo, SwitchVarType, MainConsId), + TaggedMainConsId = tagged_cons_id(MainConsId, MainConsTag), + ( MainConsTag = int_tag(IntTag) -> + list.map_foldl4(tag_cons_id_in_int_switch(ModuleInfo, SwitchVarType), + OtherConsIds, TaggedOtherConsIds, + IntTag, LowerLimit1, IntTag, UpperLimit1, + 1, NumValues1, is_int_switch, IsIntSwitch1), + TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal), + tag_cases_in_int_switch(ModuleInfo, SwitchVarType, Cases, TaggedCases, + LowerLimit1, LowerLimit, UpperLimit1, UpperLimit, + NumValues1, NumValues, IsIntSwitch1, IsIntSwitch), + ( + IsIntSwitch = is_int_switch, + MaybeIntSwitchLimits = int_switch(LowerLimit, UpperLimit, + NumValues) + ; + IsIntSwitch = is_not_int_switch, + MaybeIntSwitchLimits = not_int_switch + ) ; - unexpected(this_file, "string_hash_cases: non-string case?") - ), - string.hash(String, HashVal0), - HashVal = HashVal0 /\ HashMask, - ( map.search(Map0, HashVal, CaseList0) -> - map.det_update(Map0, HashVal, [Case | CaseList0], Map) - ; - map.det_insert(Map0, HashVal, [Case], Map) + list.map(tag_cons_id(ModuleInfo, SwitchVarType), OtherConsIds, + TaggedOtherConsIds), + TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal), + tag_cases_plain(ModuleInfo, SwitchVarType, Cases, TaggedCases), + MaybeIntSwitchLimits = not_int_switch ). -calc_hash_slots(HashValList, HashMap, Map) :- - calc_hash_slots_1(HashValList, HashMap, map.init, Map, 0, _). +:- pred tag_cases_plain(module_info::in, mer_type::in, list(case)::in, + list(tagged_case)::out) is det. -:- pred calc_hash_slots_1(assoc_list(int, cases_list)::in, - map(int, cases_list)::in, map(int, hash_slot)::in, - map(int, hash_slot)::out, int::in, int::out) is det. +tag_cases_plain(_, _, [], []). +tag_cases_plain(ModuleInfo, SwitchVarType, [Case | Cases], + [TaggedCase | TaggedCases]) :- + Case = case(MainConsId, OtherConsIds, Goal), + tag_cons_id(ModuleInfo, SwitchVarType, MainConsId, TaggedMainConsId), + list.map(tag_cons_id(ModuleInfo, SwitchVarType), + OtherConsIds, TaggedOtherConsIds), + TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal), + tag_cases_plain(ModuleInfo, SwitchVarType, Cases, TaggedCases). -calc_hash_slots_1([], _, !Map, !LastUsed). -calc_hash_slots_1([HashVal - Cases | Rest], HashMap, !Map, !LastUsed) :- - calc_hash_slots_2(Cases, HashVal, HashMap, !Map, !LastUsed), - calc_hash_slots_1(Rest, HashMap, !Map, !LastUsed). +:- pred tag_cases_in_int_switch(module_info::in, mer_type::in, list(case)::in, + list(tagged_case)::out, int::in, int::out, int::in, int::out, + int::in, int::out, is_int_switch::in, is_int_switch::out) is det. -:- pred calc_hash_slots_2(cases_list::in, int::in, map(int, cases_list)::in, - map(int, hash_slot)::in, map(int, hash_slot)::out, int::in, int::out) - is det. +tag_cases_in_int_switch(_, _, [], [], !LowerLimit, !UpperLimit, !NumValues, + !IsIntSwitch). +tag_cases_in_int_switch(ModuleInfo, SwitchVarType, [Case | Cases], + [TaggedCase | TaggedCases], !LowerLimit, !UpperLimit, !NumValues, + !IsIntSwitch) :- + Case = case(MainConsId, OtherConsIds, Goal), + tag_cons_id_in_int_switch(ModuleInfo, SwitchVarType, + MainConsId, TaggedMainConsId, !LowerLimit, !UpperLimit, + !NumValues, !IsIntSwitch), + list.map_foldl4(tag_cons_id_in_int_switch(ModuleInfo, SwitchVarType), + OtherConsIds, TaggedOtherConsIds, !LowerLimit, !UpperLimit, + !NumValues, !IsIntSwitch), + TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal), + tag_cases_in_int_switch(ModuleInfo, SwitchVarType, Cases, TaggedCases, + !LowerLimit, !UpperLimit, !NumValues, !IsIntSwitch). -calc_hash_slots_2([], _HashVal, _HashMap, !Map, !LastUsed). -calc_hash_slots_2([Case | Cases], HashVal, HashMap, !Map, !LastUsed) :- - calc_hash_slots_2(Cases, HashVal, HashMap, !Map, !LastUsed), - ( map.contains(!.Map, HashVal) -> - follow_hash_chain(!.Map, HashVal, ChainEnd), - next_free_hash_slot(!.Map, HashMap, !LastUsed), - map.lookup(!.Map, ChainEnd, hash_slot(PrevCase, _)), - svmap.det_update(ChainEnd, hash_slot(PrevCase, !.LastUsed), !Map), - svmap.det_insert(!.LastUsed, hash_slot(Case, -1), !Map) +:- pred tag_cons_id(module_info::in, mer_type::in, cons_id::in, + tagged_cons_id::out) is det. + +tag_cons_id(ModuleInfo, SwitchVarType, ConsId, TaggedConsId) :- + ConsTag = cons_id_to_tag(ModuleInfo, SwitchVarType, ConsId), + TaggedConsId = tagged_cons_id(ConsId, ConsTag). + +:- pred tag_cons_id_in_int_switch(module_info::in, mer_type::in, cons_id::in, + tagged_cons_id::out, int::in, int::out, int::in, int::out, + int::in, int::out, is_int_switch::in, is_int_switch::out) is det. + +tag_cons_id_in_int_switch(ModuleInfo, SwitchVarType, ConsId, TaggedConsId, + !LowerLimit, !UpperLimit, !NumValues, !IsIntSwitch) :- + ConsTag = cons_id_to_tag(ModuleInfo, SwitchVarType, ConsId), + TaggedConsId = tagged_cons_id(ConsId, ConsTag), + ( ConsTag = int_tag(IntTag) -> + int.min(IntTag, !LowerLimit), + int.max(IntTag, !UpperLimit), + !:NumValues = !.NumValues + 1 ; - svmap.det_insert(HashVal, hash_slot(Case, -1), !Map) + !:IsIntSwitch = is_not_int_switch ). -:- pred follow_hash_chain(map(int, hash_slot)::in, int::in, int::out) is det. - -follow_hash_chain(Map, Slot, LastSlot) :- - map.lookup(Map, Slot, hash_slot(_, NextSlot)), - ( - NextSlot >= 0, - map.contains(Map, NextSlot) - -> - follow_hash_chain(Map, NextSlot, LastSlot) - ; - LastSlot = Slot - ). - - % next_free_hash_slot(M, H_M, LastUsed, FreeSlot): - % - % Find the next available slot FreeSlot in the hash table which is not - % already used (contained in M) and which is not going to be used a - % primary slot (contained in H_M), starting at the slot after LastUsed. - % -:- pred next_free_hash_slot(map(int, hash_slot)::in, - map(int, cases_list)::in, int::in, int::out) is det. - -next_free_hash_slot(Map, H_Map, LastUsed, FreeSlot) :- - NextSlot = LastUsed + 1, - ( - \+ map.contains(Map, NextSlot), - \+ map.contains(H_Map, NextSlot) - -> - FreeSlot = NextSlot - ; - next_free_hash_slot(Map, H_Map, NextSlot, FreeSlot) - ). +represent_tagged_case_by_itself(TaggedCase, TaggedCase, + !StateA, !StateB, !StateC). %-----------------------------------------------------------------------------% % -% Stuff for categorizing switches +% Stuff for categorizing switches. % type_cat_to_switch_cat(type_cat_enum) = atomic_switch. @@ -275,72 +350,224 @@ type_cat_to_switch_cat(type_cat_typeclass_info) = _ :- type_cat_to_switch_cat(type_cat_base_typeclass_info) = _ :- unexpected(this_file, "type_cat_to_switch_cat: base_typeclass_info"). -switch_priority(no_tag) = 0. % should never occur -switch_priority(int_tag(_)) = 1. -switch_priority(foreign_tag(_, _)) = 1. -switch_priority(reserved_address_tag(_)) = 1. -switch_priority(shared_local_tag(_, _)) = 1. -switch_priority(single_functor_tag) = 2. -switch_priority(unshared_tag(_)) = 2. -switch_priority(float_tag(_)) = 3. -switch_priority(shared_remote_tag(_, _)) = 4. -switch_priority(string_tag(_)) = 5. -switch_priority(shared_with_reserved_addresses_tag(RAs, Tag)) = - switch_priority(Tag) + list.length(RAs). - % The following tags should all never occur in switches. -switch_priority(pred_closure_tag(_, _, _)) = 6. -switch_priority(type_ctor_info_tag(_, _, _)) = 6. -switch_priority(base_typeclass_info_tag(_, _, _)) = 6. -switch_priority(tabling_info_tag(_, _)) = 6. -switch_priority(deep_profiling_proc_layout_tag(_, _)) = 6. -switch_priority(table_io_decl_tag(_, _)) = 6. - -type_range(type_cat_char, _, _, MinChar, MaxChar) :- - % XXX the following code uses the host's character size, - % not the target's, so it won't work if cross-compiling - % to a machine with a different character size. - % Note also that the code in dense_switch.m and the code - % in lookup_switch.m assume that char.min_char_value is 0. - char.min_char_value(MinChar), - char.max_char_value(MaxChar). -type_range(type_cat_enum, Type, ModuleInfo, 0, MaxEnum) :- - ( type_to_ctor_and_args(Type, TypeCtorPrime, _) -> - TypeCtor = TypeCtorPrime - ; - unexpected(this_file, "dense_switch.type_range: invalid enum type?") - ), - module_info_get_type_table(ModuleInfo, TypeTable), - map.lookup(TypeTable, TypeCtor, TypeDefn), - hlds_data.get_type_defn_body(TypeDefn, TypeBody), +estimate_switch_tag_test_cost(Tag) = Cost :- ( - TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _), - map.count(ConsTable, TypeRange), - MaxEnum = TypeRange - 1 - ; - ( TypeBody = hlds_eqv_type(_) - ; TypeBody = hlds_foreign_type(_) - ; TypeBody = hlds_solver_type(_, _) - ; TypeBody = hlds_abstract_type(_) + ( Tag = int_tag(_) + ; Tag = foreign_tag(_, _) + ; Tag = reserved_address_tag(_) + ; Tag = shared_local_tag(_, _) ), - unexpected(this_file, "type_range: enum type is not d.u. type?") + % You need only a single word compare. + Cost = 1 + ; + Tag = single_functor_tag, + % There is no cost incurred here except the cost of testing for all the + % reserved addresses this tag is shared with; the Cost = 2 is an + % estimate (XXX probably not very accurate) of the fixed cost + % of the scan over them. + Cost = 2 + ; + Tag = unshared_tag(_), + % You need to compute the primary tag and compare it. + Cost = 2 + ; + Tag = float_tag(_), + % You need to follow a pointer and then compare 64 bits + % (two words on 32 bit machines, which are still the most common). + Cost = 3 + ; + Tag = shared_remote_tag(_, _), + % You need to compute the primary tag, compare it, follow a pointer + % and then compare the remote secondary tag. + Cost = 4 + ; + Tag = string_tag(String), + % You need to follow a pointer and then compare all the characters to + % the end of the string. The multiplication is an attempt to factor in + % the fact that each character comparison is in a loop, and thus takes + % more than one instruction. + Cost = 1 + 2 * string.length(String) + ; + Tag = shared_with_reserved_addresses_tag(RAs, SubTag), + % You need to rule out all reserved addresses before testing SubTag. + Cost = 2 * list.length(RAs) + estimate_switch_tag_test_cost(SubTag) + ; + ( Tag = no_tag + ; Tag = pred_closure_tag(_, _, _) + ; Tag = type_ctor_info_tag(_, _, _) + ; Tag = base_typeclass_info_tag(_, _, _) + ; Tag = tabling_info_tag(_, _) + ; Tag = deep_profiling_proc_layout_tag(_, _) + ; Tag = table_io_decl_tag(_, _) + ), + unexpected(this_file, "estimate_switch_tag_test_cost: non-switch tag") ). +%-----------------------------------------------------------------------------% +% +% Stuff for dense switches. +% + +type_range(ModuleInfo, TypeCat, Type, Min, Max, NumValues) :- + ( + TypeCat = type_cat_char, + % XXX The following code uses the host's character size, not the + % target's, so it won't work if cross-compiling to a machine with + % a different character size. Note also that some code in both + % dense_switch.m and in lookup_switch.m assumes that + % char.min_char_value is 0. + char.min_char_value(Min), + char.max_char_value(Max) + ; + TypeCat = type_cat_enum, + Min = 0, + type_to_ctor_det(Type, TypeCtor), + module_info_get_type_table(ModuleInfo, TypeTable), + map.lookup(TypeTable, TypeCtor, TypeDefn), + hlds_data.get_type_defn_body(TypeDefn, TypeBody), + ( + TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _, _), + map.count(ConsTable, TypeRange), + Max = TypeRange - 1 + ; + ( TypeBody = hlds_eqv_type(_) + ; TypeBody = hlds_foreign_type(_) + ; TypeBody = hlds_solver_type(_, _) + ; TypeBody = hlds_abstract_type(_) + ), + unexpected(this_file, "type_range: enum type is not d.u. type?") + ) + ), + NumValues = Max - Min + 1. + switch_density(NumCases, Range) = Density :- Density = (NumCases * 100) // Range. %-----------------------------------------------------------------------------% +% +% Stuff for string hash switches. +% + +string_hash_cases([], _, _, !StateA, !StateB, !StateC, !:HashMap) :- + map.init(!:HashMap). +string_hash_cases([TaggedCase | TaggedCases], HashMask, RepresentCase, + !StateA, !StateB, !StateC, !:HashMap) :- + string_hash_cases(TaggedCases, HashMask, RepresentCase, + !StateA, !StateB, !StateC, !:HashMap), + RepresentCase(TaggedCase, CaseRep, !StateA, !StateB, !StateC), + TaggedCase = tagged_case(MainTaggedConsId, OtherTaggedConsIds, _Goal), + TaggedConsIds = [MainTaggedConsId | OtherTaggedConsIds], + list.foldl(string_hash_cons_id(CaseRep, HashMask), TaggedConsIds, + !HashMap). + +:- pred string_hash_cons_id(CaseRep::in, int::in, tagged_cons_id::in, + map(int, assoc_list(string, CaseRep))::in, + map(int, assoc_list(string, CaseRep))::out) is det. + +string_hash_cons_id(CaseRep, HashMask, TaggedConsId, !HashMap) :- + TaggedConsId = tagged_cons_id(_ConsId, Tag), + ( Tag = string_tag(StringPrime) -> + String = StringPrime + ; + unexpected(this_file, "string_hash_cases: non-string case?") + ), + string.hash(String, StringHashVal), + HashVal = StringHashVal /\ HashMask, + ( map.search(!.HashMap, HashVal, OldStringCaseReps) -> + svmap.det_update(HashVal, [String - CaseRep | OldStringCaseReps], + !HashMap) + ; + svmap.det_insert(HashVal, [String - CaseRep], !HashMap) + ). + +calc_string_hash_slots(HashValList, HashMap, SlotMap) :- + calc_string_hash_slots_1(HashValList, HashMap, map.init, SlotMap, 0, _). + +:- pred calc_string_hash_slots_1( + assoc_list(int, assoc_list(string, CaseRep))::in, + map(int, assoc_list(string, CaseRep))::in, + map(int, string_hash_slot(CaseRep))::in, + map(int, string_hash_slot(CaseRep))::out, + int::in, int::out) is det. + +calc_string_hash_slots_1([], _, !SlotMap, !LastUsed). +calc_string_hash_slots_1([HashVal - StringCaseReps | Rest], HashMap, + !SlotMap, !LastUsed) :- + calc_string_hash_slots_2(StringCaseReps, HashVal, HashMap, + !SlotMap, !LastUsed), + calc_string_hash_slots_1(Rest, HashMap, !SlotMap, !LastUsed). + +:- pred calc_string_hash_slots_2(assoc_list(string, CaseRep)::in, int::in, + map(int, assoc_list(string, CaseRep))::in, + map(int, string_hash_slot(CaseRep))::in, + map(int, string_hash_slot(CaseRep))::out, + int::in, int::out) is det. + +calc_string_hash_slots_2([], _HashVal, _HashMap, !SlotMap, !LastUsed). +calc_string_hash_slots_2([StringCaseRep | StringCaseReps], HashVal, HashMap, + !SlotMap, !LastUsed) :- + calc_string_hash_slots_2(StringCaseReps, HashVal, HashMap, + !SlotMap, !LastUsed), + StringCaseRep = String - CaseRep, + NewSlot = string_hash_slot(-1, String, CaseRep), + ( map.contains(!.SlotMap, HashVal) -> + follow_hash_chain(!.SlotMap, HashVal, ChainEnd), + next_free_hash_slot(!.SlotMap, HashMap, !LastUsed), + map.lookup(!.SlotMap, ChainEnd, ChainEndSlot0), + ChainEndSlot0 = string_hash_slot(_, PrevString, PrevCaseRep), + ChainEndSlot = string_hash_slot(!.LastUsed, PrevString, PrevCaseRep), + svmap.det_update(ChainEnd, ChainEndSlot, !SlotMap), + svmap.det_insert(!.LastUsed, NewSlot, !SlotMap) + ; + svmap.det_insert(HashVal, NewSlot, !SlotMap) + ). + +:- pred follow_hash_chain(map(int, string_hash_slot(CaseRep))::in, + int::in, int::out) is det. + +follow_hash_chain(Map, Slot, LastSlot) :- + map.lookup(Map, Slot, string_hash_slot(NextSlot, _, _)), + ( + NextSlot >= 0, + map.contains(Map, NextSlot) + -> + follow_hash_chain(Map, NextSlot, LastSlot) + ; + LastSlot = Slot + ). + + % next_free_hash_slot(M, H_M, LastUsed, FreeSlot): + % + % Find the next available slot FreeSlot in the hash table which is not + % already used (contained in M) and which is not going to be used a + % primary slot (contained in H_M), starting at the slot after LastUsed. + % +:- pred next_free_hash_slot(map(int, string_hash_slot(CaseRep))::in, + map(int, assoc_list(string, CaseRep))::in, int::in, int::out) is det. + +next_free_hash_slot(Map, H_Map, LastUsed, FreeSlot) :- + NextSlot = LastUsed + 1, + ( + \+ map.contains(Map, NextSlot), + \+ map.contains(H_Map, NextSlot) + -> + FreeSlot = NextSlot + ; + next_free_hash_slot(Map, H_Map, NextSlot, FreeSlot) + ). + +%-----------------------------------------------------------------------------% +% +% Stuff for tag switches. +% get_ptag_counts(Type, ModuleInfo, MaxPrimary, PtagCountMap) :- - ( type_to_ctor_and_args(Type, TypeCtorPrime, _) -> - TypeCtor = TypeCtorPrime - ; - unexpected(this_file, "unknown type in get_ptag_counts") - ), + type_to_ctor_det(Type, TypeCtor), module_info_get_type_table(ModuleInfo, TypeTable), map.lookup(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) ; @@ -426,10 +653,21 @@ get_ptag_counts_2([Tag | Tags], !MaxPrimary, !PtagCountMap) :- %-----------------------------------------------------------------------------% -group_cases_by_ptag([], !PtagCaseMap). -group_cases_by_ptag([Case0 | Cases0], !PtagCaseMap) :- - Case0 = extended_case(_Priority, Tag, ConsId, Goal), - ConsIdGoal = stag_goal(ConsId, Goal), +group_cases_by_ptag([], _, !StateA, !StateB, !StateC, !PtagCaseMap). +group_cases_by_ptag([TaggedCase | TaggedCases], RepresentCase, + !StateA, !StateB, !StateC, !PtagCaseMap) :- + TaggedCase = tagged_case(MainTaggedConsId, OtherConsIds, _Goal), + RepresentCase(TaggedCase, CaseRep, !StateA, !StateB, !StateC), + group_case_by_ptag(CaseRep, MainTaggedConsId, !PtagCaseMap), + list.foldl(group_case_by_ptag(CaseRep), OtherConsIds, !PtagCaseMap), + group_cases_by_ptag(TaggedCases, RepresentCase, !StateA, !StateB, !StateC, + !PtagCaseMap). + +:- pred group_case_by_ptag(CaseRep::in, tagged_cons_id::in, + ptag_case_map(CaseRep)::in, ptag_case_map(CaseRep)::out) is det. + +group_case_by_ptag(CaseRep, TaggedConsId, !PtagCaseMap) :- + TaggedConsId = tagged_cons_id(_ConsId, Tag), ( ( Tag = single_functor_tag, Primary = 0 ; Tag = unshared_tag(Primary) @@ -438,7 +676,7 @@ group_cases_by_ptag([Case0 | Cases0], !PtagCaseMap) :- unexpected(this_file, "unshared tag is shared") ; map.init(StagGoalMap0), - map.det_insert(StagGoalMap0, -1, ConsIdGoal, StagGoalMap), + map.det_insert(StagGoalMap0, -1, CaseRep, StagGoalMap), svmap.det_insert(Primary, ptag_case(sectag_none, StagGoalMap), !PtagCaseMap) ) @@ -448,12 +686,12 @@ group_cases_by_ptag([Case0 | Cases0], !PtagCaseMap) :- Group = ptag_case(StagLoc, StagGoalMap0), expect(unify(StagLoc, sectag_remote), this_file, "remote tag is shared with non-remote"), - map.det_insert(StagGoalMap0, Secondary, ConsIdGoal, StagGoalMap), + map.det_insert(StagGoalMap0, Secondary, CaseRep, StagGoalMap), svmap.det_update(Primary, ptag_case(sectag_remote, StagGoalMap), !PtagCaseMap) ; map.init(StagGoalMap0), - map.det_insert(StagGoalMap0, Secondary, ConsIdGoal, StagGoalMap), + map.det_insert(StagGoalMap0, Secondary, CaseRep, StagGoalMap), svmap.det_insert(Primary, ptag_case(sectag_remote, StagGoalMap), !PtagCaseMap) ) @@ -463,12 +701,12 @@ group_cases_by_ptag([Case0 | Cases0], !PtagCaseMap) :- Group = ptag_case(StagLoc, StagGoalMap0), expect(unify(StagLoc, sectag_local), this_file, "local tag is shared with non-local"), - map.det_insert(StagGoalMap0, Secondary, ConsIdGoal, StagGoalMap), + map.det_insert(StagGoalMap0, Secondary, CaseRep, StagGoalMap), svmap.det_update(Primary, ptag_case(sectag_local, StagGoalMap), !PtagCaseMap) ; map.init(StagGoalMap0), - map.det_insert(StagGoalMap0, Secondary, ConsIdGoal, StagGoalMap), + map.det_insert(StagGoalMap0, Secondary, CaseRep, StagGoalMap), svmap.det_insert(Primary, ptag_case(sectag_local, StagGoalMap), !PtagCaseMap) ) @@ -487,9 +725,8 @@ group_cases_by_ptag([Case0 | Cases0], !PtagCaseMap) :- ; Tag = reserved_address_tag(_) ; Tag = shared_with_reserved_addresses_tag(_, _) ), - unexpected(this_file, "non-du tag in group_cases_by_ptag") - ), - group_cases_by_ptag(Cases0, !PtagCaseMap). + unexpected(this_file, "non-du tag in group_case_by_ptag") + ). %-----------------------------------------------------------------------------% diff --git a/compiler/table_gen.m b/compiler/table_gen.m index 7a4c4516c..41998901c 100644 --- a/compiler/table_gen.m +++ b/compiler/table_gen.m @@ -755,8 +755,8 @@ create_new_loop_goal(Detism, OrigGoal, Statistics, PredId, ProcId, TB = mercury_table_builtin_module, SwitchArms = [ - case(cons(qualified(TB, "loop_active"), 0), ActiveGoal), - case(cons(qualified(TB, "loop_inactive"), 0), InactiveGoal) + case(cons(qualified(TB, "loop_active"), 0), [], ActiveGoal), + case(cons(qualified(TB, "loop_inactive"), 0), [], InactiveGoal) ], SwitchExpr = switch(StatusVar, cannot_fail, SwitchArms), set.insert_list(InactiveNonLocals, [StatusVar, TableTipVar], @@ -956,9 +956,12 @@ create_new_memo_goal(Detism, OrigGoal, Statistics, _MaybeSizeLimit, TB = mercury_table_builtin_module, SwitchArms = [ - case(cons(qualified(TB, "memo_det_active"), 0), ActiveGoal), - case(cons(qualified(TB, "memo_det_inactive"), 0), InactiveGoal), - case(cons(qualified(TB, "memo_det_succeeded"), 0), SucceededGoal) + case(cons(qualified(TB, "memo_det_active"), 0), [], + ActiveGoal), + case(cons(qualified(TB, "memo_det_inactive"), 0), [], + InactiveGoal), + case(cons(qualified(TB, "memo_det_succeeded"), 0), [], + SucceededGoal) ] ; CodeModel = model_semi, @@ -994,10 +997,14 @@ create_new_memo_goal(Detism, OrigGoal, Statistics, _MaybeSizeLimit, TB = mercury_table_builtin_module, SwitchArms = [ - case(cons(qualified(TB, "memo_semi_active"), 0), ActiveGoal), - case(cons(qualified(TB, "memo_semi_inactive"), 0), InactiveGoal), - case(cons(qualified(TB, "memo_semi_succeeded"), 0), SucceededGoal), - case(cons(qualified(TB, "memo_semi_failed"), 0), FailedGoal) + case(cons(qualified(TB, "memo_semi_active"), 0), [], + ActiveGoal), + case(cons(qualified(TB, "memo_semi_inactive"), 0), [], + InactiveGoal), + case(cons(qualified(TB, "memo_semi_succeeded"), 0), [], + SucceededGoal), + case(cons(qualified(TB, "memo_semi_failed"), 0), [], + FailedGoal) ] ), @@ -1112,10 +1119,14 @@ create_new_memo_non_goal(Detism, OrigGoal, Statistics, _MaybeSizeLimit, TB = mercury_table_builtin_module, SwitchArms = [ - case(cons(qualified(TB, "memo_non_active"), 0), InfiniteRecursionGoal), - case(cons(qualified(TB, "memo_non_inactive"), 0), InactiveGoal), - case(cons(qualified(TB, "memo_non_incomplete"), 0), NeedMinModelGoal), - case(cons(qualified(TB, "memo_non_complete"), 0), RestoreAllAnswerGoal) + case(cons(qualified(TB, "memo_non_active"), 0), [], + InfiniteRecursionGoal), + case(cons(qualified(TB, "memo_non_inactive"), 0), [], + InactiveGoal), + case(cons(qualified(TB, "memo_non_incomplete"), 0), [], + NeedMinModelGoal), + case(cons(qualified(TB, "memo_non_complete"), 0), [], + RestoreAllAnswerGoal) ], SwitchExpr = switch(StatusVar, cannot_fail, SwitchArms), @@ -1508,9 +1519,12 @@ create_new_mm_goal(Detism, OrigGoal, Statistics, PredId, ProcId, TB = mercury_table_builtin_module, SwitchArms = [ - case(cons(qualified(TB, "mm_inactive"), 0), InactiveGoal), - case(cons(qualified(TB, "mm_complete"), 0), RestoreAllAnswerGoal), - case(cons(qualified(TB, "mm_active"), 0), SuspendGoal) + case(cons(qualified(TB, "mm_inactive"), 0), [], + InactiveGoal), + case(cons(qualified(TB, "mm_complete"), 0), [], + RestoreAllAnswerGoal), + case(cons(qualified(TB, "mm_active"), 0), [], + SuspendGoal) ], SwitchExpr = switch(StatusVar, cannot_fail, SwitchArms), goal_info_add_feature(feature_hide_debug_event, @@ -2437,7 +2451,7 @@ gen_lookup_call_for_type(ArgTablingMethod, TypeCat, Type, ArgVar, VarSeqNum, ; ( ArgTablingMethod = arg_addr ; ArgTablingMethod = arg_promise_implied - ) + ) ) ; TypeCat = type_cat_base_typeclass_info, diff --git a/compiler/tabling_analysis.m b/compiler/tabling_analysis.m index 2313e2cee..8963abc1c 100644 --- a/compiler/tabling_analysis.m +++ b/compiler/tabling_analysis.m @@ -363,7 +363,7 @@ check_goal_for_mm_tabling_2(SCC, VarTypes, Goal, _, Goals = [If, Then, Else] ; Goal = switch(_, _, Cases), - Goals = list.map((func(case(_, CaseGoal)) = CaseGoal), Cases) + Goals = list.map((func(case(_, _, CaseGoal)) = CaseGoal), Cases) ), check_goals_for_mm_tabling(SCC, VarTypes, Goals, Result, MaybeAnalysisStatus, !ModuleInfo, !IO). @@ -707,9 +707,9 @@ annotate_cases(VarTypes, !Cases, Status, !ModuleInfo, !IO) :- io::di, io::uo) is det. annotate_case(VarTypes, !Case, Status, !ModuleInfo, !IO) :- - !.Case = case(ConsId, Goal0), + !.Case = case(MainConsId, OtherConsIds, Goal0), annotate_goal(VarTypes, Goal0, Goal, Status, !ModuleInfo, !IO), - !:Case = case(ConsId, Goal). + !:Case = case(MainConsId, OtherConsIds, Goal). :- pred annotate_call(pred_proc_id::in, prog_vars::in, vartypes::in, mm_tabling_status::out, module_info::in, module_info::out, io::di, io::uo) diff --git a/compiler/tag_switch.m b/compiler/tag_switch.m index 9f06b10ac..fcf47b567 100644 --- a/compiler/tag_switch.m +++ b/compiler/tag_switch.m @@ -16,7 +16,6 @@ :- module ll_backend.tag_switch. :- interface. -:- import_module backend_libs.switch_util. :- import_module hlds.code_model. :- import_module hlds.hlds_goal. :- import_module ll_backend.code_info. @@ -29,8 +28,8 @@ % Generate intelligent indexing code for tag based switches. % -:- pred generate_tag_switch(list(extended_case)::in, prog_var::in, - code_model::in, can_fail::in, hlds_goal_info::in, label::in, +:- pred generate_tag_switch(list(tagged_case)::in, rval::in, mer_type::in, + string::in, code_model::in, can_fail::in, hlds_goal_info::in, label::in, branch_end::in, branch_end::out, code_tree::out, code_info::in, code_info::out) is det. @@ -41,6 +40,7 @@ :- import_module backend_libs.builtin_ops. :- import_module backend_libs.rtti. +:- import_module backend_libs.switch_util. :- import_module hlds.hlds_data. :- import_module hlds.hlds_llds. :- import_module hlds.hlds_out. @@ -50,6 +50,7 @@ :- import_module libs.options. :- import_module libs.tree. :- import_module ll_backend.code_gen. +:- import_module ll_backend.switch_case. :- import_module ll_backend.trace_gen. :- import_module parse_tree.prog_data. @@ -59,6 +60,7 @@ :- import_module maybe. :- import_module pair. :- import_module string. +:- import_module svmap. %-----------------------------------------------------------------------------% @@ -125,16 +127,17 @@ % Note that for a det switch with two tag values, try-me-else chains % and try chains are equivalent. % - % Which method is best depends on the number of possible tag values, - % on the costs of taken/untaken branches and table lookups on the given - % architecture, and on the frequency with which the various - % alternatives are taken. + % Which method is best depends + % - on the number of possible tag values, + % - on the costs of taken/untaken branches and table lookups on the given + % architecture, and + % - on the frequency with which the various alternatives are taken. % - % While the first two are in principle known at compile time, - % the third is not. Nevertheless, for switches on primary tags - % we can use the heuristic that the more secondary tags assigned to - % a primary tag, the more likely that the switch variable will have - % that primary tag at runtime. + % While the first two are in principle known at compile time, the third + % is not (at least not without feedback from a profiler). Nevertheless, + % for switches on primary tags we can use the heuristic that the more + % secondary tags assigned to a primary tag, the more likely that the + % switch variable will have that primary tag at runtime. % % Try chains are good for switches with small numbers of alternatives % on architectures where untaken branches are cheaper than taken @@ -159,7 +162,7 @@ % expected cost of a jump table lookup and dispatch. % For try-me-else chains, we want tag1 to be the most frequent case, - % tag 2 the next most frequent case, etc. + % tag2 the next most frequent case, etc. % % For det try chains, we want the last tag value to be the most % frequent case, since it can be reached without taken jumps. @@ -191,19 +194,42 @@ ; jump_table ; binary_search. -generate_tag_switch(Cases, Var, CodeModel, CanFail, SwitchGoalInfo, EndLabel, - !MaybeEnd, Code, !CI) :- +%-----------------------------------------------------------------------------% + +generate_tag_switch(TaggedCases, VarRval, VarType, VarName, CodeModel, CanFail, + SwitchGoalInfo, EndLabel, !MaybeEnd, Code, !CI) :- + + % We get registers for holding the primary and (if needed) the secondary + % tag. The tags needed only by the switch, and no other code gets control + % between producing the tag values and all their uses, so we can release + % the registers for use by the code of the various cases. + % + % We forgo using the primary tag register if the primary tag is needed + % only once, or if the "register" we get is likely to be slower than + % recomputing the tag from scratch. + % + % We need to get and release the registers before we generate the code + % of the switch arms, since the set of free registers will in general be + % different before and after that action. + acquire_reg(reg_r, PtagReg, !CI), + acquire_reg(reg_r, StagReg, !CI), + release_reg(PtagReg, !CI), + release_reg(StagReg, !CI), + % Group the cases based on primary tag value and find out how many % constructors share each primary tag value. - get_module_info(!.CI, ModuleInfo), - get_proc_info(!.CI, ProcInfo), - proc_info_get_vartypes(ProcInfo, VarTypes), - map.lookup(VarTypes, Var, Type), - switch_util.get_ptag_counts(Type, ModuleInfo, MaxPrimary, PtagCountMap), + get_ptag_counts(VarType, ModuleInfo, MaxPrimary, PtagCountMap), map.to_assoc_list(PtagCountMap, PtagCountList), + remember_position(!.CI, BranchStart), + Params = represent_params(VarName, SwitchGoalInfo, CodeModel, BranchStart, + EndLabel), + map.init(CaseLabelMap0), map.init(PtagCaseMap0), - switch_util.group_cases_by_ptag(Cases, PtagCaseMap0, PtagCaseMap), + group_cases_by_ptag(TaggedCases, + represent_tagged_case_for_llds(Params), + CaseLabelMap0, CaseLabelMap1, !MaybeEnd, !CI, + PtagCaseMap0, PtagCaseMap), map.count(PtagCaseMap, PtagsUsed), get_globals(!.CI, Globals), @@ -220,19 +246,6 @@ generate_tag_switch(Cases, Var, CodeModel, CanFail, SwitchGoalInfo, EndLabel, PrimaryMethod = try_me_else_chain ), - % We get a register for holding the tag. The tag is needed only - % by the switch, and no other code gets control between producing - % the tag value and all uses of it, so we can release the register - % for use by the code of the various cases. - - % We forgo using the register if the primary tag is needed only once, - % or if the "register" we get is likely to be slower than - % recomputing the tag from scratch. - - produce_variable_in_reg(Var, VarCode, VarLval, !CI), - VarRval = lval(VarLval), - acquire_reg(reg_r, PtagReg, !CI), - release_reg(PtagReg, !CI), ( PrimaryMethod \= jump_table, PtagsUsed >= 2, @@ -257,232 +270,258 @@ generate_tag_switch(Cases, Var, CodeModel, CanFail, SwitchGoalInfo, EndLabel, PtagRval = unop(tag, VarRval) ), - % We generate FailCode and EndCode here because the last case within - % a primary tag may not be the last case overall. - - get_next_label(FailLabel, !CI), - FailLabelCode = node([ - llds_instr(label(FailLabel), "switch has failed") - ]), + % We generate EndCode (and if needed, FailCode) here because the last + % case within a primary tag may not be the last case overall. + EndCode = node([llds_instr(label(EndLabel), "end of tag switch")]), ( CanFail = cannot_fail, - FailCode = node([ - llds_instr(goto(do_not_reached), "oh-oh, det switch failed") - ]) + MaybeFailLabel = no, + FailCode = empty ; CanFail = can_fail, - generate_failure(FailCode, !CI) + get_next_label(FailLabel, !CI), + MaybeFailLabel = yes(FailLabel), + FailLabelCode = node([ + llds_instr(label(FailLabel), "switch has failed") + ]), + % We must generate the failure code in the context in which none of the + % switch arms have been executed yet. + reset_to_position(BranchStart, !CI), + generate_failure(FailureCode, !CI), + FailCode = tree(FailLabelCode, FailureCode) ), - LabelledFailCode = tree(FailLabelCode, FailCode), - - EndCode = node([llds_instr(label(EndLabel), "end of tag switch")]), ( PrimaryMethod = binary_search, - switch_util.order_ptags_by_value(0, MaxPrimary, PtagCaseMap, - PtagCaseList), + order_ptags_by_value(0, MaxPrimary, PtagCaseMap, PtagCaseList), generate_primary_binary_search(PtagCaseList, 0, MaxPrimary, PtagRval, - VarRval, CodeModel, CanFail, SwitchGoalInfo, EndLabel, FailLabel, - PtagCountMap, !MaybeEnd, CasesCode, !CI) + StagReg, VarRval, MaybeFailLabel, PtagCountMap, CasesCode, + CaseLabelMap1, CaseLabelMap, !CI) ; PrimaryMethod = jump_table, - switch_util.order_ptags_by_value(0, MaxPrimary, PtagCaseMap, - PtagCaseList), - generate_primary_jump_table(PtagCaseList, 0, MaxPrimary, VarRval, - CodeModel, SwitchGoalInfo, EndLabel, FailLabel, PtagCountMap, - !MaybeEnd, Labels, TableCode, !CI), + order_ptags_by_value(0, MaxPrimary, PtagCaseMap, PtagCaseList), + generate_primary_jump_table(PtagCaseList, 0, MaxPrimary, StagReg, + VarRval, MaybeFailLabel, PtagCountMap, Targets, TableCode, + CaseLabelMap1, CaseLabelMap, !CI), SwitchCode = node([ - llds_instr(computed_goto(PtagRval, Labels), + llds_instr(computed_goto(PtagRval, Targets), "switch on primary tag") ]), CasesCode = tree(SwitchCode, TableCode) ; PrimaryMethod = try_chain, - switch_util.order_ptags_by_count(PtagCountList, PtagCaseMap, - PtagCaseList0), + order_ptags_by_count(PtagCountList, PtagCaseMap, PtagCaseList0), ( CanFail = cannot_fail, PtagCaseList0 = [MostFreqCase | OtherCases] -> - list.append(OtherCases, [MostFreqCase], PtagCaseList) + PtagCaseList = OtherCases ++ [MostFreqCase] ; PtagCaseList = PtagCaseList0 ), - generate_primary_try_chain(PtagCaseList, PtagRval, VarRval, CodeModel, - CanFail, SwitchGoalInfo, EndLabel, FailLabel, PtagCountMap, - empty, empty, !MaybeEnd, CasesCode, !CI) + generate_primary_try_chain(PtagCaseList, PtagRval, StagReg, VarRval, + MaybeFailLabel, PtagCountMap, empty, empty, CasesCode, + CaseLabelMap1, CaseLabelMap, !CI) ; PrimaryMethod = try_me_else_chain, - switch_util.order_ptags_by_count(PtagCountList, PtagCaseMap, - PtagCaseList), - generate_primary_try_me_else_chain(PtagCaseList, PtagRval, VarRval, - CodeModel, CanFail, SwitchGoalInfo, EndLabel, FailLabel, - PtagCountMap, !MaybeEnd, CasesCode, !CI) + order_ptags_by_count(PtagCountList, PtagCaseMap, PtagCaseList), + generate_primary_try_me_else_chain(PtagCaseList, PtagRval, StagReg, + VarRval, MaybeFailLabel, PtagCountMap, CasesCode, + CaseLabelMap1, CaseLabelMap, !CI) ), - Code = tree_list([VarCode, PtagCode, CasesCode, LabelledFailCode, + map.foldl(add_remaining_case, CaseLabelMap, empty, RemainingCasesCode), + Code = tree_list([PtagCode, CasesCode, RemainingCasesCode, FailCode, EndCode]). %-----------------------------------------------------------------------------% % Generate a switch on a primary tag value using a try-me-else chain. % -:- pred generate_primary_try_me_else_chain(ptag_case_list::in, - rval::in, rval::in, code_model::in, can_fail::in, hlds_goal_info::in, - label::in, label::in, ptag_count_map::in, - branch_end::in, branch_end::out, code_tree::out, +:- pred generate_primary_try_me_else_chain(ptag_case_list(label)::in, + rval::in, lval::in, rval::in, maybe(label)::in, + ptag_count_map::in, code_tree::out, + case_label_map::in, case_label_map::out, code_info::in, code_info::out) is det. -generate_primary_try_me_else_chain([], _, _, _, _, _, _, _, _, _, _, _, !CI) :- +generate_primary_try_me_else_chain([], _, _, _, _, _, _, + !CaseLabelMap, !CI) :- unexpected(this_file, "generate_primary_try_me_else_chain: empty switch"). -generate_primary_try_me_else_chain([PtagGroup | PtagGroups], TagRval, VarRval, - CodeModel, CanFail, SwitchGoalInfo, EndLabel, FailLabel, PtagCountMap, - !MaybeEnd, Code, !CI) :- - PtagGroup = Primary - ptag_case(StagLoc, StagGoalMap), +generate_primary_try_me_else_chain([PtagGroup | PtagGroups], PtagRval, StagReg, + VarRval, MaybeFailLabel, PtagCountMap, Code, !CaseLabelMap, !CI) :- + PtagGroup = Primary - PtagCase, + PtagCase = ptag_case(StagLoc, StagGoalMap), map.lookup(PtagCountMap, Primary, CountInfo), - CountInfo = StagLoc1 - MaxSecondary, - expect(unify(StagLoc, StagLoc1), this_file, + CountInfo = StagLocPrime - MaxSecondary, + expect(unify(StagLoc, StagLocPrime), this_file, "generate_primary_try_me_else_chain: secondary tag locations differ"), ( - ( PtagGroups = [_ | _] - ; CanFail = can_fail - ) - -> - remember_position(!.CI, BranchStart), - get_next_label(ElseLabel, !CI), - TestRval = binop(ne, TagRval, - unop(mktag, const(llconst_int(Primary)))), - TestCode = node([ - llds_instr(if_val(TestRval, code_label(ElseLabel)), - "test primary tag only") - ]), - generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, StagLoc, - VarRval, CodeModel, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, - TagCode, !CI), - ElseCode = node([ - llds_instr(label(ElseLabel), "handle next primary tag") - ]), - ThisTagCode = tree_list([TestCode, TagCode, ElseCode]), + PtagGroups = [_ | _], + generate_primary_try_me_else_chain_case(PtagRval, StagReg, Primary, + PtagCase, MaxSecondary, VarRval, MaybeFailLabel, ThisTagCode, + !CaseLabelMap, !CI), + generate_primary_try_me_else_chain(PtagGroups, PtagRval, StagReg, + VarRval, MaybeFailLabel, PtagCountMap, OtherTagsCode, + !CaseLabelMap, !CI), + Code = tree(ThisTagCode, OtherTagsCode) + ; + PtagGroups = [], ( - PtagGroups = [_ | _], - reset_to_position(BranchStart, !CI), - generate_primary_try_me_else_chain(PtagGroups, TagRval, VarRval, - CodeModel, CanFail, SwitchGoalInfo, EndLabel, FailLabel, - PtagCountMap, !MaybeEnd, OtherTagsCode, !CI), - Code = tree(ThisTagCode, OtherTagsCode) - ; - PtagGroups = [], - % FailLabel ought to be the next label anyway, - % so this goto will be optimized away (unless the - % layout of the failcode in the caller changes). + MaybeFailLabel = yes(FailLabel), + generate_primary_try_me_else_chain_case(PtagRval, StagReg, Primary, + PtagCase, MaxSecondary, VarRval, MaybeFailLabel, ThisTagCode, + !CaseLabelMap, !CI), + % FailLabel ought to be the next label anyway, so this goto + % will be optimized away (unless the layout of the failcode + % in the caller changes). FailCode = node([ llds_instr(goto(code_label(FailLabel)), "primary tag with no code to handle it") ]), Code = tree(ThisTagCode, FailCode) + ; + MaybeFailLabel = no, + generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, + StagReg, StagLoc, VarRval, MaybeFailLabel, Code, + !CaseLabelMap, !CI) ) - ; - generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, StagLoc, - VarRval, CodeModel, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, - Code, !CI) ). +:- pred generate_primary_try_me_else_chain_case(rval::in, lval::in, int::in, + ptag_case(label)::in, int::in, rval::in, maybe(label)::in, + code_tree::out, + case_label_map::in, case_label_map::out, + code_info::in, code_info::out) is det. + +generate_primary_try_me_else_chain_case(PtagRval, StagReg, Primary, PtagCase, + MaxSecondary, VarRval, MaybeFailLabel, Code, !CaseLabelMap, !CI) :- + get_next_label(ElseLabel, !CI), + TestRval = binop(ne, PtagRval, + unop(mktag, const(llconst_int(Primary)))), + TestCode = node([ + llds_instr(if_val(TestRval, code_label(ElseLabel)), + "test primary tag only") + ]), + PtagCase = ptag_case(StagLoc, StagGoalMap), + generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, + StagReg, StagLoc, VarRval, MaybeFailLabel, TagCode, + !CaseLabelMap, !CI), + ElseCode = node([ + llds_instr(label(ElseLabel), "handle next primary tag") + ]), + Code = tree_list([TestCode, TagCode, ElseCode]). + %-----------------------------------------------------------------------------% % Generate a switch on a primary tag value using a try chain. % -:- pred generate_primary_try_chain(ptag_case_list::in, - rval::in, rval::in, code_model::in, can_fail::in, hlds_goal_info::in, - label::in, label::in, ptag_count_map::in, code_tree::in, code_tree::in, - branch_end::in, branch_end::out, code_tree::out, +:- pred generate_primary_try_chain(ptag_case_list(label)::in, + rval::in, lval::in, rval::in, maybe(label)::in, + ptag_count_map::in, code_tree::in, code_tree::in, code_tree::out, + case_label_map::in, case_label_map::out, code_info::in, code_info::out) is det. -generate_primary_try_chain([], _, _, _, _, _, _, _, _, _, _, _, _, _, !CI) :- +generate_primary_try_chain([], _, _, _, _, _, _, _, _, !CaseLabelMap, !CI) :- unexpected(this_file, "empty list in generate_primary_try_chain"). -generate_primary_try_chain([PtagGroup | PtagGroups], TagRval, VarRval, - CodeModel, CanFail, SwitchGoalInfo, EndLabel, FailLabel, PtagCountMap, - PrevTests0, PrevCases0, !MaybeEnd, Code, !CI) :- - PtagGroup = Primary - ptag_case(StagLoc, StagGoalMap), +generate_primary_try_chain([PtagGroup | PtagGroups], PtagRval, StagReg, + VarRval, MaybeFailLabel, PtagCountMap, PrevTestsCode0, PrevCasesCode0, + Code, !CaseLabelMap, !CI) :- + PtagGroup = Primary - PtagCase, + PtagCase = ptag_case(StagLoc, StagGoalMap), map.lookup(PtagCountMap, Primary, CountInfo), - CountInfo = StagLoc1 - MaxSecondary, - expect(unify(StagLoc, StagLoc1), this_file, + CountInfo = StagLocPrime - MaxSecondary, + expect(unify(StagLoc, StagLocPrime), this_file, "secondary tag locations differ in generate_primary_try_chain"), ( - ( PtagGroups = [_ | _] - ; CanFail = can_fail - ) - -> - remember_position(!.CI, BranchStart), - get_next_label(ThisPtagLabel, !CI), - TestRval = binop(eq, TagRval, - unop(mktag, const(llconst_int(Primary)))), - TestCode = node([ - llds_instr(if_val(TestRval, code_label(ThisPtagLabel)), - "test primary tag only") - ]), - LabelCode = node([ - llds_instr(label(ThisPtagLabel), "this primary tag") - ]), - generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, StagLoc, - VarRval, CodeModel, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, - TagCode, !CI), - PrevTests = tree(PrevTests0, TestCode), - PrevCases = tree(tree(LabelCode, TagCode), PrevCases0), + PtagGroups = [_ | _], + generate_primary_try_chain_case(PtagRval, StagReg, Primary, + PtagCase, MaxSecondary, VarRval, MaybeFailLabel, + PrevTestsCode0, PrevTestsCode1, PrevCasesCode0, PrevCasesCode1, + !CaseLabelMap, !CI), + generate_primary_try_chain(PtagGroups, PtagRval, StagReg, VarRval, + MaybeFailLabel, PtagCountMap, PrevTestsCode1, PrevCasesCode1, + Code, !CaseLabelMap, !CI) + ; + PtagGroups = [], ( - PtagGroups = [_ | _], - reset_to_position(BranchStart, !CI), - generate_primary_try_chain(PtagGroups, TagRval, VarRval, CodeModel, - CanFail, SwitchGoalInfo, EndLabel, FailLabel, PtagCountMap, - PrevTests, PrevCases, !MaybeEnd, Code, !CI) - ; - PtagGroups = [], + MaybeFailLabel = yes(FailLabel), + generate_primary_try_chain_case(PtagRval, StagReg, Primary, + PtagCase, MaxSecondary, VarRval, MaybeFailLabel, + PrevTestsCode0, PrevTestsCode1, PrevCasesCode0, PrevCasesCode1, + !CaseLabelMap, !CI), FailCode = node([ llds_instr(goto(code_label(FailLabel)), "primary tag with no code to handle it") ]), - Code = tree(PrevTests, tree(FailCode, PrevCases)) + Code = tree_list([PrevTestsCode1, FailCode, PrevCasesCode1]) + ; + MaybeFailLabel = no, + Comment = "fallthrough to last primary tag value: " ++ + string.int_to_string(Primary), + CommentCode = node([ + llds_instr(comment(Comment), "") + ]), + generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, + StagReg, StagLoc, VarRval, MaybeFailLabel, TagCode, + !CaseLabelMap, !CI), + Code = tree_list([PrevTestsCode0, CommentCode, + TagCode, PrevCasesCode0]) ) - ; - Comment = node([ - llds_instr(comment("fallthrough to last tag value"), "") - ]), - generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, StagLoc, - VarRval, CodeModel, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, - TagCode, !CI), - Code = tree_list([PrevTests0, Comment, TagCode, PrevCases0]) ). +:- pred generate_primary_try_chain_case(rval::in, lval::in, int::in, + ptag_case(label)::in, int::in, rval::in, maybe(label)::in, + code_tree::in, code_tree::out, code_tree::in, code_tree::out, + case_label_map::in, case_label_map::out, + code_info::in, code_info::out) is det. + +generate_primary_try_chain_case(PtagRval, StagReg, Primary, PtagCase, + MaxSecondary, VarRval, MaybeFailLabel, + PrevTestsCode0, PrevTestsCode, PrevCasesCode0, PrevCasesCode, + !CaseLabelMap, !CI) :- + get_next_label(ThisPtagLabel, !CI), + TestRval = binop(eq, PtagRval, + unop(mktag, const(llconst_int(Primary)))), + TestCode = node([ + llds_instr(if_val(TestRval, code_label(ThisPtagLabel)), + "test primary tag only") + ]), + Comment = "primary tag value: " ++ string.int_to_string(Primary), + LabelCode = node([ + llds_instr(label(ThisPtagLabel), Comment) + ]), + PtagCase = ptag_case(StagLoc, StagGoalMap), + generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, + StagReg, StagLoc, VarRval, MaybeFailLabel, TagCode, + !CaseLabelMap, !CI), + PrevTestsCode = tree(PrevTestsCode0, TestCode), + PrevCasesCode = tree_list([LabelCode, TagCode, PrevCasesCode0]). + %-----------------------------------------------------------------------------% % Generate the cases for a primary tag using a dense jump table % that has an entry for all possible primary tag values. % -:- pred generate_primary_jump_table(ptag_case_list::in, int::in, - int::in, rval::in, code_model::in, hlds_goal_info::in, - label::in, label::in, ptag_count_map::in, - branch_end::in, branch_end::out, list(label)::out, code_tree::out, +:- pred generate_primary_jump_table(ptag_case_list(label)::in, int::in, + int::in, lval::in, rval::in, maybe(label)::in, ptag_count_map::in, + list(maybe(label))::out, code_tree::out, + case_label_map::in, case_label_map::out, code_info::in, code_info::out) is det. -generate_primary_jump_table(PtagGroups, CurPrimary, MaxPrimary, VarRval, - CodeModel, SwitchGoalInfo, EndLabel, FailLabel, PtagCountMap, - !MaybeEnd, Labels, Code, !CI) :- +generate_primary_jump_table(PtagGroups, CurPrimary, MaxPrimary, StagReg, + VarRval, MaybeFailLabel, PtagCountMap, Targets, Code, + !CaseLabelMap, !CI) :- ( CurPrimary > MaxPrimary -> - ( - PtagGroups = [] - ; - PtagGroups = [_ | _], - unexpected(this_file, - "generate_primary_jump_table: " ++ - "caselist not empty when reaching limiting primary tag") - ), - Labels = [], + expect(unify(PtagGroups, []), this_file, + "generate_primary_jump_table: PtagGroups != [] when Cur > Max"), + Targets = [], Code = empty ; NextPrimary = CurPrimary + 1, - ( PtagGroups = [CurPrimary - PrimaryInfo | PtagGroups1] -> + ( PtagGroups = [CurPrimary - PrimaryInfo | PtagGroupsTail] -> PrimaryInfo = ptag_case(StagLoc, StagGoalMap), map.lookup(PtagCountMap, CurPrimary, CountInfo), - CountInfo = StagLoc1 - MaxSecondary, - expect(unify(StagLoc, StagLoc1), this_file, + CountInfo = StagLocPrime - MaxSecondary, + expect(unify(StagLoc, StagLocPrime), this_file, "secondary tag locations differ " ++ "in generate_primary_jump_table"), get_next_label(NewLabel, !CI), @@ -490,29 +529,20 @@ generate_primary_jump_table(PtagGroups, CurPrimary, MaxPrimary, VarRval, llds_instr(label(NewLabel), "start of a case in primary tag switch") ]), - ( - PtagGroups1 = [], - generate_primary_tag_code(StagGoalMap, CurPrimary, - MaxSecondary, StagLoc, VarRval, CodeModel, SwitchGoalInfo, - EndLabel, FailLabel, !MaybeEnd, ThisTagCode, !CI) - ; - PtagGroups1 = [_ | _], - remember_position(!.CI, BranchStart), - generate_primary_tag_code(StagGoalMap, CurPrimary, - MaxSecondary, StagLoc, VarRval, CodeModel, SwitchGoalInfo, - EndLabel, FailLabel, !MaybeEnd, ThisTagCode, !CI), - reset_to_position(BranchStart, !CI) - ), - generate_primary_jump_table(PtagGroups1, NextPrimary, MaxPrimary, - VarRval, CodeModel, SwitchGoalInfo, EndLabel, FailLabel, - PtagCountMap, !MaybeEnd, OtherLabels, OtherCode, !CI), - Labels = [NewLabel | OtherLabels], - Code = tree_list([LabelCode, ThisTagCode, OtherCode]) + generate_primary_tag_code(StagGoalMap, CurPrimary, MaxSecondary, + StagReg, StagLoc, VarRval, MaybeFailLabel, ThisTagCode, + !CaseLabelMap, !CI), + generate_primary_jump_table(PtagGroupsTail, NextPrimary, + MaxPrimary, StagReg, VarRval, MaybeFailLabel, PtagCountMap, + TailTargets, TailCode, !CaseLabelMap, !CI), + Targets = [yes(NewLabel) | TailTargets], + Code = tree_list([LabelCode, ThisTagCode, TailCode]) ; generate_primary_jump_table(PtagGroups, NextPrimary, MaxPrimary, - VarRval, CodeModel, SwitchGoalInfo, EndLabel, FailLabel, - PtagCountMap, !MaybeEnd, OtherLabels, Code, !CI), - Labels = [FailLabel | OtherLabels] + StagReg, VarRval, MaybeFailLabel, PtagCountMap, + TailTargets, TailCode, !CaseLabelMap, !CI), + Targets = [MaybeFailLabel | TailTargets], + Code = TailCode ) ). @@ -522,27 +552,28 @@ generate_primary_jump_table(PtagGroups, CurPrimary, MaxPrimary, VarRval, % This invocation looks after primary tag values in the range % MinPtag to MaxPtag (including both boundary values). % -:- pred generate_primary_binary_search(ptag_case_list::in, int::in, - int::in, rval::in, rval::in, code_model::in, can_fail::in, - hlds_goal_info::in, label::in, label::in, ptag_count_map::in, - branch_end::in, branch_end::out, code_tree::out, +:- pred generate_primary_binary_search(ptag_case_list(label)::in, int::in, + int::in, rval::in, lval::in, rval::in, maybe(label)::in, + ptag_count_map::in, code_tree::out, + case_label_map::in, case_label_map::out, code_info::in, code_info::out) is det. -generate_primary_binary_search(PtagGroups, MinPtag, MaxPtag, PtagRval, VarRval, - CodeModel, CanFail, SwitchGoalInfo, EndLabel, FailLabel, PtagCountMap, - !MaybeEnd, Code, !CI) :- +generate_primary_binary_search(PtagGroups, MinPtag, MaxPtag, PtagRval, StagReg, + VarRval, MaybeFailLabel, PtagCountMap, Code, !CaseLabelMap, !CI) :- ( MinPtag = MaxPtag -> CurPrimary = MinPtag, ( PtagGroups = [], % There is no code for this tag. ( - CanFail = can_fail, + MaybeFailLabel = yes(FailLabel), string.int_to_string(CurPrimary, PtagStr), - string.append("no code for ptag ", PtagStr, Comment), + Comment = "no code for ptag " ++ PtagStr, Code = node([llds_instr(goto(code_label(FailLabel)), Comment)]) ; - CanFail = cannot_fail, + MaybeFailLabel = no, + % The switch is cannot_fail, which means this case cannot + % happen. Code = empty ) ; @@ -551,13 +582,12 @@ generate_primary_binary_search(PtagGroups, MinPtag, MaxPtag, PtagRval, VarRval, "generate_primary_binary_search: cur_primary mismatch"), PrimaryInfo = ptag_case(StagLoc, StagGoalMap), map.lookup(PtagCountMap, CurPrimary, CountInfo), - CountInfo = StagLoc1 - MaxSecondary, - expect(unify(StagLoc, StagLoc1), this_file, - "secondary tag locations differ " ++ - "in generate_primary_jump_table"), + CountInfo = StagLocPrime - MaxSecondary, + expect(unify(StagLoc, StagLocPrime), this_file, + "generate_primary_jump_table: secondary tag locations differ"), generate_primary_tag_code(StagGoalMap, CurPrimary, MaxSecondary, - StagLoc, VarRval, CodeModel, SwitchGoalInfo, - EndLabel, FailLabel, !MaybeEnd, Code, !CI) + StagReg, StagLoc, VarRval, MaybeFailLabel, Code, + !CaseLabelMap, !CI) ; PtagGroups = [_, _ | _], unexpected(this_file, @@ -576,10 +606,10 @@ generate_primary_binary_search(PtagGroups, MinPtag, MaxPtag, PtagRval, VarRval, string.int_to_string(LowRangeEnd, LowEndStr), string.int_to_string(HighRangeStart, HighStartStr), string.int_to_string(MaxPtag, HighEndStr), - IfComment = "fallthrough for ptags " ++ LowStartStr ++ - " to " ++ LowEndStr, - LabelComment = "code for ptags " ++ HighStartStr ++ - " to " ++ HighEndStr, + IfComment = "fallthrough for ptags " ++ + LowStartStr ++ " to " ++ LowEndStr, + LabelComment = "code for ptags " ++ + HighStartStr ++ " to " ++ HighEndStr, LowRangeEndConst = const(llconst_int(LowRangeEnd)), TestRval = binop(int_gt, PtagRval, LowRangeEndConst), IfCode = node([ @@ -587,15 +617,12 @@ generate_primary_binary_search(PtagGroups, MinPtag, MaxPtag, PtagRval, VarRval, ]), LabelCode = node([llds_instr(label(NewLabel), LabelComment)]), - remember_position(!.CI, BranchStart), generate_primary_binary_search(LowGroups, MinPtag, LowRangeEnd, - PtagRval, VarRval, CodeModel, CanFail, SwitchGoalInfo, - EndLabel, FailLabel, PtagCountMap, !MaybeEnd, LowRangeCode, !CI), - reset_to_position(BranchStart, !CI), + PtagRval, StagReg, VarRval, MaybeFailLabel, PtagCountMap, + LowRangeCode, !CaseLabelMap, !CI), generate_primary_binary_search(HighGroups, HighRangeStart, MaxPtag, - PtagRval, VarRval, CodeModel, CanFail, SwitchGoalInfo, - EndLabel, FailLabel, PtagCountMap, !MaybeEnd, HighRangeCode, !CI), - + PtagRval, StagReg, VarRval, MaybeFailLabel, PtagCountMap, + HighRangeCode, !CaseLabelMap, !CI), Code = tree_list([IfCode, LowRangeCode, LabelCode, HighRangeCode]) ). @@ -605,14 +632,13 @@ generate_primary_binary_search(PtagGroups, MinPtag, MaxPtag, PtagRval, VarRval, % If this primary tag has secondary tags, decide whether we should % use a jump table to implement the secondary switch. % -:- pred generate_primary_tag_code(stag_goal_map::in, tag_bits::in, - int::in, sectag_locn::in, rval::in, code_model::in, hlds_goal_info::in, - label::in, label::in, branch_end::in, branch_end::out, code_tree::out, +:- pred generate_primary_tag_code(stag_goal_map(label)::in, tag_bits::in, + int::in, lval::in, sectag_locn::in, rval::in, maybe(label)::in, + code_tree::out, case_label_map::in, case_label_map::out, code_info::in, code_info::out) is det. -generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, StagLoc, Rval, - CodeModel, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, Code, - !CI) :- +generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, StagReg, StagLoc, + Rval, MaybeFailLabel, Code, !CaseLabelMap, !CI) :- map.to_assoc_list(StagGoalMap, StagGoalList), ( StagLoc = sectag_none, @@ -622,20 +648,8 @@ generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, StagLoc, Rval, unexpected(this_file, "no goal for non-shared tag") ; StagGoalList = [StagGoal], - ( StagGoal = -1 - stag_goal(ConsId, Goal) -> - Comment = "case " ++ cons_id_to_string(ConsId), - CommentCode = node([llds_instr(comment(Comment), "")]), - maybe_generate_internal_event_code(Goal, SwitchGoalInfo, - TraceCode, !CI), - code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), - goal_info_get_store_map(SwitchGoalInfo, StoreMap), - generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), - GotoCode = node([ - llds_instr(goto(code_label(EndLabel)), - "skip to end of primary tag switch") - ]), - Code = tree_list([CommentCode, TraceCode, GoalCode, SaveCode, - GotoCode]) + ( StagGoal = -1 - CaseLabel -> + generate_case_code_or_jump(CaseLabel, Code, !CaseLabelMap) ; unexpected(this_file, "badly formed goal for non-shared tag") ) @@ -676,8 +690,6 @@ generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, StagLoc, Rval, Comment = "compute local sec tag to switch on" ), - acquire_reg(reg_r, StagReg, !CI), - release_reg(StagReg, !CI), ( SecondaryMethod \= jump_table, MaxSecondary >= 2, @@ -701,41 +713,42 @@ generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, StagLoc, Rval, StagRval = OrigStagRval ), ( - list.length(StagGoalList, StagGoalCount), - FullGoalCount = MaxSecondary + 1, - FullGoalCount = StagGoalCount - -> - CanFail = cannot_fail + MaybeFailLabel = yes(FailLabel), + ( + list.length(StagGoalList, StagGoalCount), + FullGoalCount = MaxSecondary + 1, + FullGoalCount = StagGoalCount + -> + MaybeSecFailLabel = no + ; + MaybeSecFailLabel = yes(FailLabel) + ) ; - CanFail = can_fail + MaybeFailLabel = no, + MaybeSecFailLabel = no ), ( SecondaryMethod = jump_table, generate_secondary_jump_table(StagGoalList, 0, MaxSecondary, - CodeModel, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, - Labels, CasesCode, !CI), - SwitchCode = node([ - llds_instr(computed_goto(StagRval, Labels), + MaybeSecFailLabel, Targets), + Code = node([ + llds_instr(computed_goto(StagRval, Targets), "switch on secondary tag") - ]), - Code = tree(SwitchCode, CasesCode) + ]) ; SecondaryMethod = binary_search, generate_secondary_binary_search(StagGoalList, 0, MaxSecondary, - StagRval, CodeModel, CanFail, SwitchGoalInfo, - EndLabel, FailLabel, !MaybeEnd, Code, !CI) + StagRval, MaybeSecFailLabel, Code, !CaseLabelMap, !CI) ; SecondaryMethod = try_chain, - generate_secondary_try_chain(StagGoalList, StagRval, CodeModel, - CanFail, SwitchGoalInfo, EndLabel, FailLabel, empty, empty, - !MaybeEnd, Codes, !CI), + generate_secondary_try_chain(StagGoalList, StagRval, + MaybeSecFailLabel, empty, Codes, !CaseLabelMap), Code = tree(StagCode, Codes) ; SecondaryMethod = try_me_else_chain, generate_secondary_try_me_else_chain(StagGoalList, StagRval, - CodeModel, CanFail, SwitchGoalInfo, EndLabel, FailLabel, - !MaybeEnd, Codes, !CI), + MaybeSecFailLabel, Codes, !CaseLabelMap, !CI), Code = tree(StagCode, Codes) ) ). @@ -744,199 +757,137 @@ generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, StagLoc, Rval, % Generate a switch on a secondary tag value using a try-me-else chain. % -:- pred generate_secondary_try_me_else_chain(stag_goal_list::in, - rval::in, code_model::in, can_fail::in, hlds_goal_info::in, - label::in, label::in, branch_end::in, branch_end::out, code_tree::out, +:- pred generate_secondary_try_me_else_chain(stag_goal_list(label)::in, + rval::in, maybe(label)::in, code_tree::out, + case_label_map::in, case_label_map::out, code_info::in, code_info::out) is det. -generate_secondary_try_me_else_chain([], _, _, _, _, _, _, _, _, _, !CI) :- +generate_secondary_try_me_else_chain([], _, _, _, !CaseLabelMap, !CI) :- unexpected(this_file, "generate_secondary_try_me_else_chain: empty switch"). -generate_secondary_try_me_else_chain([Case0 | Cases0], StagRval, CodeModel, - CanFail, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, Code, !CI) :- - Case0 = Secondary - stag_goal(ConsId, Goal), - Comment = "case " ++ cons_id_to_string(ConsId), - CommentCode = node([llds_instr(comment(Comment), "")]), - goal_info_get_store_map(SwitchGoalInfo, StoreMap), +generate_secondary_try_me_else_chain([Case | Cases], StagRval, + MaybeFailLabel, Code, !CaseLabelMap, !CI) :- + Case = Secondary - CaseLabel, ( - ( Cases0 = [_ | _] - ; CanFail = can_fail - ) - -> - remember_position(!.CI, BranchStart), - get_next_label(ElseLabel, !CI), - TestCode = node([ - llds_instr( - if_val(binop(ne, StagRval, const(llconst_int(Secondary))), - code_label(ElseLabel)), - "test remote sec tag only") - ]), - maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, - !CI), - code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), - generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), - GotoLabelCode = node([ - llds_instr(goto(code_label(EndLabel)), - "skip to end of secondary tag switch"), - llds_instr(label(ElseLabel), "handle next secondary tag") - ]), - ThisCode = tree_list([TestCode, CommentCode, TraceCode, GoalCode, - SaveCode, GotoLabelCode]), + Cases = [_ | _], + generate_secondary_try_me_else_chain_case(CaseLabel, StagRval, + Secondary, ThisCode, !CaseLabelMap, !CI), + generate_secondary_try_me_else_chain(Cases, StagRval, + MaybeFailLabel, OtherCode, !CaseLabelMap, !CI), + Code = tree(ThisCode, OtherCode) + ; + Cases = [], ( - Cases0 = [_ | _], - reset_to_position(BranchStart, !CI), - generate_secondary_try_me_else_chain(Cases0, StagRval, CodeModel, - CanFail, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, - OtherCode, !CI), - Code = tree(ThisCode, OtherCode) - ; - Cases0 = [], + MaybeFailLabel = yes(FailLabel), + generate_secondary_try_me_else_chain_case(CaseLabel, StagRval, + Secondary, ThisCode, !CaseLabelMap, !CI), FailCode = node([ llds_instr(goto(code_label(FailLabel)), "secondary tag does not match") ]), Code = tree(ThisCode, FailCode) + ; + MaybeFailLabel = no, + generate_case_code_or_jump(CaseLabel, Code, !CaseLabelMap) ) - ; - maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, - !CI), - code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), - generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), - GotoCode = node([ - llds_instr(goto(code_label(EndLabel)), - "skip to end of secondary tag switch") - ]), - Code = tree_list([CommentCode, TraceCode, GoalCode, SaveCode, - GotoCode]) ). +:- pred generate_secondary_try_me_else_chain_case(label::in, rval::in, int::in, + code_tree::out, case_label_map::in, case_label_map::out, + code_info::in, code_info::out) is det. + +generate_secondary_try_me_else_chain_case(CaseLabel, StagRval, Secondary, + Code, !CaseLabelMap, !CI) :- + generate_case_code_or_jump(CaseLabel, CaseCode, !CaseLabelMap), + % XXX Optimize what we generate when CaseCode = goto(CaseLabel). + get_next_label(ElseLabel, !CI), + TestCode = node([ + llds_instr( + if_val(binop(ne, StagRval, const(llconst_int(Secondary))), + code_label(ElseLabel)), + "test remote sec tag only") + ]), + ElseLabelCode = node([ + llds_instr(label(ElseLabel), "handle next secondary tag") + ]), + Code = tree_list([TestCode, CaseCode, ElseLabelCode]). + %-----------------------------------------------------------------------------% % Generate a switch on a secondary tag value using a try chain. % -:- pred generate_secondary_try_chain(stag_goal_list::in, rval::in, - code_model::in, can_fail::in, hlds_goal_info::in, label::in, label::in, - code_tree::in, code_tree::in, branch_end::in, branch_end::out, - code_tree::out, code_info::in, code_info::out) is det. +:- pred generate_secondary_try_chain(stag_goal_list(label)::in, rval::in, + maybe(label)::in, code_tree::in, code_tree::out, + case_label_map::in, case_label_map::out) is det. -generate_secondary_try_chain([], _, _, _, _, _, _, _, _, _, _, _, !CI) :- +generate_secondary_try_chain([], _, _, _, _, !CaseLabelMap) :- unexpected(this_file, "generate_secondary_try_chain: empty switch"). -generate_secondary_try_chain([Case0 | Cases0], StagRval, CodeModel, CanFail, - SwitchGoalInfo, EndLabel, FailLabel, PrevTests0, PrevCases0, !MaybeEnd, - Code, !CI) :- - Case0 = Secondary - stag_goal(ConsId, Goal), - Comment = "case " ++ cons_id_to_string(ConsId), - goal_info_get_store_map(SwitchGoalInfo, StoreMap), +generate_secondary_try_chain([Case | Cases], StagRval, MaybeFailLabel, + PrevTestsCode0, Code, !CaseLabelMap) :- + Case = Secondary - CaseLabel, ( - ( Cases0 = [_ | _] - ; CanFail = can_fail - ) - -> - remember_position(!.CI, BranchStart), - get_next_label(ThisStagLabel, !CI), - TestCode = node([ - llds_instr( - if_val(binop(eq, StagRval, const(llconst_int(Secondary))), - code_label(ThisStagLabel)), - "test remote sec tag only for " ++ Comment) - ]), - LabelCode = node([ - llds_instr(label(ThisStagLabel), - "handle next secondary tag for " ++ Comment) - ]), - maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, - !CI), - code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), - generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), - GotoCode = node([ - llds_instr(goto(code_label(EndLabel)), - "skip to end of secondary tag switch") - ]), - ThisCode = tree_list([LabelCode, TraceCode, GoalCode, SaveCode, - GotoCode]), - PrevTests = tree(PrevTests0, TestCode), - PrevCases = tree(ThisCode, PrevCases0), + Cases = [_ | _], + generate_secondary_try_chain_case(CaseLabel, StagRval, Secondary, + PrevTestsCode0, PrevTestsCode1, !.CaseLabelMap), + generate_secondary_try_chain(Cases, StagRval, + MaybeFailLabel, PrevTestsCode1, Code, !CaseLabelMap) + ; + Cases = [], ( - Cases0 = [_ | _], - reset_to_position(BranchStart, !CI), - generate_secondary_try_chain(Cases0, StagRval, CodeModel, CanFail, - SwitchGoalInfo, EndLabel, FailLabel, PrevTests, PrevCases, - !MaybeEnd, Code, !CI) - ; - Cases0 = [], + MaybeFailLabel = yes(FailLabel), + generate_secondary_try_chain_case(CaseLabel, StagRval, Secondary, + PrevTestsCode0, PrevTestsCode1, !.CaseLabelMap), FailCode = node([ llds_instr(goto(code_label(FailLabel)), "secondary tag with no code to handle it") ]), - Code = tree(PrevTests, tree(FailCode, PrevCases)) + Code = tree(PrevTestsCode1, FailCode) + ; + MaybeFailLabel = no, + generate_case_code_or_jump(CaseLabel, ThisCode, !CaseLabelMap), + Code = tree(PrevTestsCode0, ThisCode) ) - ; - CommentCode = node([llds_instr(comment(Comment), "")]), - maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, - !CI), - code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), - generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), - GotoCode = node([ - llds_instr(goto(code_label(EndLabel)), - "skip to end of secondary tag switch") - ]), - Code = tree_list([PrevTests0, CommentCode, TraceCode, GoalCode, - SaveCode, GotoCode, PrevCases0]) ). +:- pred generate_secondary_try_chain_case(label::in, rval::in, int::in, + code_tree::in, code_tree::out, case_label_map::in) is det. + +generate_secondary_try_chain_case(CaseLabel, StagRval, Secondary, + PrevTestsCode0, PrevTestsCode, CaseLabelMap) :- + map.lookup(CaseLabelMap, CaseLabel, CaseInfo0), + CaseInfo0 = case_label_info(Comment, _CaseCode, _CaseGenerated), + TestCode = node([ + llds_instr( + if_val(binop(eq, StagRval, const(llconst_int(Secondary))), + code_label(CaseLabel)), + "test remote sec tag only for " ++ Comment) + ]), + PrevTestsCode = tree(PrevTestsCode0, TestCode). + %-----------------------------------------------------------------------------% % Generate the cases for a primary tag using a dense jump table % that has an entry for all possible secondary tag values. % -:- pred generate_secondary_jump_table(stag_goal_list::in, int::in, - int::in, code_model::in, hlds_goal_info::in, label::in, label::in, - branch_end::in, branch_end::out, list(label)::out, code_tree::out, - code_info::in, code_info::out) is det. +:- pred generate_secondary_jump_table(stag_goal_list(label)::in, int::in, + int::in, maybe(label)::in, list(maybe(label))::out) is det. -generate_secondary_jump_table(CaseList, CurSecondary, MaxSecondary, CodeModel, - SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, Labels, Code, !CI) :- +generate_secondary_jump_table(CaseList, CurSecondary, MaxSecondary, + MaybeFailLabel, Targets) :- ( CurSecondary > MaxSecondary -> expect(unify(CaseList, []), this_file, "caselist not empty when reaching limiting secondary tag"), - Labels = [], - Code = empty + Targets = [] ; NextSecondary = CurSecondary + 1, - ( CaseList = [CurSecondary - stag_goal(ConsId, Goal) | CaseList1] -> - Comment = "case " ++ cons_id_to_string(ConsId), - get_next_label(NewLabel, !CI), - LabelCode = node([ - llds_instr(label(NewLabel), - "start of " ++ Comment ++ " in secondary tag switch") - ]), - remember_position(!.CI, BranchStart), - maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, - !CI), - code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), - goal_info_get_store_map(SwitchGoalInfo, StoreMap), - generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), - ( - CaseList1 = [] - ; - CaseList1 = [_ | _], - reset_to_position(BranchStart, !CI) - ), - GotoCode = node([ - llds_instr(goto(code_label(EndLabel)), - "branch to end of tag switch") - ]), - generate_secondary_jump_table(CaseList1, NextSecondary, - MaxSecondary, CodeModel, SwitchGoalInfo, EndLabel, FailLabel, - !MaybeEnd, OtherLabels, OtherCode, !CI), - Labels = [NewLabel | OtherLabels], - Code = tree_list([LabelCode, TraceCode, GoalCode, SaveCode, - GotoCode, OtherCode]) + ( CaseList = [CurSecondary - CaseLabel | CaseListTail] -> + generate_secondary_jump_table(CaseListTail, NextSecondary, + MaxSecondary, MaybeFailLabel, OtherTargets), + Targets = [yes(CaseLabel) | OtherTargets] ; - generate_secondary_jump_table(CaseList, - NextSecondary, MaxSecondary, CodeModel, SwitchGoalInfo, - EndLabel, FailLabel, !MaybeEnd, OtherLabels, Code, !CI), - Labels = [FailLabel | OtherLabels] + generate_secondary_jump_table(CaseList, NextSecondary, + MaxSecondary, MaybeFailLabel, OtherTargets), + Targets = [MaybeFailLabel | OtherTargets] ) ). @@ -946,41 +897,32 @@ generate_secondary_jump_table(CaseList, CurSecondary, MaxSecondary, CodeModel, % This invocation looks after secondary tag values in the range % MinPtag to MaxPtag (including both boundary values). % -:- pred generate_secondary_binary_search(stag_goal_list::in, - int::in, int::in, rval::in, code_model::in, can_fail::in, - hlds_goal_info::in, label::in, label::in, - branch_end::in, branch_end::out, code_tree::out, +:- pred generate_secondary_binary_search(stag_goal_list(label)::in, + int::in, int::in, rval::in, maybe(label)::in, code_tree::out, + case_label_map::in, case_label_map::out, code_info::in, code_info::out) is det. generate_secondary_binary_search(StagGoals, MinStag, MaxStag, StagRval, - CodeModel, CanFail, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, - Code, !CI) :- + MaybeFailLabel, Code, !CaseLabelMap, !CI) :- ( MinStag = MaxStag -> CurSec = MinStag, ( StagGoals = [], % There is no code for this tag. ( - CanFail = can_fail, + MaybeFailLabel = yes(FailLabel), string.int_to_string(CurSec, StagStr), - string.append("no code for ptag ", StagStr, Comment), + Comment = "no code for ptag " ++ StagStr, Code = node([llds_instr(goto(code_label(FailLabel)), Comment)]) ; - CanFail = cannot_fail, + MaybeFailLabel = no, Code = empty ) ; - StagGoals = [CurSecPrime - stag_goal(ConsId, Goal)], - Comment = "case " ++ cons_id_to_string(ConsId), - CommentCode = node([llds_instr(comment(Comment), "")]), + StagGoals = [CurSecPrime - CaseLabel], expect(unify(CurSec, CurSecPrime), this_file, "generate_secondary_binary_search: cur_secondary mismatch"), - maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode, - !CI), - code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI), - goal_info_get_store_map(SwitchGoalInfo, StoreMap), - generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI), - Code = tree_list([CommentCode, TraceCode, GoalCode, SaveCode]) + generate_case_code_or_jump(CaseLabel, Code, !CaseLabelMap) ; StagGoals = [_, _ | _], unexpected(this_file, @@ -1000,10 +942,10 @@ generate_secondary_binary_search(StagGoals, MinStag, MaxStag, StagRval, string.int_to_string(LowRangeEnd, LowEndStr), string.int_to_string(HighRangeStart, HighStartStr), string.int_to_string(MaxStag, HighEndStr), - string.append_list(["fallthrough for stags ", - LowStartStr, " to ", LowEndStr], IfComment), - string.append_list(["code for stags ", HighStartStr, - " to ", HighEndStr], LabelComment), + IfComment = "fallthrough for stags " ++ + LowStartStr ++ " to " ++ LowEndStr, + LabelComment = "code for stags " ++ + HighStartStr ++ " to " ++ HighEndStr, LowRangeEndConst = const(llconst_int(LowRangeEnd)), TestRval = binop(int_gt, StagRval, LowRangeEndConst), IfCode = node([ @@ -1011,14 +953,10 @@ generate_secondary_binary_search(StagGoals, MinStag, MaxStag, StagRval, ]), LabelCode = node([llds_instr(label(NewLabel), LabelComment)]), - remember_position(!.CI, BranchStart), generate_secondary_binary_search(LowGoals, MinStag, LowRangeEnd, - StagRval, CodeModel, CanFail, SwitchGoalInfo, EndLabel, FailLabel, - !MaybeEnd, LowRangeCode, !CI), - reset_to_position(BranchStart, !CI), + StagRval, MaybeFailLabel, LowRangeCode, !CaseLabelMap, !CI), generate_secondary_binary_search(HighGoals, HighRangeStart, MaxStag, - StagRval, CodeModel, CanFail, SwitchGoalInfo, EndLabel, FailLabel, - !MaybeEnd, HighRangeCode, !CI), + StagRval, MaybeFailLabel, HighRangeCode, !CaseLabelMap, !CI), Code = tree_list([IfCode, LowRangeCode, LabelCode, HighRangeCode]) ). diff --git a/compiler/term_constr_build.m b/compiler/term_constr_build.m index 9bb23a582..f1cfe6dc6 100644 --- a/compiler/term_constr_build.m +++ b/compiler/term_constr_build.m @@ -5,25 +5,25 @@ % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %------------------------------------------------------------------------------% -% +% % File: term_constr_build.m. % Main author: juliensf. % (partially based on code written by vjteag) -% +% % This module is responsible for building the abstract representation (AR) % used by the constraint termination analyser. -% (The AR is defined in term_constr_data.m). +% (The AR is defined in term_constr_data.m). % % TODO: make the resulting abstract representations more independent of the % HLDS. -% +% %------------------------------------------------------------------------------% :- module transform_hlds.term_constr_build. :- interface. -:- import_module hlds.hlds_module. -:- import_module hlds.hlds_pred. +:- import_module hlds.hlds_module. +:- import_module hlds.hlds_pred. :- import_module transform_hlds.term_constr_errors. :- import_module transform_hlds.term_norm. @@ -44,7 +44,7 @@ % failure constraints and no otherwise; `ArgSizeOnly' is `yes' % if the `--arg-size-analysis-only' option is enabled and `no' % otherwise. - % + % :- func build_options_init(functor_info, bool, bool) = build_options. % Builds the abstract representation of an SCC. @@ -59,15 +59,15 @@ :- implementation. :- import_module check_hlds.mode_util. -:- import_module check_hlds.type_util. -:- import_module hlds.goal_util. -:- import_module hlds.hlds_goal. -:- import_module hlds.quantification. +:- import_module check_hlds.type_util. +:- import_module hlds.goal_util. +:- import_module hlds.hlds_goal. +:- import_module hlds.quantification. :- import_module libs.compiler_util. -:- import_module libs.lp_rational. +:- import_module libs.lp_rational. :- import_module libs.polyhedron. :- import_module libs.rat. -:- import_module parse_tree.prog_data. +:- import_module parse_tree.prog_data. :- import_module parse_tree.prog_type. :- import_module transform_hlds.dependency_graph. :- import_module transform_hlds.term_constr_data. @@ -96,17 +96,17 @@ ---> build_options( functor_info :: functor_info, % Which norm we are using. - + failure_constrs :: bool, % Whether we are propagating failure % constraints is enabled. - + arg_size_only :: bool % Whether the `--term2-arg-size-only' % is enabled. ). -build_options_init(Norm, Failure, ArgSizeOnly) = +build_options_init(Norm, Failure, ArgSizeOnly) = build_options(Norm, Failure, ArgSizeOnly). %-----------------------------------------------------------------------------% @@ -117,12 +117,12 @@ build_options_init(Norm, Failure, ArgSizeOnly) = % procedure because we will not have all the information we need until % we have finished processing the entire SCC. -:- type scc_info +:- type scc_info ---> scc_info( - scc_ppid :: pred_proc_id, - proc :: abstract_proc, + scc_ppid :: pred_proc_id, + proc :: abstract_proc, size_var_map :: size_var_map, - intermod :: intermod_status, + intermod :: intermod_status, accum_errors :: term2_errors, non_zero_heads :: list(size_var) ). @@ -131,14 +131,14 @@ build_options_init(Norm, Failure, ArgSizeOnly) = build_abstract_scc(DepOrder, SCC, Options, Errors, !Module, !IO) :- dependency_graph.get_scc_entry_points(SCC, DepOrder, !.Module, - EntryProcs), - list.foldl3(build_abstract_proc(EntryProcs, Options, SCC, !.Module), - SCC, varset.init, Varset, [], AbstractSCC, !IO), + EntryProcs), + list.foldl3(build_abstract_proc(EntryProcs, Options, SCC, !.Module), + SCC, varset.init, Varset, [], AbstractSCC, !IO), module_info_preds(!.Module, PredTable0), RecordInfo = (pred(Info::in, !.Errors::in, !:Errors::out, !.PredTable::in, !:PredTable::out) is det :- - Info = scc_info(proc(PredId, ProcId), AR0, VarMap, Status, - ProcErrors, HeadSizeVars), + Info = scc_info(proc(PredId, ProcId), AR0, VarMap, Status, + ProcErrors, HeadSizeVars), % % Record the proper size_varset. Each procedure has a copy. % XXX It would be nicer to store one copy per SCC. @@ -151,7 +151,7 @@ build_abstract_scc(DepOrder, SCC, Options, Errors, !Module, !IO) :- pred_info_get_procedures(PredInfo0, ProcTable0), ProcInfo0 = ProcTable0 ^ det_elem(ProcId), some [!TermInfo] ( - proc_info_get_termination2_info(ProcInfo0, !:TermInfo), + proc_info_get_termination2_info(ProcInfo0, !:TermInfo), !:TermInfo = !.TermInfo ^ intermod_status := yes(Status), !:TermInfo = !.TermInfo ^ abstract_rep := yes(AR), !:TermInfo = !.TermInfo ^ size_var_map := VarMap, @@ -163,9 +163,9 @@ build_abstract_scc(DepOrder, SCC, Options, Errors, !Module, !IO) :- ( analysis_depends_on_ho(AR) -> !:TermInfo = !.TermInfo ^ success_constrs := yes(polyhedron.universe), - HorderErrors = list.map((func(ho_call(Context)) - = Context - horder_call), AR ^ ho), - list.append(HorderErrors, !Errors) + HorderErrors = list.map((func(ho_call(Context)) + = Context - horder_call), AR ^ ho), + list.append(HorderErrors, !Errors) ; true ), @@ -175,7 +175,7 @@ build_abstract_scc(DepOrder, SCC, Options, Errors, !Module, !IO) :- pred_info_set_procedures(ProcTable, PredInfo0, PredInfo), svmap.det_update(PredId, PredInfo, !PredTable), list.append(ProcErrors, !Errors) - ), + ), list.foldl2(RecordInfo, AbstractSCC, [], Errors, PredTable0, PredTable), module_info_set_preds(PredTable, !Module). @@ -184,9 +184,9 @@ build_abstract_scc(DepOrder, SCC, Options, Errors, !Module, !IO) :- size_varset::in, size_varset::out, list(scc_info)::in, list(scc_info)::out, io::di, io::uo) is det. - + build_abstract_proc(EntryProcs, Options, SCC, Module, PPId, !SizeVarset, - !AbstractInfo, !IO) :- + !AbstractInfo, !IO) :- % XXX For debugging ... % io.write_string("Building procedure: ", !IO), % hlds_out.write_pred_proc_id(Module, PPId, !IO), @@ -208,16 +208,16 @@ build_abstract_proc(EntryProcs, Options, SCC, Module, PPId, !SizeVarset, % Allocate one size_var for each real var. in the procedure. % Work out which variables have zero size. % - allocate_sizevars(HeadProgVars, Goal, SizeVarMap, !SizeVarset), + allocate_sizevars(HeadProgVars, Goal, SizeVarMap, !SizeVarset), Zeros = find_zero_size_vars(Module, SizeVarMap, VarTypes), Info0 = init_traversal_info(Module, Options ^ functor_info, PPId, - Context, VarTypes, Zeros, SizeVarMap, SCC, + Context, VarTypes, Zeros, SizeVarMap, SCC, Options ^ failure_constrs, Options ^ arg_size_only ), % % Traverse the HLDS and construct the abstract version of - % this procedure. + % this procedure. % - build_abstract_goal(Goal, AbstractBody0, Info0, Info), + build_abstract_goal(Goal, AbstractBody0, Info0, Info), IntermodStatus = Info ^ intermod_status, HeadSizeVars = prog_vars_to_size_vars(SizeVarMap, HeadProgVars), AbstractBody = simplify_abstract_rep(AbstractBody0), @@ -225,20 +225,20 @@ build_abstract_proc(EntryProcs, Options, SCC, Module, PPId, !SizeVarset, % Work out which arguments can be used in termination proofs. % An argument may be used if (a) it is input and (b) it has % non-zero size. - % + % ChooseArg = (func(Var, Mode) = UseArg :- Type = VarTypes ^ det_elem(Var), - ( + ( not zero_size_type(Module, Type), mode_util.mode_is_input(Module, Mode) - -> + -> UseArg = yes ; UseArg = no ) ), Inputs = list.map_corresponding(ChooseArg, HeadProgVars, - ArgModes0), + ArgModes0), % % The size_varset for this procedure is set to rubbish here. % When we complete building this SCC we will set it to @@ -248,10 +248,10 @@ build_abstract_proc(EntryProcs, Options, SCC, Module, PPId, !SizeVarset, AbstractProc = abstract_proc(real(PPId), Context, Info ^ recursion, SizeVarMap, HeadSizeVars, Inputs, Zeros, AbstractBody, Info ^ maxcalls, !.SizeVarset, Info ^ ho_info, IsEntryPoint), - + ThisProcInfo = scc_info(PPId, AbstractProc, SizeVarMap, IntermodStatus, Info ^ errors, HeadSizeVars), - + list.cons(ThisProcInfo, !AbstractInfo). % XXX For debugging ... % io.write_string("Abstract proc is:\n", !IO), @@ -275,77 +275,77 @@ build_abstract_proc(EntryProcs, Options, SCC, Module, PPId, !SizeVarset, % * Any calls that are made from the SCC being processed to lower SCCs % that do not terminate. -:- type traversal_info +:- type traversal_info ---> traversal_info( recursion :: recursion_type, % What type of recursion is present % in the procedure. ie. `none', `direct', `mutual'. - + intermod_status :: intermod_status, % Record whether this procedure is potentially % involved in mutual recursion across module boundaries. - + errors :: term2_errors, % Errors encountered while building the AR. - + module_info :: module_info, % The HLDS. - + norm :: functor_info, % The norm we are using. - - ppid :: pred_proc_id, + + ppid :: pred_proc_id, % The procedure we are currently processing. - - context :: term.context, + + context :: term.context, % The context of the current procedure. - + types :: vartypes, % Types for all prog_vars in the current procedure. - + zeros :: set(size_var), % size_vars in the current procedure that % are known to have zero size. - - var_map :: size_var_map, + + var_map :: size_var_map, % Map from prog_vars to size_vars. - + scc :: list(pred_proc_id), % The procedures in the same SCC of the call % graph as the one we are current traversing. - + maxcalls :: int, % The number of calls in the procedure. - + find_fail_constrs :: bool, % If no then do not bother looking for failure constraints. - % The `--no-term2-propagate-failure-constraints' options. - + % The `--no-term2-propagate-failure-constraints' options. + ho_info :: list(abstract_ho_call), % Information about any higher-order calls a procedure makes. % XXX Currently unused. - + arg_analysis_only :: bool % Do we only want to run IR analysis? % The `--term2-arg-size-analysis-only' option. ). -:- func init_traversal_info(module_info, functor_info, pred_proc_id, +:- func init_traversal_info(module_info, functor_info, pred_proc_id, term.context, vartypes, zero_vars, size_var_map, list(pred_proc_id), bool, bool) = traversal_info. -init_traversal_info(ModuleInfo, Norm, PPId, Context, Types, Zeros, +init_traversal_info(ModuleInfo, Norm, PPId, Context, Types, Zeros, VarMap, SCC, FailConstrs, ArgSizeOnly) - = traversal_info(none, not_mutually_recursive, [], ModuleInfo, Norm, + = traversal_info(none, not_mutually_recursive, [], ModuleInfo, Norm, PPId, Context, Types, Zeros, VarMap, SCC, 0, FailConstrs, [], - ArgSizeOnly). + ArgSizeOnly). :- pred info_increment_maxcalls(traversal_info::in, traversal_info::out) is det. info_increment_maxcalls(!Info) :- !:Info = !.Info ^ maxcalls := !.Info ^ maxcalls + 1. -:- pred info_update_errors(term_constr_errors.error::in, traversal_info::in, +:- pred info_update_errors(term_constr_errors.error::in, traversal_info::in, traversal_info::out) is det. info_update_errors(Error, !Info) :- @@ -364,11 +364,11 @@ info_update_recursion(RecType, !Info) :- info_update_ho_info(Context, !Info) :- !:Info = !.Info ^ ho_info := [ho_call(Context) | !.Info ^ ho_info]. -:- pred set_intermod_status(intermod_status::in, traversal_info::in, +:- pred set_intermod_status(intermod_status::in, traversal_info::in, traversal_info::out) is det. set_intermod_status(Status, !TraversalInfo) :- - !:TraversalInfo = !.TraversalInfo ^ intermod_status := Status. + !:TraversalInfo = !.TraversalInfo ^ intermod_status := Status. %------------------------------------------------------------------------------% % @@ -376,41 +376,41 @@ set_intermod_status(Status, !TraversalInfo) :- % % When constructing the abstract representation of the program -% this attaches the local variables to the abstract goal. -% (See comments about local variables in term_constr_data.m for more details.) +% this attaches the local variables to the abstract goal. +% (See comments about local variables in term_constr_data.m for more details.) -:- pred build_abstract_goal(hlds_goal::in, abstract_goal::out, +:- pred build_abstract_goal(hlds_goal::in, abstract_goal::out, traversal_info::in, traversal_info::out) is det. -build_abstract_goal(Goal, AbstractGoal, !Info) :- +build_abstract_goal(Goal, AbstractGoal, !Info) :- Goal = hlds_goal(GoalExpr, GoalInfo), build_abstract_goal_2(GoalExpr, GoalInfo, AbstractGoal0, !Info), partition_vars(Goal, Locals0, NonLocals0), VarMap = !.Info ^ var_map, Locals = prog_vars_to_size_vars(VarMap, Locals0), - NonLocals = prog_vars_to_size_vars(VarMap, NonLocals0), + NonLocals = prog_vars_to_size_vars(VarMap, NonLocals0), AbstractGoal = update_local_and_nonlocal_vars(AbstractGoal0, Locals, NonLocals). - + :- pred build_abstract_goal_2(hlds_goal_expr::in, hlds_goal_info::in, abstract_goal::out, traversal_info::in, traversal_info::out) is det. build_abstract_goal_2(conj(_, Goals), _, AbstractGoal, !Info) :- - % For the purposes of termination analysis there is no + % For the purposes of termination analysis there is no % distinction between parallel conjunctions and normal ones. build_abstract_conj(Goals, AbstractGoal, !Info). build_abstract_goal_2(disj(Goals), _, AbstractGoal, !Info) :- build_abstract_disj(non_switch(Goals), AbstractGoal, !Info). -build_abstract_goal_2(GoalExpr, _, AbstractGoal, !Info) :- +build_abstract_goal_2(GoalExpr, _, AbstractGoal, !Info) :- GoalExpr = switch(SwitchVar, _, Cases), build_abstract_disj(switch(SwitchVar, Cases), AbstractGoal, !Info). build_abstract_goal_2(GoalExpr, _, AbstractGoal, !Info) :- GoalExpr = if_then_else(_, Cond, Then, Else), % - % Reduce the if-then goals to an abstract conjunction. + % Reduce the if-then goals to an abstract conjunction. % build_abstract_conj([Cond, Then], AbstractSuccessGoal, !Info), % @@ -420,28 +420,28 @@ build_abstract_goal_2(GoalExpr, _, AbstractGoal, !Info) :- % CondFail = find_failure_constraint_for_goal(Cond, !.Info), % - % XXX FIXME - the local/non-local variable sets end up + % XXX FIXME - the local/non-local variable sets end up % being incorrect here. % - build_abstract_goal(Else, AbstractElse, !Info), + build_abstract_goal(Else, AbstractElse, !Info), AbstractFailureGoal = term_conj([CondFail, AbstractElse], [], []), AbstractDisjuncts = [AbstractSuccessGoal, AbstractFailureGoal], AbstractGoal = term_disj(AbstractDisjuncts, 2, [], []). -build_abstract_goal_2(scope(_, Goal), _, AbstractGoal, !Info) :- +build_abstract_goal_2(scope(_, Goal), _, AbstractGoal, !Info) :- build_abstract_goal(Goal, AbstractGoal, !Info). -build_abstract_goal_2(GoalExpr, GoalInfo, AbstractGoal, !Info) :- +build_abstract_goal_2(GoalExpr, GoalInfo, AbstractGoal, !Info) :- GoalExpr = plain_call(CallPredId, CallProcId, CallArgs, _, _, _), CallSizeArgs = prog_vars_to_size_vars(!.Info ^ var_map, CallArgs), - build_abstract_call(proc(CallPredId, CallProcId), CallSizeArgs, + build_abstract_call(proc(CallPredId, CallProcId), CallSizeArgs, GoalInfo, AbstractGoal, !Info). -build_abstract_goal_2(GoalExpr, _, AbstractGoal, !Info) :- +build_abstract_goal_2(GoalExpr, _, AbstractGoal, !Info) :- GoalExpr = unify(_, _, _, Unification, _), build_abstract_unification(Unification, AbstractGoal, !Info). -build_abstract_goal_2(negation(Goal), _GoalInfo, AbstractGoal, !Info) :- +build_abstract_goal_2(negation(Goal), _GoalInfo, AbstractGoal, !Info) :- % % Event though a negated goal cannot have any output we still % need to check it for calls to non-terminating procedures. @@ -458,20 +458,20 @@ build_abstract_goal_2(negation(Goal), _GoalInfo, AbstractGoal, !Info) :- % XXX Eventually we should provide some facility for specifying the % arg_size constraints for foreign_procs. % -build_abstract_goal_2(GoalExpr, GoalInfo, AbstractGoal, !Info) :- - GoalExpr = call_foreign_proc(Attrs, PredId, ProcId, Args, ExtraArgs, _, _), +build_abstract_goal_2(GoalExpr, GoalInfo, AbstractGoal, !Info) :- + GoalExpr = call_foreign_proc(Attrs, PredId, ProcId, Args, ExtraArgs, _, _), % % Create non-negativity constraints for each non-zero argument % in the foreign proc. % ForeignArgToVar = (func(ForeignArg) = ForeignArg ^ arg_var), ProgVars = list.map(ForeignArgToVar, Args ++ ExtraArgs), - SizeVars = prog_vars_to_size_vars(!.Info ^ var_map, ProgVars), + SizeVars = prog_vars_to_size_vars(!.Info ^ var_map, ProgVars), Constraints = make_arg_constraints(SizeVars, !.Info ^ zeros), - ( - ( + ( + ( get_terminates(Attrs) = proc_terminates - ; + ; get_terminates(Attrs) = depends_on_mercury_calls, get_may_call_mercury(Attrs) = proc_will_not_call_mercury ) @@ -499,8 +499,8 @@ build_abstract_goal_2(GoalExpr, GoalInfo, AbstractGoal, !Info) :- % shorthand/1 goals ought to have been transformed away by % the time we get round to termination analysis. - % -build_abstract_goal_2(shorthand(_), _, _, _, _) :- + % +build_abstract_goal_2(shorthand(_), _, _, _, _) :- unexpected(this_file, "shorthand/1 goal during termination analysis."). %------------------------------------------------------------------------------% @@ -508,7 +508,7 @@ build_abstract_goal_2(shorthand(_), _, _, _, _) :- % Additional predicates for abstracting (parallel) conjunctions. % -:- pred build_abstract_conj(hlds_goals::in, abstract_goal::out, +:- pred build_abstract_conj(hlds_goals::in, abstract_goal::out, traversal_info::in, traversal_info::out) is det. build_abstract_conj(Conjuncts, AbstractGoal, !Info) :- @@ -521,14 +521,14 @@ build_abstract_conj(Conjuncts, AbstractGoal, !Info) :- % Additional predicates for abstracting calls. % -:- pred build_abstract_call(pred_proc_id::in, size_vars::in, - hlds_goal_info::in, abstract_goal::out, traversal_info::in, +:- pred build_abstract_call(pred_proc_id::in, size_vars::in, + hlds_goal_info::in, abstract_goal::out, traversal_info::in, traversal_info::out) is det. build_abstract_call(CalleePPId, CallerArgs, GoalInfo, AbstractGoal, !Info) :- Context = goal_info_get_context(GoalInfo), ( if list.member(CalleePPId, !.Info ^ scc) - then build_recursive_call(CalleePPId, CallerArgs, Context, + then build_recursive_call(CalleePPId, CallerArgs, Context, AbstractGoal, !Info) else build_non_recursive_call(CalleePPId, CallerArgs, Context, AbstractGoal, !Info) @@ -542,16 +542,16 @@ build_abstract_call(CalleePPId, CallerArgs, GoalInfo, AbstractGoal, !Info) :- build_recursive_call(CalleePPId, CallerArgs, Context, AbstractGoal, !Info) :- CallerPPId = !.Info ^ ppid, - CallerZeros = !.Info ^ zeros, + CallerZeros = !.Info ^ zeros, ( if CallerPPId = CalleePPId then info_update_recursion(direct_only, !Info) else info_update_recursion(mutual_only, !Info) ), - CallerArgConstrs = make_arg_constraints(CallerArgs, CallerZeros), + CallerArgConstrs = make_arg_constraints(CallerArgs, CallerZeros), CallerArgPoly = polyhedron.from_constraints(CallerArgConstrs), info_increment_maxcalls(!Info), AbstractGoal = term_call(real(CalleePPId), Context, CallerArgs, - CallerZeros, [], [], CallerArgPoly). + CallerZeros, [], [], CallerArgPoly). % For non-recursive calls look up the argument size constraints for the % callee procedure and build an abstract primitive goal to store them. @@ -599,7 +599,7 @@ build_non_recursive_call(CalleePPId, CallerArgs, Context, AbstractGoal, ), % % Check the arg_size_info for the procedure being called. - % + % ArgSizeInfo = CalleeTerm2Info ^ success_constrs, ( ArgSizeInfo = no, @@ -621,7 +621,7 @@ build_non_recursive_call(CalleePPId, CallerArgs, Context, AbstractGoal, ), Polyhedron = polyhedron.from_constraints(Constraints), AbstractGoal = term_primitive(Polyhedron, [], []). - + %------------------------------------------------------------------------------% % % Additional predicates for abstracting switches and disjunctions. @@ -637,11 +637,11 @@ build_non_recursive_call(CalleePPId, CallerArgs, Context, AbstractGoal, % usually be much larger for the entire disjunction than the matrix used % for each case/disjunct. -:- type disj_info - ---> switch(prog_var, list(case)) +:- type disj_info + ---> switch(prog_var, list(case)) ; non_switch(hlds_goals). -:- pred build_abstract_disj(disj_info::in, abstract_goal::out, +:- pred build_abstract_disj(disj_info::in, abstract_goal::out, traversal_info::in, traversal_info::out) is det. build_abstract_disj(Type, AbstractGoal, !Info) :- @@ -650,10 +650,10 @@ build_abstract_disj(Type, AbstractGoal, !Info) :- build_abstract_disj_acc(Goals, [], AbstractGoals, !Info) ; Type = switch(SwitchVar, Cases), - build_abstract_switch_acc(SwitchVar, Cases, [], AbstractGoals, + build_abstract_switch_acc(SwitchVar, Cases, [], AbstractGoals, !Info) ), - ( + ( AbstractGoals = [], AbstractGoal = term_primitive(polyhedron.universe, [], []) ; @@ -665,11 +665,11 @@ build_abstract_disj(Type, AbstractGoal, !Info) :- AbstractGoal = term_disj(AbstractGoals, DisjSize, [], []) ). -:- pred build_abstract_disj_acc(hlds_goals::in, abstract_goals::in, +:- pred build_abstract_disj_acc(hlds_goals::in, abstract_goals::in, abstract_goals::out, traversal_info::in, traversal_info::out) is det. build_abstract_disj_acc([], !AbstractGoals, !Info). -build_abstract_disj_acc([Goal | Goals], !AbstractGoals, !Info) :- +build_abstract_disj_acc([Goal | Goals], !AbstractGoals, !Info) :- build_abstract_goal(Goal, AbstractGoal, !Info), list.cons(AbstractGoal, !AbstractGoals), build_abstract_disj_acc(Goals, !AbstractGoals, !Info). @@ -677,11 +677,10 @@ build_abstract_disj_acc([Goal | Goals], !AbstractGoals, !Info) :- % With switches we need to consider the constraints on the variable % being switched on as well as those from the body of each case. % - % For each case we check if the there is a deconstruction - % unification involving the switch variable. If there is no such - % unification then the constraint for the case will not include a - % constraint on the size of the switch-var. In that case we add an - % appropriate constraint. + % For each case, we check if there is a deconstruction unification + % involving the switch variable. If there is no such unification then + % the constraint for the case will not include a constraint on the size + % of the switched-on var. In that case we add an appropriate constraint. % % We add the extra constraint by creating a new primitive abstract % goal and conjoining that to the rest. @@ -691,63 +690,69 @@ build_abstract_disj_acc([Goal | Goals], !AbstractGoals, !Info) :- traversal_info::out) is det. build_abstract_switch_acc(_, [], !AbstractGoals, !Info). -build_abstract_switch_acc(SwitchProgVar, [case(ConsId, Goal) | Cases], - !AbstractGoals, !Info) :- - build_abstract_goal(Goal, AbstractGoal0, !Info), - % - % We now need to check that constraints on the switch var are - % included. They will *not* have been included if the case did not - % contain a unification deconstructing that variable. They are of - % course in the HLDS, just not stored in a way we can derive them - % from the goal in the normal fashion unless there is actually a - % deconstruction unification present. - % - ( detect_switch_var(Goal, SwitchProgVar, ConsId) -> +build_abstract_switch_acc(SwitchProgVar, [Case | Cases], !AbstractGoals, + !Info) :- + Case = case(MainConsId, OtherConsIds, Goal), + build_abstract_goal(Goal, AbstractGoal0, !Info), + + % We now need to check that constraints on the switch var are included. + % They will *not* have been included if the case did not contain a + % unification deconstructing that variable (which it can't contain if the + % switch arm is for several cons_ids). They are of course in the HLDS, + % just not stored in a way we can derive them from the goal in the normal + % fashion unless there is actually a deconstruction unification present. + + ( + OtherConsIds = [], + detect_switch_var(Goal, SwitchProgVar, MainConsId) + -> AbstractGoal = AbstractGoal0 ; TypeMap = !.Info ^ types, SizeVarMap = !.Info ^ var_map, SwitchVarType = TypeMap ^ det_elem(SwitchProgVar), SwitchSizeVar = prog_var_to_size_var(SizeVarMap, SwitchProgVar), - ( type_to_ctor_and_args(SwitchVarType, TypeCtor, _) -> - Size = functor_lower_bound(!.Info ^ norm, TypeCtor, ConsId, - !.Info ^ module_info) - ; - unexpected(this_file, "variable type in detect_switch_var.") - ), - ( not set.member(SwitchSizeVar, !.Info ^ zeros) -> + type_to_ctor_and_args_det(SwitchVarType, TypeCtor, _), + Size = functor_lower_bound(!.Info ^ norm, TypeCtor, MainConsId, + !.Info ^ module_info), + ( set.member(SwitchSizeVar, !.Info ^ zeros) -> + ExtraConstr = [] + ; SwitchVarConst = rat(Size), - SwitchVarConstr = + SwitchVarConstr = ( Size = 0 -> make_var_const_eq_constraint(SwitchSizeVar, SwitchVarConst) ; make_var_const_gte_constraint(SwitchSizeVar, - SwitchVarConst) + SwitchVarConst) ), ExtraConstr = [SwitchVarConstr] - ; - ExtraConstr = [] ), ExtraPoly = polyhedron.from_constraints(ExtraConstr), ExtraGoal = term_primitive(ExtraPoly, [], []), AbstractGoal = term_conj([ExtraGoal, AbstractGoal0], [], []) ), list.cons(AbstractGoal, !AbstractGoals), - build_abstract_switch_acc(SwitchProgVar, Cases, !AbstractGoals, !Info). + build_abstract_switch_acc(SwitchProgVar, Cases, !AbstractGoals, !Info). :- pred detect_switch_var(hlds_goal::in, prog_var::in, cons_id::in) is semidet. detect_switch_var(hlds_goal(unify(_, _, _, Kind, _), _), SwitchVar, ConsId) :- - ( Kind = deconstruct(SwitchVar, ConsId, _, _, _, _) -> - true - ; Kind = complicated_unify(_, _, _) -> + ( + Kind = deconstruct(SwitchVar, ConsId, _, _, _, _) + ; + Kind = complicated_unify(_, _, _), unexpected(this_file, "complicated_unify/3 goal during termination analysis.") ; + ( Kind = construct(_, _, _, _, _, _, _) + ; Kind = assign(_, _) + ; Kind = simple_test(_, _) + ), fail ). -detect_switch_var(hlds_goal(shorthand(_), _), _, _) :- +detect_switch_var(hlds_goal(shorthand(_), _), _, _) :- unexpected(this_file, "shorthand/1 goal during termination analysis"). %------------------------------------------------------------------------------% @@ -755,14 +760,14 @@ detect_switch_var(hlds_goal(shorthand(_), _), _, _) :- % Additional predicates for abstracting unifications. % -:- pred build_abstract_unification(unification::in, abstract_goal::out, +:- pred build_abstract_unification(unification::in, abstract_goal::out, traversal_info::in, traversal_info::out) is det. -build_abstract_unification(Unification, AbstractGoal, !Info) :- +build_abstract_unification(Unification, AbstractGoal, !Info) :- Unification = construct(Var, ConsId, ArgVars, Modes, _, _, _), build_abstract_decon_or_con_unify(Var, ConsId, ArgVars, Modes, Constraints, !Info), - AbstractGoal = build_goal_from_unify(Constraints). + AbstractGoal = build_goal_from_unify(Constraints). build_abstract_unification(Unification, AbstractGoal, !Info) :- Unification = deconstruct(Var, ConsId, ArgVars, Modes, _, _), @@ -776,9 +781,9 @@ build_abstract_unification(assign(LVar, RVar), AbstractGoal, !Info) :- build_abstract_unification(simple_test(LVar, RVar), AbstractGoal, !Info) :- build_abstract_simple_or_assign_unify(LVar, RVar, Constraints, !Info), - AbstractGoal = build_goal_from_unify(Constraints). - -build_abstract_unification(complicated_unify(_, _, _), _, _, _) :- + AbstractGoal = build_goal_from_unify(Constraints). + +build_abstract_unification(complicated_unify(_, _, _), _, _, _) :- unexpected(this_file, "complicated_unify/3 in termination analysis."). % Used for deconstruction and construction unifications. e.g. for a @@ -794,7 +799,7 @@ build_abstract_decon_or_con_unify(Var, ConsId, ArgVars, Modes, Constraints, !Info) :- VarTypes = !.Info ^ types, Type = VarTypes ^ det_elem(Var), - ( + ( not type_is_higher_order(Type), type_to_ctor_and_args(Type, TypeCtor, _) -> @@ -810,22 +815,22 @@ build_abstract_decon_or_con_unify(Var, ConsId, ArgVars, Modes, Constraints, strip_typeinfos_from_args_and_modes(VarTypes, ArgVars, FixedArgs, Modes, FixedModes), - functor_norm(Norm, TypeCtor, ConsId, ModuleInfo, Constant, + functor_norm(Norm, TypeCtor, ConsId, ModuleInfo, Constant, FixedArgs, CountedVars, FixedModes, _), % % The constraint from this unification is: - % + % % |Var| = Constant + sum(CountedVars) % % |Var| is just the size_var corresponding to Var. The % value of `Constant' will depend upon the norm being used. - % + % SizeVar = prog_var_to_size_var(!.Info ^ var_map, Var), - ( if set.member(SizeVar, Zeros) - then FirstTerm = [] - else FirstTerm = [SizeVar - one] + ( if set.member(SizeVar, Zeros) + then FirstTerm = [] + else FirstTerm = [SizeVar - one] ), - AddTerms = (func(Var1, Terms0) = Terms1 :- + AddTerms = (func(Var1, Terms0) = Terms1 :- SizeVar1 = prog_var_to_size_var( !.Info ^ var_map, Var1), ( if set.member(SizeVar1, Zeros) @@ -852,8 +857,8 @@ build_abstract_decon_or_con_unify(Var, ConsId, ArgVars, Modes, Constraints, Constraints = [] ). -:- pred strip_typeinfos_from_args_and_modes(vartypes::in, - list(prog_var)::in, list(prog_var)::out, +:- pred strip_typeinfos_from_args_and_modes(vartypes::in, + list(prog_var)::in, list(prog_var)::out, list(uni_mode)::in, list(uni_mode)::out) is det. strip_typeinfos_from_args_and_modes(VarTypes, !Args, !Modes) :- @@ -870,7 +875,7 @@ strip_typeinfos_from_args_and_modes(VarTypes, !Args, !Modes) :- strip_typeinfos_from_args_and_modes_2(_, [], [], [], []). strip_typeinfos_from_args_and_modes_2(VarTypes, [ Arg | !.Args ], !:Args, - [ Mode | !.Modes ], !:Modes) :- + [ Mode | !.Modes ], !:Modes) :- strip_typeinfos_from_args_and_modes_2(VarTypes, !Args, !Modes), Type = VarTypes ^ det_elem(Arg), ( is_introduced_type_info_type(Type) -> @@ -885,7 +890,7 @@ strip_typeinfos_from_args_and_modes_2(VarTypes, [ Arg | !.Args ], !:Args, % :- pred build_abstract_simple_or_assign_unify(prog_var::in, prog_var::in, constraints::out, traversal_info::in, traversal_info::out) is det. - + build_abstract_simple_or_assign_unify(LeftProgVar, RightProgVar, Constraints, !Info) :- SizeVarMap = !.Info ^ var_map, @@ -897,12 +902,12 @@ build_abstract_simple_or_assign_unify(LeftProgVar, RightProgVar, set.member(RightSizeVar, Zeros) -> Constraints = [] % `true' constraint. - ; + ; (set.member(LeftSizeVar, Zeros) ; set.member(RightSizeVar, Zeros)) -> - unexpected(this_file, "zero unified with non-zero.") - ; + unexpected(this_file, "zero unified with non-zero.") + ; % Create non-negativity constraints. % NonNegConstrs = list.map(make_nonneg_constr, @@ -932,7 +937,7 @@ build_goal_from_unify(Constraints) = term_primitive(Polyhedron, [], []) :- % real local vars. This shouldn't be a problem as everything but % the head_vars will be projected out at the end of each iteration % anyway. - % + % :- func local_vars(hlds_goal) = prog_vars. local_vars(hlds_goal(GoalExpr, GoalInfo)) = Locals :- @@ -959,7 +964,7 @@ partition_vars(hlds_goal(GoalExpr, GoalInfo), Locals, NonLocals) :- % Create the size_vars corresponding to the given prog_vars. Also % create map from the prog_vars to the size_vars. - % + % % As termination analysis is (currently) carried out before unused % argument analysis it is possible that some variables in the head % of a procedure may not occur in the body (this typically occurs @@ -1025,7 +1030,7 @@ possibly_fix_sizevar_map([ProgVar | ProgVars], !SizeVarset, !SizeVarMap) :- = abstract_goal. find_failure_constraint_for_goal(Goal, Info) = AbstractGoal :- - ( + ( Info ^ find_fail_constrs = yes, find_failure_constraint_for_goal_2(Goal, Info, AbstractGoal0) -> @@ -1052,7 +1057,7 @@ find_failure_constraint_for_goal_2(hlds_goal(GoalExpr, _), Info, GoalExpr = plain_call(PredId, ProcId, CallArgs, _, _, _), CallSizeArgs0 = prog_vars_to_size_vars(Info ^ var_map, CallArgs), CallSizeArgs = list.filter(isnt(is_zero_size_var(Info ^ zeros)), - CallSizeArgs0), + CallSizeArgs0), ModuleInfo = Info ^ module_info, module_info_pred_proc_info(ModuleInfo, PredId, ProcId, _, ProcInfo), proc_info_get_termination2_info(ProcInfo, TermInfo), @@ -1064,7 +1069,7 @@ find_failure_constraint_for_goal_2(hlds_goal(GoalExpr, _), Info, MaybeFailureConstrs = yes(CalleeFailurePolyhedron), CalleeFailureConstraints = polyhedron.non_false_constraints(CalleeFailurePolyhedron), - ( + ( CalleeFailureConstraints = [], FailureConstraints = [] ; @@ -1082,7 +1087,7 @@ find_failure_constraint_for_goal_2( hlds_goal(GoalExpr @ unify(_, _, _, _, _), _), Info, AbstractGoal) :- find_deconstruct_fail_bound(GoalExpr, Info, Polyhedron), - AbstractGoal = term_primitive(Polyhedron, [], []). + AbstractGoal = term_primitive(Polyhedron, [], []). % Given a deconstruction unification and assuming that it has % failed, find a bound on the size of the variable being @@ -1096,7 +1101,7 @@ find_deconstruct_fail_bound(unify(_, _, _, Kind, _), Info, Polyhedron) :- Type = Info ^ types ^ det_elem(Var), prog_type.type_to_ctor_and_args(Type, TypeCtor, _), ModuleInfo = Info ^ module_info, - type_util.type_constructors(Type, ModuleInfo, Constructors0), + type_util.type_constructors(ModuleInfo, Type, Constructors0), ( if ConsId = cons(ConsName0, ConsArity0) then ConsName = ConsName0, ConsArity = ConsArity0 else unexpected(this_file, @@ -1115,37 +1120,37 @@ find_deconstruct_fail_bound(unify(_, _, _, Kind, _), Info, Polyhedron) :- bounds_on_var(Info ^ norm, ModuleInfo, TypeCtor, SizeVar, Constructors, Polyhedron). - % Given a variable, its type and a list of constructors to which + % Given a variable, its type and a list of constructors to which % it could be bound, return a polyhedron representing the bounds % on the size of that variable. % :- pred bounds_on_var(functor_info::in, module_info::in, type_ctor::in, - size_var::in, list(constructor)::in, polyhedron::out) is det. + size_var::in, list(constructor)::in, polyhedron::out) is det. bounds_on_var(Norm, ModuleInfo, TypeCtor, Var, Constructors, Polyhedron) :- - CtorSizes = list.map(lower_bound(Norm, ModuleInfo, TypeCtor), + CtorSizes = list.map(lower_bound(Norm, ModuleInfo, TypeCtor), Constructors), % % Split constructors into those that have zero size and % those that have non-zero size. % - list.filter((pred(V::in) is semidet :- V = 0), CtorSizes, - ZeroSizeCtors, NonZeroSizeCtors), - ( - ZeroSizeCtors = [], NonZeroSizeCtors = [] + list.filter((pred(V::in) is semidet :- V = 0), CtorSizes, + ZeroSizeCtors, NonZeroSizeCtors), + ( + ZeroSizeCtors = [], NonZeroSizeCtors = [] -> unexpected(this_file, "bounds_on_var/6: " ++ "no other constructors for type.") ; - ZeroSizeCtors = [_|_], NonZeroSizeCtors = [] - -> + ZeroSizeCtors = [_|_], NonZeroSizeCtors = [] + -> Constraints = [constraint([Var - one], (=), zero)] ; upper_bound_constraints(Norm, ModuleInfo, Var, TypeCtor, Constructors, UpperBoundConstr), ( ZeroSizeCtors = [], NonZeroSizeCtors = [C | Cs] -> - LowerBound = list.foldl(int.min, Cs, C), + LowerBound = list.foldl(int.min, Cs, C), LowerBoundConstr = [constraint([Var - one], (>=), rat(LowerBound))] ; LowerBoundConstr = [constraint([Var - one], (>=), zero)] @@ -1168,7 +1173,7 @@ lower_bound(Norm, Module, TypeCtor, Constructor) = LowerBound :- % upper bound. % :- pred upper_bound_constraints(functor_info::in, module_info::in, size_var::in, - type_ctor::in, list(constructor)::in, constraints::out) is det. + type_ctor::in, list(constructor)::in, constraints::out) is det. upper_bound_constraints(Norm, Module, Var, TypeCtor, Ctors, Constraints) :- % @@ -1178,7 +1183,7 @@ upper_bound_constraints(Norm, Module, Var, TypeCtor, Ctors, Constraints) :- % bounds. % % XXX We could extend this to include functors can only have a - % finite size but I'm not sure that it's worth it. + % finite size but I'm not sure that it's worth it. % FindUpperBound = (pred(Ctor::in, !.B::in, !:B::out) is semidet :- Ctor = ctor(_, _, SymName, Args, _), diff --git a/compiler/term_norm.m b/compiler/term_norm.m index 70878c468..821cecf88 100644 --- a/compiler/term_norm.m +++ b/compiler/term_norm.m @@ -147,7 +147,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/term_pass1.m b/compiler/term_pass1.m index fdea5517f..e27bbedc4 100644 --- a/compiler/term_pass1.m +++ b/compiler/term_pass1.m @@ -399,7 +399,7 @@ check_goal_expr_non_term_calls(_, _, shorthand(_), _, _, _, _, _, _, _) :- termination_error_contexts::in, termination_error_contexts::out, module_info::in, module_info::out, io::di, io::uo) is det. -check_cases_non_term_calls(PPId, VarTypes, case(_, Goal), !Errors, +check_cases_non_term_calls(PPId, VarTypes, case(_, _, Goal), !Errors, !ModuleInfo, !IO) :- check_goal_non_term_calls(PPId, VarTypes, Goal, !Errors, !ModuleInfo, !IO). diff --git a/compiler/term_traversal.m b/compiler/term_traversal.m index 7d0f193fe..07beec00b 100644 --- a/compiler/term_traversal.m +++ b/compiler/term_traversal.m @@ -384,7 +384,7 @@ traverse_disj([Goal | Goals], Params, !Info, !ModuleInfo, !IO) :- traverse_switch([], _, _, ok(Empty, []), !ModuleInfo, !IO) :- set.init(Empty). -traverse_switch([case(_, Goal) | Cases], Params, !Info, !ModuleInfo, !IO) :- +traverse_switch([case(_, _, Goal) | Cases], Params, !Info, !ModuleInfo, !IO) :- traverse_goal(Goal, Params, !.Info, GoalInfo, !ModuleInfo, !IO), traverse_switch(Cases, Params, !.Info, CasesInfo, !ModuleInfo, !IO), combine_paths(GoalInfo, CasesInfo, Params, !:Info). diff --git a/compiler/trailing_analysis.m b/compiler/trailing_analysis.m index ad3891a65..0c9d5bf14 100644 --- a/compiler/trailing_analysis.m +++ b/compiler/trailing_analysis.m @@ -465,7 +465,7 @@ check_goal_for_trail_mods_2(_, _, shorthand(_), _, _, _, !ModuleInfo, !IO) :- check_goal_for_trail_mods_2(SCC, VarTypes, GoalExpr, _, Result, MaybeAnalysisStatus, !ModuleInfo, !IO) :- GoalExpr = switch(_, _, Cases), - CaseGoals = list.map((func(case(_, CaseGoal)) = CaseGoal), Cases), + CaseGoals = list.map((func(case(_, _, CaseGoal)) = CaseGoal), Cases), check_goals_for_trail_mods(SCC, VarTypes, CaseGoals, Result, MaybeAnalysisStatus, !ModuleInfo, !IO). check_goal_for_trail_mods_2(SCC, VarTypes, GoalExpr, _, @@ -1023,9 +1023,9 @@ annotate_cases(VarTypes, !Cases, Status, !ModuleInfo, !IO) :- io::di, io::uo) is det. annotate_case(VarTypes, !Case, Status, !ModuleInfo, !IO) :- - !.Case = case(ConsId, Goal0), + !.Case = case(MainConsId, OtherConsIds, Goal0), annotate_goal(VarTypes, Goal0, Goal, Status, !ModuleInfo, !IO), - !:Case = case(ConsId, Goal). + !:Case = case(MainConsId, OtherConsIds, Goal). %----------------------------------------------------------------------------% % diff --git a/compiler/transform_llds.m b/compiler/transform_llds.m index 0e50114fa..411122d77 100644 --- a/compiler/transform_llds.m +++ b/compiler/transform_llds.m @@ -46,6 +46,7 @@ :- import_module counter. :- import_module int. :- import_module list. +:- import_module maybe. :- import_module pair. :- import_module set. :- import_module string. @@ -171,12 +172,12 @@ transform_instructions([], [], !C, _, _). transform_instructions([Instr0 | Instrs0], Instrs, !C, ProcLabel, MaxSize) :- transform_instructions(Instrs0, InstrsTail, !C, ProcLabel, MaxSize), ( - Instr0 = llds_instr(computed_goto(Rval, Labels), Comment), - list.length(Labels, NumLabels), - NumLabels > MaxSize + Instr0 = llds_instr(computed_goto(Rval, Targets), Comment), + list.length(Targets, NumTargets), + NumTargets > MaxSize -> - split_computed_goto(Rval, Labels, Comment, InstrsHead, !C, - MaxSize, NumLabels, ProcLabel), + split_computed_goto(Rval, Targets, Comment, InstrsHead, !C, + MaxSize, NumTargets, ProcLabel), list.append(InstrsHead, InstrsTail, Instrs) ; Instrs = [Instr0 | InstrsTail] @@ -188,20 +189,20 @@ transform_instructions([Instr0 | Instrs0], Instrs, !C, ProcLabel, MaxSize) :- % in half as many times as necessary to bring the jump table size % below MaxSize, doing a binary search on the way. % -:- pred split_computed_goto(rval::in, list(label)::in, string::in, +:- pred split_computed_goto(rval::in, list(maybe(label))::in, string::in, list(instruction)::out, counter::in, counter::out, int::in, int::in, proc_label::in) is det. -split_computed_goto(Rval, Labels, Comment, Instrs, !C, MaxSize, NumLabels, +split_computed_goto(Rval, Targets, Comment, Instrs, !C, MaxSize, NumTargets, ProcLabel) :- - ( NumLabels =< MaxSize -> - Instrs = [llds_instr(computed_goto(Rval, Labels), Comment)] + ( NumTargets =< MaxSize -> + Instrs = [llds_instr(computed_goto(Rval, Targets), Comment)] ; counter.allocate(LabelNum, !C), - Mid = NumLabels // 2, - ( list.split_list(Mid, Labels, StartPrime, EndPrime) -> - Start = StartPrime, - End = EndPrime + Mid = NumTargets // 2, + ( list.split_list(Mid, Targets, StartTargetsPrime, EndTargetsPrime) -> + StartTargets = StartTargetsPrime, + EndTargets = EndTargetsPrime ; unexpected(this_file, "split_computed_goto: list.split_list") ), @@ -212,10 +213,10 @@ split_computed_goto(Rval, Labels, Comment, Instrs, !C, MaxSize, NumLabels, IfInstr = llds_instr(if_val(Test, ElseAddr), "binary search"), ElseInstr = llds_instr(label(internal_label(LabelNum, ProcLabel)), ""), - split_computed_goto(Rval, Start, Comment ++ " then", + split_computed_goto(Rval, StartTargets, Comment ++ " then", ThenInstrs, !C, MaxSize, Mid, ProcLabel), - split_computed_goto(Index, End, Comment ++ " else", - ElseInstrs, !C, MaxSize, NumLabels - Mid, ProcLabel), + split_computed_goto(Index, EndTargets, Comment ++ " else", + ElseInstrs, !C, MaxSize, NumTargets - Mid, ProcLabel), Instrs = [IfInstr | ThenInstrs] ++ [ElseInstr | ElseInstrs] ). diff --git a/compiler/tupling.m b/compiler/tupling.m index 5da12ce51..b4454edc8 100644 --- a/compiler/tupling.m +++ b/compiler/tupling.m @@ -1299,7 +1299,7 @@ count_load_stores_in_disj([Goal | Goals], CountInfo, !CountState) :- count_load_stores_in_cases([], _CountInfo, !CountState). count_load_stores_in_cases([Case | Cases], CountInfo, !CountState) :- - Case = case(_ConsId, Goal), + Case = case(_MainConsId, _OtherConsIds, Goal), GoalInfo = Goal ^ hlds_goal_info, goal_info_get_resume_point(GoalInfo, ResumePoint), ( @@ -1825,10 +1825,10 @@ fix_calls_in_goal_list([Goal0 | Goals0], [Goal | Goals], !VarSet, !VarTypes, fix_calls_in_cases([], [], !VarSet, !VarTypes, !RttiVarMaps, _). fix_calls_in_cases([Case0 | Cases0], [Case | Cases], !VarSet, !VarTypes, !RttiVarMaps, TransformMap) :- - Case0 = case(Functor, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, !RttiVarMaps, TransformMap), - Case = case(Functor, Goal), + Case = case(MainConsId, OtherConsIds, Goal), fix_calls_in_cases(Cases0, Cases, !VarSet, !VarTypes, !RttiVarMaps, TransformMap). diff --git a/compiler/type_ctor_info.m b/compiler/type_ctor_info.m index 93241b971..8b6a4ea9b 100644 --- a/compiler/type_ctor_info.m +++ b/compiler/type_ctor_info.m @@ -360,8 +360,9 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :- UnivTvars, ExistTvars, MaybePseudoTypeInfo), Details = eqv(MaybePseudoTypeInfo) ; - TypeBody = hlds_du_type(Ctors, ConsTagMap, EnumDummy, - MaybeUserEqComp, ReservedTag, ReservedAddr, _), + TypeBody = hlds_du_type(Ctors, ConsTagMap, _CheaperTagTest, + EnumDummy, MaybeUserEqComp, ReservedTag, ReservedAddr, + _IsForeignType), ( MaybeUserEqComp = yes(_), EqualityAxioms = user_defined @@ -400,7 +401,7 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :- some [!Flags] ( !:Flags = set.init, ( - TypeBody = hlds_du_type(_, _, _, _, BodyReservedTag, _, _), + TypeBody = hlds_du_type(_, _, _, _, _, BodyReservedTag, _, _), svset.insert(kind_of_du_flag, !Flags), ( BodyReservedTag = uses_reserved_tag, diff --git a/compiler/type_util.m b/compiler/type_util.m index 1c0e465fa..5ba8bec22 100644 --- a/compiler/type_util.m +++ b/compiler/type_util.m @@ -164,7 +164,7 @@ % If the type is a du type or a tuple type, return the list of its % constructors. % -:- pred type_constructors(mer_type::in, module_info::in, +:- pred type_constructors(module_info::in, mer_type::in, list(constructor)::out) is semidet. % Given a type on which it is possible to have a complete switch, @@ -175,8 +175,8 @@ % and equivalence types will have been expanded out by the time % we consider switches.) % -:- pred switch_type_num_functors(module_info::in, mer_type::in, - int::out) is semidet. +:- pred switch_type_num_functors(module_info::in, mer_type::in, int::out) + is semidet. % Work out the types of the arguments of a functor, given the cons_id % and type of the functor. Aborts if the functor is existentially typed. @@ -395,7 +395,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) @@ -463,7 +463,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) @@ -473,7 +473,7 @@ type_body_definitely_has_no_user_defined_equality_pred(ModuleInfo, Type, ; TypeBody ^ du_type_usereq = no, % type_constructors does substitution of types variables. - type_constructors(Type, ModuleInfo, Ctors), + type_constructors(ModuleInfo, Type, Ctors), list.foldl(ctor_definitely_has_no_user_defined_eq_pred(ModuleInfo), Ctors, !SeenTypes) ) @@ -573,8 +573,8 @@ type_body_is_solver_type(ModuleInfo, TypeBody) :- is_solver_type(ModuleInfo, Type) ). -is_existq_type(Module, Type) :- - type_constructors(Type, Module, Constructors), +is_existq_type(ModuleInfo, Type) :- + type_constructors(ModuleInfo, Type, Constructors), some [Constructor] ( list.member(Constructor, Constructors), Constructor ^ cons_exist = [_ | _] @@ -609,7 +609,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(_, _) ). @@ -737,7 +737,7 @@ type_may_use_atomic_alloc(ModuleInfo, Type) = TypeMayUseAtomic :- %-----------------------------------------------------------------------------% -type_constructors(Type, ModuleInfo, Constructors) :- +type_constructors(ModuleInfo, Type, Constructors) :- type_to_ctor_and_args(Type, TypeCtor, TypeArgs), ( type_ctor_is_tuple(TypeCtor) -> % Tuples are never existentially typed. @@ -745,7 +745,7 @@ type_constructors(Type, ModuleInfo, Constructors) :- ClassConstraints = [], Context = term.context_init, CtorArgs = list.map( - (func(ArgType) = ctor_arg(no, ArgType, Context)), TypeArgs), + (func(ArgType) = ctor_arg(no, ArgType, Context)), TypeArgs), Constructors = [ctor(ExistQVars, ClassConstraints, unqualified("{}"), CtorArgs, Context)] ; diff --git a/compiler/unify_gen.m b/compiler/unify_gen.m index f3541cc26..aa98831ab 100644 --- a/compiler/unify_gen.m +++ b/compiler/unify_gen.m @@ -22,11 +22,14 @@ :- interface. :- import_module hlds.code_model. +:- import_module hlds.hlds_data. :- import_module hlds.hlds_goal. :- import_module ll_backend.code_info. :- import_module ll_backend.llds. :- import_module parse_tree.prog_data. +:- import_module list. + %---------------------------------------------------------------------------% :- type test_sense @@ -36,8 +39,14 @@ :- pred generate_unification(code_model::in, unification::in, hlds_goal_info::in, code_tree::out, code_info::in, code_info::out) is det. -:- pred generate_tag_test(prog_var::in, cons_id::in, test_sense::in, - label::out, code_tree::out, code_info::in, code_info::out) is det. +:- pred generate_tag_test(prog_var::in, cons_id::in, + maybe_cheaper_tag_test::in, test_sense::in, label::out, code_tree::out, + code_info::in, code_info::out) is det. + +:- pred generate_raw_tag_test_case(rval::in, mer_type::in, string::in, + tagged_cons_id::in, list(tagged_cons_id)::in, maybe_cheaper_tag_test::in, + test_sense::in, label::out, code_tree::out, code_info::in, code_info::out) + is det. %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% @@ -50,7 +59,6 @@ :- import_module backend_libs.type_class_info. :- import_module check_hlds.mode_util. :- import_module check_hlds.type_util. -:- import_module hlds.hlds_data. :- import_module hlds.hlds_module. :- import_module hlds.hlds_out. :- import_module hlds.hlds_pred. @@ -71,7 +79,6 @@ :- import_module assoc_list. :- import_module bool. :- import_module int. -:- import_module list. :- import_module map. :- import_module maybe. :- import_module pair. @@ -193,58 +200,95 @@ generate_test(VarA, VarB, Code, !CI) :- %---------------------------------------------------------------------------% -generate_tag_test(Var, ConsId, Sense, ElseLab, Code, !CI) :- - produce_variable(Var, VarCode, Rval, !CI), +generate_raw_tag_test_case(VarRval, VarType, VarName, + MainTaggedConsId, OtherTaggedConsIds, CheaperTagTest, + Sense, ElseLabel, Code, !CI) :- + ( + OtherTaggedConsIds = [], + MainTaggedConsId = tagged_cons_id(MainConsId, MainConsTag), + generate_raw_tag_test(VarRval, VarType, VarName, + MainConsId, yes(MainConsTag), CheaperTagTest, Sense, ElseLabel, + Code, !CI) + ; + OtherTaggedConsIds = [_ | _], + % The cheaper tag test optimization doesn't apply. + project_cons_name_and_tag(MainTaggedConsId, MainConsName, MainConsTag), + list.map2(project_cons_name_and_tag, OtherTaggedConsIds, + OtherConsNames, OtherConsTags), + Comment = branch_sense_comment(Sense) ++ + case_comment(VarName, MainConsName, OtherConsNames), + raw_tag_test(VarRval, MainConsTag, MainTagTestRval), + list.map(raw_tag_test(VarRval), OtherConsTags, OtherTagTestRvals), + disjoin_tag_tests(MainTagTestRval, OtherTagTestRvals, TestRval), + get_next_label(ElseLabel, !CI), + ( + Sense = branch_on_success, + TheRval = TestRval + ; + Sense = branch_on_failure, + code_util.neg_rval(TestRval, TheRval) + ), + Code = node([ + llds_instr(if_val(TheRval, code_label(ElseLabel)), Comment) + ]) + ). + +:- pred disjoin_tag_tests(rval::in, list(rval)::in, rval::out) is det. + +disjoin_tag_tests(CurTestRval, OtherTestRvals, TestRval) :- + ( + OtherTestRvals = [], + TestRval = CurTestRval + ; + OtherTestRvals = [HeadTestRval | TailTestRvals], + NextTestRval = binop(logical_or, CurTestRval, HeadTestRval), + disjoin_tag_tests(NextTestRval, TailTestRvals, TestRval) + ). + +%---------------------------------------------------------------------------% + +generate_tag_test(Var, ConsId, CheaperTagTest, Sense, ElseLabel, Code, !CI) :- + produce_variable(Var, VarCode, VarRval, !CI), + VarType = variable_type(!.CI, Var), + VarName = variable_name(!.CI, Var), + generate_raw_tag_test(VarRval, VarType, VarName, ConsId, no, + CheaperTagTest, Sense, ElseLabel, TestCode, !CI), + Code = tree(VarCode, TestCode). + +:- pred generate_raw_tag_test(rval::in, mer_type::in, string::in, + cons_id::in, maybe(cons_tag)::in, + maybe_cheaper_tag_test::in, test_sense::in, label::out, code_tree::out, + code_info::in, code_info::out) is det. + +generate_raw_tag_test(VarRval, VarType, VarName, ConsId, MaybeConsTag, + CheaperTagTest, Sense, ElseLabel, Code, !CI) :- + ConsIdName = hlds_out.cons_id_to_string(ConsId), % As an optimization, for data types with exactly two alternatives, % one of which is a constant, we make sure that we test against the % constant (negating the result of the test, if needed), % since a test against a constant is cheaper than a tag test. ( - ConsId = cons(_, Arity), - Arity > 0 + CheaperTagTest = cheaper_tag_test(ExpensiveConsId, _ExpensiveConsTag, + _CheapConsId, CheapConsTag), + ConsId = ExpensiveConsId -> - Type = variable_type(!.CI, Var), - TypeDefn = lookup_type_defn(!.CI, Type), - hlds_data.get_type_defn_body(TypeDefn, TypeBody), - ( ConsTable = TypeBody ^ du_type_cons_tag_values -> - map.to_assoc_list(ConsTable, ConsList), - ( - ConsList = [ConsId - _, OtherConsId - _], - OtherConsId = cons(_, 0) - -> - Reverse = yes(OtherConsId) - ; - ConsList = [OtherConsId - _, ConsId - _], - OtherConsId = cons(_, 0) - -> - Reverse = yes(OtherConsId) - ; - Reverse = no - ) - ; - Reverse = no - ) - ; - Reverse = no - ), - VarName = variable_to_string(!.CI, Var), - ConsIdName = hlds_out.cons_id_to_string(ConsId), - Comment0 = "checking that " ++ VarName ++ " has functor " ++ ConsIdName, - ( - Reverse = no, - Comment = Comment0, - CommentCode = node([llds_instr(comment(Comment), "")]), - Tag = cons_id_to_tag_for_var(!.CI, Var, ConsId), - generate_tag_test_rval_2(Tag, Rval, TestRval) - ; - Reverse = yes(TestConsId), - Comment = Comment0 ++ " (inverted test)", - CommentCode = node([llds_instr(comment(Comment), "")]), - Tag = cons_id_to_tag_for_var(!.CI, Var, TestConsId), - generate_tag_test_rval_2(Tag, Rval, NegTestRval), + Comment = branch_sense_comment(Sense) ++ VarName ++ + " has functor " ++ ConsIdName ++ " (inverted test)", + raw_tag_test(VarRval, CheapConsTag, NegTestRval), code_util.neg_rval(NegTestRval, TestRval) + ; + Comment = branch_sense_comment(Sense) ++ VarName ++ + " has functor " ++ ConsIdName, + ( + MaybeConsTag = yes(ConsTag) + % Our caller has already computed ConsTag. + ; + MaybeConsTag = no, + ConsTag = cons_id_to_tag_for_type(!.CI, VarType, ConsId) + ), + raw_tag_test(VarRval, ConsTag, TestRval) ), - get_next_label(ElseLab, !CI), + get_next_label(ElseLabel, !CI), ( Sense = branch_on_success, TheRval = TestRval @@ -252,25 +296,22 @@ generate_tag_test(Var, ConsId, Sense, ElseLab, Code, !CI) :- Sense = branch_on_failure, code_util.neg_rval(TestRval, TheRval) ), - TestCode = node([ - llds_instr(if_val(TheRval, code_label(ElseLab)), "tag test") - ]), - Code = tree_list([VarCode, CommentCode, TestCode]). + Code = node([ + llds_instr(if_val(TheRval, code_label(ElseLabel)), Comment) + ]). + +:- func branch_sense_comment(test_sense) = string. + +branch_sense_comment(branch_on_success) = + "branch away if ". +branch_sense_comment(branch_on_failure) = + "branch away unless ". %---------------------------------------------------------------------------% -:- pred generate_tag_test_rval(prog_var::in, cons_id::in, - rval::out, code_tree::out, code_info::in, code_info::out) is det. +:- pred raw_tag_test(rval::in, cons_tag::in, rval::out) is det. -generate_tag_test_rval(Var, ConsId, TestRval, Code, !CI) :- - produce_variable(Var, Code, Rval, !CI), - Tag = cons_id_to_tag_for_var(!.CI, Var, ConsId), - generate_tag_test_rval_2(Tag, Rval, TestRval). - -:- pred generate_tag_test_rval_2(cons_tag::in, rval::in, rval::out) - is det. - -generate_tag_test_rval_2(ConsTag, Rval, TestRval) :- +raw_tag_test(Rval, ConsTag, TestRval) :- ( ConsTag = string_tag(String), TestRval = binop(str_eq, Rval, const(llconst_string(String))) @@ -338,11 +379,11 @@ generate_tag_test_rval_2(ConsTag, Rval, TestRval) :- % We first check that the Rval doesn't match any of the ReservedAddrs, % and then check that it matches ThisTag. CheckReservedAddrs = (func(RA, InnerTestRval0) = InnerTestRval :- - generate_tag_test_rval_2(reserved_address_tag(RA), Rval, EqualRA), + raw_tag_test(Rval, reserved_address_tag(RA), EqualRA), InnerTestRval = binop(logical_and, unop(logical_not, EqualRA), InnerTestRval0) ), - generate_tag_test_rval_2(ThisTag, Rval, MatchesThisTag), + raw_tag_test(Rval, ThisTag, MatchesThisTag), TestRval = list.foldr(CheckReservedAddrs, ReservedAddrs, MatchesThisTag) ). @@ -1026,12 +1067,15 @@ generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI) :- code_info::in, code_info::out) is det. generate_semi_deconstruction(Var, Tag, Args, Modes, Code, !CI) :- - generate_tag_test(Var, Tag, branch_on_success, SuccLab, TagTestCode, !CI), + VarType = variable_type(!.CI, Var), + CheaperTagTest = lookup_cheaper_tag_test(!.CI, VarType), + generate_tag_test(Var, Tag, CheaperTagTest, branch_on_success, SuccLabel, + TagTestCode, !CI), remember_position(!.CI, AfterUnify), generate_failure(FailCode, !CI), reset_to_position(AfterUnify, !CI), generate_det_deconstruction(Var, Tag, Args, Modes, DeconsCode, !CI), - SuccessLabelCode = node([llds_instr(label(SuccLab), "")]), + SuccessLabelCode = node([llds_instr(label(SuccLabel), "")]), Code = tree_list([TagTestCode, FailCode, SuccessLabelCode, DeconsCode]). %---------------------------------------------------------------------------% diff --git a/compiler/unify_proc.m b/compiler/unify_proc.m index ad651665b..5dee82456 100644 --- a/compiler/unify_proc.m +++ b/compiler/unify_proc.m @@ -552,8 +552,8 @@ add_lazily_generated_unify_pred(TypeCtor, PredId, !ModuleInfo) :- ReservedTag = does_not_use_reserved_tag, ReservedAddr = does_not_use_reserved_address, IsForeign = no, - TypeBody = hlds_du_type([Ctor], ConsTagValues, IsEnum, UnifyPred, - ReservedTag, ReservedAddr, IsForeign), + TypeBody = hlds_du_type([Ctor], ConsTagValues, no_cheaper_tag_test, + IsEnum, UnifyPred, ReservedTag, ReservedAddr, IsForeign), construct_type(TypeCtor, TupleArgTypes, Type), term.context_init(Context) @@ -759,7 +759,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(_) ), @@ -788,7 +788,7 @@ generate_unify_proc_body(Type, TypeBody, X, Y, Context, Clause, !Info) :- Clause, !Info) ; ( - TypeBody = hlds_du_type(Ctors, _, EnumDummy, _, _, _, _), + TypeBody = hlds_du_type(Ctors, _, _, EnumDummy, _, _, _, _), ( ( EnumDummy = is_mercury_enum ; EnumDummy = is_foreign_enum(_) @@ -1000,7 +1000,7 @@ generate_index_proc_body(TypeBody, X, Index, Context, Clause, !Info) :- "trying to create index proc for non-canonical type") ; ( - TypeBody = hlds_du_type(Ctors, _, EnumDummy, _, _, _, _), + TypeBody = hlds_du_type(Ctors, _, _, EnumDummy, _, _, _, _), ( % For enum types, the generated comparison predicate performs % an integer comparison, and does not call the type's index @@ -1066,7 +1066,7 @@ generate_compare_proc_body(Type, TypeBody, Res, X, Y, Context, Clause, Res, X, Y, Context, Clause, !Info) ; ( - TypeBody = hlds_du_type(Ctors0, _, EnumDummy, _, _, _, _), + TypeBody = hlds_du_type(Ctors0, _, _, EnumDummy, _, _, _, _), ( ( EnumDummy = is_mercury_enum ; EnumDummy = is_foreign_enum(_) diff --git a/compiler/unique_modes.m b/compiler/unique_modes.m index 62f4225f4..e07377d3b 100644 --- a/compiler/unique_modes.m +++ b/compiler/unique_modes.m @@ -815,16 +815,15 @@ prepare_for_disjunct(Goal0, DisjDetism, DisjNonLocals, !ModeInfo) :- unique_modes_check_case_list([], _Var, [], [], !ModeInfo, !IO). unique_modes_check_case_list([Case0 | Cases0], Var, [Case | Cases], [InstMap | InstMaps], !ModeInfo, !IO) :- - Case0 = case(ConsId, Goal0), - Case = case(ConsId, Goal), + Case0 = case(MainConsId, OtherConsIds, Goal0), mode_info_get_instmap(!.ModeInfo, InstMap0), % If you modify this code, you may also need to modify % unique_modecheck_clause_switch or the code that calls it. - % Record the fact that Var was bound to ConsId in the instmap before - % processing this case. - modecheck_functor_test(Var, ConsId, !ModeInfo), + % Update the instmap to reflect the binding of Var to MainConsId or + % one of the OtherConsIds before processing this case. + modecheck_functors_test(Var, MainConsId, OtherConsIds, !ModeInfo), mode_info_get_instmap(!.ModeInfo, InstMap1), ( instmap.is_reachable(InstMap1) -> @@ -838,6 +837,7 @@ unique_modes_check_case_list([Case0 | Cases0], Var, [Case | Cases], mode_info_get_instmap(!.ModeInfo, InstMap), fixup_switch_var(Var, InstMap0, InstMap, Goal1, Goal), + Case = case(MainConsId, OtherConsIds, Goal), mode_info_set_instmap(InstMap0, !ModeInfo), unique_modes_check_case_list(Cases0, Var, Cases, InstMaps, !ModeInfo, !IO). diff --git a/compiler/unneeded_code.m b/compiler/unneeded_code.m index 2810873eb..5edd99193 100644 --- a/compiler/unneeded_code.m +++ b/compiler/unneeded_code.m @@ -667,7 +667,7 @@ process_goal_internal(Goal0, Goal, InitInstMap, FinalInstMap, VarTypes, ; GoalExpr0 = switch(SwitchVar, CanFail, Cases0), ( - Cases0 = [case(_, hlds_goal(_, FirstCaseGoalInfo)) | _], + Cases0 = [case(_, _, hlds_goal(_, FirstCaseGoalInfo)) | _], FirstCaseGoalPath = goal_info_get_goal_path(FirstCaseGoalInfo), cord.get_last(FirstCaseGoalPath, FirstCaseLastStep), FirstCaseLastStep = step_switch(_, MaybeNumAltPrime) @@ -813,13 +813,14 @@ process_disj([Goal0 | Goals0], [Goal | Goals], InitInstMap, FinalInstMap, process_cases([], [], _, _, _, _, _, _, _, _, _, !WhereNeededMap, !RefinedGoals, !Changed). -process_cases([case(Var, Goal0) | Cases0], [case(Var, Goal) | Cases], - BranchPoint, BranchNum, InitInstMap, FinalInstMap, VarTypes, - ModuleInfo, Options, CurrentPath, StartWhereNeededMap, - !WhereNeededMap, !RefinedGoals, !Changed) :- +process_cases([Case0 | Cases0], [Case | Cases], BranchPoint, BranchNum, + InitInstMap, FinalInstMap, VarTypes, ModuleInfo, Options, CurrentPath, + StartWhereNeededMap, !WhereNeededMap, !RefinedGoals, !Changed) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), process_goal(Goal0, Goal, InitInstMap, FinalInstMap, VarTypes, ModuleInfo, Options, StartWhereNeededMap, WhereNeededMapFirst, !RefinedGoals, !Changed), + Case = case(MainConsId, OtherConsIds, Goal), map.to_assoc_list(WhereNeededMapFirst, WhereNeededList), add_alt_start(WhereNeededList, BranchPoint, BranchNum, CurrentPath, !WhereNeededMap), @@ -1006,8 +1007,9 @@ refine_conj([Goal0 | Goals0], Goals, !RefinedGoals) :- goal_path::in, int::in) is det. refine_cases([], [], !RefinedGoals, _, _). -refine_cases([case(Var, Goal0) | Cases0], [case(Var, Goal) | Cases], - !RefinedGoals, GoalPath, BranchNum) :- +refine_cases([Case0 | Cases0], [Case | Cases], !RefinedGoals, GoalPath, + BranchNum) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), refine_goal(Goal0, Goal1, !RefinedGoals), ( map.search(!.RefinedGoals, GoalPath - BranchNum, ToInsertGoals) -> insert_refine_goals(ToInsertGoals, Goal1, Goal), @@ -1015,6 +1017,7 @@ refine_cases([case(Var, Goal0) | Cases0], [case(Var, Goal) | Cases], ; Goal = Goal1 ), + Case = case(MainConsId, OtherConsIds, Goal), refine_cases(Cases0, Cases, !RefinedGoals, GoalPath, BranchNum + 1). :- pred refine_disj(list(hlds_goal)::in, list(hlds_goal)::out, diff --git a/compiler/untupling.m b/compiler/untupling.m index 5c8f895c8..5e50029df 100644 --- a/compiler/untupling.m +++ b/compiler/untupling.m @@ -626,10 +626,10 @@ fix_calls_in_goal_list([Goal0 | Goals0], [Goal | Goals], !VarSet, !VarTypes, fix_calls_in_cases([], [], !VarSet, !VarTypes, _, _). fix_calls_in_cases([Case0 | Cases0], [Case | Cases], !VarSet, !VarTypes, TransformMap, ModuleInfo) :- - Case0 = case(Functor, Goal0), + Case0 = case(MainConsId, OtherConsIds, Goal0), fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap, ModuleInfo), - Case = case(Functor, Goal), + Case = case(MainConsId, OtherConsIds, Goal), fix_calls_in_cases(Cases0, Cases, !VarSet, !VarTypes, TransformMap, ModuleInfo). diff --git a/compiler/unused_args.m b/compiler/unused_args.m index 524022e89..5db143898 100644 --- a/compiler/unused_args.m +++ b/compiler/unused_args.m @@ -839,7 +839,7 @@ add_construction_aliases(Alias, [Var | Vars], !VarDep) :- :- pred list_case_to_list_goal(list(case)::in, list(hlds_goal)::out) is det. list_case_to_list_goal([], []). -list_case_to_list_goal([case(_, Goal) | Cases], [Goal | Goals]) :- +list_case_to_list_goal([case(_, _, Goal) | Cases], [Goal | Goals]) :- list_case_to_list_goal(Cases, Goals). :- pred traverse_list_of_goals(traverse_info::in, list(hlds_goal)::in, @@ -1601,9 +1601,10 @@ fixup_disjuncts([Goal0 | Goals0], [Goal | Goals], !Info, !Changed) :- fixup_info::in, fixup_info::out, bool::in, bool::out) is det. fixup_cases([], [], !Info, !Changed). -fixup_cases([case(ConsId, Goal0) | Cases0], [case(ConsId, Goal) | Cases], - !Info, !Changed) :- +fixup_cases([Case0 | Cases0], [Case | Cases], !Info, !Changed) :- + Case0 = case(MainConsId, OtherConsIds, Goal0), fixup_goal(Goal0, Goal, !Info, LocalChanged), + Case = case(MainConsId, OtherConsIds, Goal), ( LocalChanged = yes, !:Changed = yes diff --git a/compiler/unused_imports.m b/compiler/unused_imports.m index 4fec76142..62341881c 100644 --- a/compiler/unused_imports.m +++ b/compiler/unused_imports.m @@ -195,7 +195,7 @@ type_used_modules(_TypeCtor, TypeDefn, !UsedModules) :- ( status_defined_in_this_module(ImportStatus) = 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), @@ -407,11 +407,7 @@ hlds_goal_expr_used_modules(conj(_, Goals), !UsedModules) :- hlds_goal_expr_used_modules(disj(Goals), !UsedModules) :- list.foldl(hlds_goal_used_modules, Goals, !UsedModules). hlds_goal_expr_used_modules(switch(_, _, Cases), !UsedModules) :- - list.foldl( - (pred(case(ConsId, Goal)::in, !.M::in, !:M::out) is det :- - cons_id_used_modules(visibility_private, ConsId, !M), - hlds_goal_used_modules(Goal, !M) - ), Cases, !UsedModules). + list.foldl(case_used_modules, Cases, !UsedModules). hlds_goal_expr_used_modules(negation(Goal), !UsedModules) :- hlds_goal_used_modules(Goal, !UsedModules). hlds_goal_expr_used_modules(scope(_, Goal), !UsedModules) :- @@ -425,6 +421,16 @@ hlds_goal_expr_used_modules(shorthand(bi_implication(GoalA, GoalB)), hlds_goal_used_modules(GoalA, !UsedModules), hlds_goal_used_modules(GoalB, !UsedModules). +:- pred case_used_modules(case::in, used_modules::in, used_modules::out) + is det. + +case_used_modules(Case, !UsedModules) :- + Case = case(MainConsId, OtherConsIds, Goal), + cons_id_used_modules(visibility_private, MainConsId, !UsedModules), + list.foldl(cons_id_used_modules(visibility_private), OtherConsIds, + !UsedModules), + hlds_goal_used_modules(Goal, !UsedModules). + :- pred unify_rhs_used_modules(unify_rhs::in, used_modules::in, used_modules::out) is det. diff --git a/compiler/xml_documentation.m b/compiler/xml_documentation.m index 8414ce140..917a6b3f1 100644 --- a/compiler/xml_documentation.m +++ b/compiler/xml_documentation.m @@ -373,7 +373,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". @@ -387,7 +387,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/deep_profiler/mdprof_procrep.m b/deep_profiler/mdprof_procrep.m index 6912a5e08..35cbbc32e 100644 --- a/deep_profiler/mdprof_procrep.m +++ b/deep_profiler/mdprof_procrep.m @@ -236,12 +236,20 @@ print_switch(Indent, [CaseRep | CaseReps], PrintSemi, !IO) :- indent(Indent, !IO), io.write_string(";\n", !IO) ), - CaseRep = case_rep(ConsIdRep, Arity, GoalRep), - indent(Indent + 1, !IO), - io.format("%% case %s/%d\n", [s(ConsIdRep), i(Arity)], !IO), + CaseRep = case_rep(MainConsIdArityRep, OtherConsIdArityRep, GoalRep), + print_cons_id_and_arity(Indent + 1, MainConsIdArityRep, !IO), + list.foldl(print_cons_id_and_arity(Indent + 1), OtherConsIdArityRep, !IO), print_goal(Indent + 1, GoalRep, !IO), print_switch(Indent, CaseReps, yes, !IO). +:- pred print_cons_id_and_arity(int::in, cons_id_arity_rep::in, + io::di, io::uo) is det. + +print_cons_id_and_arity(Indent, ConsIdArityRep, !IO) :- + ConsIdArityRep = cons_id_arity_rep(ConsIdRep, Arity), + indent(Indent + 1, !IO), + io.format("%% case %s/%d\n", [s(ConsIdRep), i(Arity)], !IO). + %-----------------------------------------------------------------------------% :- pred print_atomic_goal(int::in, atomic_goal_rep::in, io::di, io::uo) is det. diff --git a/mdbcomp/program_representation.m b/mdbcomp/program_representation.m index 22499279e..4e09145b1 100644 --- a/mdbcomp/program_representation.m +++ b/mdbcomp/program_representation.m @@ -151,9 +151,12 @@ :- type case_rep ---> case_rep( - cons_id_rep, % The function symbol unified with the - % switched-on in this switch arm. - int, % The arity of the function symbol. + cons_id_arity_rep, % The name and arity of the first + % function symbol for which this switch arm + % is applicable. + list(cons_id_arity_rep), + % The names and arities of any other + % function symbols for this switch arm. goal_rep % The code of the switch arm. ). @@ -233,6 +236,12 @@ :- type var_rep == int. +:- type cons_id_arity_rep + ---> cons_id_arity_rep( + cons_id_rep, + int + ). + :- type cons_id_rep == string. :- type detism_rep @@ -1113,10 +1122,12 @@ read_cases(VarNumRep, ByteCode, StringTable, Info, Cases, !Pos) :- read_cases_2(VarNumRep, ByteCode, StringTable, Info, N, Cases, !Pos) :- ( N > 0 -> - read_cons_id(ByteCode, StringTable, ConsId, !Pos), - read_short(ByteCode, ConsIdArity, !Pos), + read_cons_id_arity(ByteCode, StringTable, MainConsId, !Pos), + read_length(ByteCode, NumOtherConsIds, !Pos), + read_n_cons_id_arities(ByteCode, StringTable, NumOtherConsIds, + OtherConsIds, !Pos), read_goal(VarNumRep, ByteCode, StringTable, Info, Goal, !Pos), - Head = case_rep(ConsId, ConsIdArity, Goal), + Head = case_rep(MainConsId, OtherConsIds, Goal), read_cases_2(VarNumRep, ByteCode, StringTable, Info, N - 1, Tail, !Pos), Cases = [Head | Tail] @@ -1124,6 +1135,26 @@ read_cases_2(VarNumRep, ByteCode, StringTable, Info, N, Cases, !Pos) :- Cases = [] ). +:- pred read_cons_id_arity(bytecode::in, string_table::in, + cons_id_arity_rep::out, int::in, int::out) is semidet. + +read_cons_id_arity(ByteCode, StringTable, ConsId, !Pos) :- + read_cons_id(ByteCode, StringTable, ConsIdFunctor, !Pos), + read_short(ByteCode, ConsIdArity, !Pos), + ConsId = cons_id_arity_rep(ConsIdFunctor, ConsIdArity). + +:- pred read_n_cons_id_arities(bytecode::in, string_table::in, int::in, + list(cons_id_arity_rep)::out, int::in, int::out) is semidet. + +read_n_cons_id_arities(ByteCode, StringTable, N, ConsIds, !Pos) :- + ( N > 0 -> + read_cons_id_arity(ByteCode, StringTable, Head, !Pos), + read_n_cons_id_arities(ByteCode, StringTable, N - 1, Tail, !Pos), + ConsIds = [Head | Tail] + ; + ConsIds = [] + ). + :- pred read_vars(var_num_rep::in, bytecode::in, list(var_rep)::out, int::in, int::out) is semidet. diff --git a/tools/binary b/tools/binary index 7762214fd..1f314594f 100755 --- a/tools/binary +++ b/tools/binary @@ -102,9 +102,23 @@ while [ $# -gt 0 ]; do dependency_only="-d" ;; -D|--dir) - alldirs="$2"; shift ;; + if test "$alldirs" = "" + then + alldirs="$2"; shift + else + echo "You can specify only one directory." 1>&2 + exit 1 + fi + ;; -D*) - alldirs="` expr $1 : '-d\(.*\)' `"; ;; + if test "$alldirs" = "" + then + alldirs="` expr $1 : '-d\(.*\)' `" + else + echo "You can specify only one directory." 1>&2 + exit 1 + fi + ;; -f|--file) allmodules="$allmodules $2"; shift ;; @@ -502,6 +516,13 @@ then exit 1 fi else + for subdir in library mdbcomp analysis compiler + do + echo linking stage2/$subdir from stage2.ok/$subdir 1>&2 + cp stage2.ok/$subdir/*.[co] stage2/$subdir + cp stage2.ok/$subdir/*.pic_o stage2/$subdir + done + testeddir=$alldirs if test ! -d stage2/$testeddir then