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