%-----------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et %-----------------------------------------------------------------------------% % Copyright (C) 2001-2002, 2004-2012 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: hhf.m. % Author: dmo. % % Convert superhomogeneous form to hyperhomogeneous form and output an % inst graph for the predicate based on this transformation. % % Hyperhomogeneous form and the transformation are documented in % David Overton's PhD thesis. % %-----------------------------------------------------------------------------% :- module hlds.hhf. :- interface. :- import_module hlds.hlds_clauses. :- import_module hlds.hlds_module. :- import_module hlds.hlds_pred. :- import_module hlds.inst_graph. :- import_module bool. :- import_module io. %-----------------------------------------------------------------------------% :- pred convert_pred_to_hhf(io.text_output_stream::in, bool::in, pred_id::in, module_info::in, module_info::out, io::di, io::uo) is det. :- pred convert_clauses_info_to_hhf(bool::in, module_info::in, clauses_info::in, clauses_info::out, inst_graph::out) is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module check_hlds. :- import_module check_hlds.type_util. :- import_module hlds.goal_util. :- import_module hlds.hlds_goal. :- import_module hlds.passes_aux. :- import_module mdbcomp. :- import_module mdbcomp.sym_name. :- import_module parse_tree. :- import_module parse_tree.prog_data. :- import_module parse_tree.prog_type. :- import_module parse_tree.set_of_var. :- import_module parse_tree.var_table. :- import_module list. :- import_module map. :- import_module require. :- import_module solutions. :- import_module term. %-----------------------------------------------------------------------------% convert_pred_to_hhf(ProgressStream, Simple, PredId, !ModuleInfo, !IO) :- module_info_pred_info(!.ModuleInfo, PredId, PredInfo0), ( if pred_info_is_imported(PredInfo0) then % AAA % PredInfo2 = PredInfo0 pred_info_get_clauses_info(PredInfo0, ClausesInfo), clauses_info_get_headvar_list(ClausesInfo, HeadVars), clauses_info_get_var_table(ClausesInfo, VarTable), some [!IG] ( pred_info_get_inst_graph_info(PredInfo0, !:IG), inst_graph.init(HeadVars, InstGraph), !IG ^ implementation_inst_graph := InstGraph, !IG ^ interface_inst_graph := InstGraph, !IG ^ interface_vars := HeadVars, !IG ^ interface_var_table := VarTable, pred_info_set_inst_graph_info(!.IG, PredInfo0, PredInfo2) ) else maybe_write_pred_progress_message(ProgressStream, !.ModuleInfo, "Calculating HHF and inst graph for", PredId, !IO), pred_info_get_clauses_info(PredInfo0, ClausesInfo0), convert_clauses_info_to_hhf(Simple, !.ModuleInfo, ClausesInfo0, ClausesInfo, ImplementationInstGraph), pred_info_set_clauses_info(ClausesInfo, PredInfo0, PredInfo1), some [!IG] ( pred_info_get_inst_graph_info(PredInfo1, !:IG), !IG ^ implementation_inst_graph := ImplementationInstGraph, % AAA only for non-imported preds with no mode decls. clauses_info_get_headvar_list(ClausesInfo, HeadVars), clauses_info_get_var_table(ClausesInfo, VarTable), !IG ^ interface_inst_graph := ImplementationInstGraph, solutions( (pred(V::out) is nondet :- list.member(V0, HeadVars), inst_graph.reachable(ImplementationInstGraph, V0, V) ), InterfaceVars), !IG ^ interface_vars := InterfaceVars, !IG ^ interface_var_table := VarTable, pred_info_set_inst_graph_info(!.IG, PredInfo1, PredInfo2) ) ), % pred_info_get_markers(PredInfo2, Markers), % ( if check_marker(Markers, infer_modes) then % % No mode declarations. If not imported, use implementation % % inst_graph. % % ... % else % pred_info_clauses_info(PredInfo2, ClausesInfo2), % clauses_info_get_headvars(ClausesInfo2, HeadVars), % clauses_info_get_varset(ClausesInfo2, VarSet), % inst_graph.init(HeadVars, InterfaceInstGraph), % InstGraphInfo0 = ( (PredInfo2 ^ inst_graph_info) % ^ interface_inst_graph := InterfaceInstGraph ) % ^ interface_varset := VarSet, % map.foldl(process_proc(ModuleInfo0, HeadVars), % Procedures, InstGraphInfo0, InstGraphInfo1), % % % Calculate interface vars. % solutions((pred(V::out) is nondet :- % list.member(V0, HeadVars), % inst_graph.reachable(InstGraph, V0, V) % ), InterfaceVars), % InstGraphInfo = InstGraphInfo1 ^ interface_vars := % InterfaceVars, % % PredInfo = PredInfo2 ^ inst_graph_info := InstGraphInfo % ), PredInfo = PredInfo2, % AAA module_info_set_pred_info(PredId, PredInfo, !ModuleInfo). convert_clauses_info_to_hhf(Simple, ModuleInfo, !ClausesInfo, InstGraph) :- clauses_info_get_var_table(!.ClausesInfo, VarTable0), var_table_vars(VarTable0, Vars0), inst_graph.init(Vars0, InstGraph0), Info0 = hhf_info(ModuleInfo, InstGraph0, VarTable0), clauses_info_get_headvar_list(!.ClausesInfo, HeadVars), clauses_info_clauses(Clauses0, ItemNumbers, !ClausesInfo), ( % % For simple mode checking we do not give the inst_graph any % % structure. % Simple = yes, % Clauses = Clauses0, % Info1 = Info0 %; % Simple = no, list.map_foldl(convert_clause_to_hhf(HeadVars), Clauses0, Clauses, Info0, Info1) ), set_clause_list(Clauses, ClausesRep), clauses_info_set_clauses_rep(ClausesRep, ItemNumbers, !ClausesInfo), complete_inst_graph(Info1, Info), % XXX Comment out the above line for incomplete, quick checking. % Info = Info1, Info = hhf_info(_, InstGraph1, VarTable), ( Simple = yes, var_table_vars(VarTable, Vars), inst_graph.init(Vars, InstGraph) ; Simple = no, InstGraph = InstGraph1 ), % XXX do we need this (it slows things down a lot (i.e. uses 50% % of the runtime). % varset.vars(VarSet1, Vars1), % varset.ensure_unique_names(Vars1, "_", VarSet1, VarSet), clauses_info_set_var_table(VarTable, !ClausesInfo). :- type hhf_info ---> hhf_info( hhfi_module_info :: module_info, hhfi_inst_graph :: inst_graph, hhfi_var_table :: var_table ). :- pred convert_clause_to_hhf(list(prog_var)::in, clause::in, clause::out, hhf_info::in, hhf_info::out) is det. convert_clause_to_hhf(_HeadVars, Clause0, Clause, !HI) :- Goal0 = Clause0 ^ clause_body, Goal0 = hlds_goal(_, GoalInfo0), NonLocals = goal_info_get_nonlocals(GoalInfo0), convert_goal_to_hhf(NonLocals, Goal0, Goal, !HI), Clause = Clause0 ^ clause_body := Goal. % XXX We probably need to requantify, but doing so stuffs up the % inst_graph. :- pred convert_goal_to_hhf(set_of_progvar::in, hlds_goal::in, hlds_goal::out, hhf_info::in, hhf_info::out) is det. convert_goal_to_hhf(NonLocals, Goal0, Goal, !HI) :- Goal0 = hlds_goal(GoalExpr0, GoalInfo), convert_goal_expr_to_hhf(NonLocals, GoalInfo, GoalExpr0, GoalExpr, !HI), Goal = hlds_goal(GoalExpr, GoalInfo). :- pred goal_use_own_nonlocals(hlds_goal::in, hlds_goal::out, hhf_info::in, hhf_info::out) is det. goal_use_own_nonlocals(Goal0, Goal, !HI) :- Goal0 = hlds_goal(GoalExpr0, GoalInfo), NonLocals = goal_info_get_nonlocals(GoalInfo), convert_goal_expr_to_hhf(NonLocals, GoalInfo, GoalExpr0, GoalExpr, !HI), Goal = hlds_goal(GoalExpr, GoalInfo). :- pred convert_goal_expr_to_hhf(set_of_progvar::in, hlds_goal_info::in, hlds_goal_expr::in, hlds_goal_expr::out, hhf_info::in, hhf_info::out) is det. convert_goal_expr_to_hhf(NonLocals, GoalInfo, GoalExpr0, GoalExpr, !HI) :- ( GoalExpr0 = unify(Var, RHS, Mode, Unif, Context), convert_unify_to_hhf(RHS, NonLocals, GoalInfo, Var, Mode, Unif, Context, GoalExpr, !HI) ; GoalExpr0 = plain_call(_, _, _, _, _, _), GoalExpr = GoalExpr0 ; GoalExpr0 = generic_call(_, _, _, _, _), GoalExpr = GoalExpr0 ; GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _), GoalExpr = GoalExpr0 ; GoalExpr0 = conj(ConjType, Goals0), list.map_foldl(convert_goal_to_hhf(NonLocals), Goals0, Goals1, !HI), ( ConjType = plain_conj, flatten_conj(Goals1, Goals) ; ConjType = parallel_conj, Goals = Goals1 ), GoalExpr = conj(ConjType, Goals) ; GoalExpr0 = disj(Goals0), list.map_foldl(goal_use_own_nonlocals, Goals0, Goals, !HI), GoalExpr = disj(Goals) ; GoalExpr0 = switch(_, _, _), unexpected($pred, "switch") ; GoalExpr0 = scope(Reason, SubGoal0), convert_goal_to_hhf(NonLocals, SubGoal0, SubGoal, !HI), GoalExpr = scope(Reason, SubGoal) ; GoalExpr0 = negation(SubGoal0), convert_goal_to_hhf(NonLocals, SubGoal0, SubGoal, !HI), GoalExpr = negation(SubGoal) ; GoalExpr0 = if_then_else(Vs, Cond0, Then0, Else0), convert_goal_to_hhf(NonLocals, Cond0, Cond, !HI), Then0 = hlds_goal(ThenExpr0, ThenInfo), ThenNonLocals = goal_info_get_nonlocals(ThenInfo), convert_goal_expr_to_hhf(ThenNonLocals, ThenInfo, ThenExpr0, ThenExpr, !HI), Then = hlds_goal(ThenExpr, ThenInfo), Else0 = hlds_goal(ElseExpr0, ElseInfo), ElseNonLocals = goal_info_get_nonlocals(ElseInfo), convert_goal_expr_to_hhf(ElseNonLocals, ElseInfo, ElseExpr0, ElseExpr, !HI), Else = hlds_goal(ElseExpr, ElseInfo), GoalExpr = if_then_else(Vs, Cond, Then, Else) ; GoalExpr0 = shorthand(_), unexpected($pred, "shorthand") ). :- pred convert_unify_to_hhf(unify_rhs::in, set_of_progvar::in, hlds_goal_info::in, prog_var::in, unify_mode::in, unification::in, unify_context::in, hlds_goal_expr::out, hhf_info::in, hhf_info::out) is det. convert_unify_to_hhf(RHS0, NonLocals, GoalInfo0, X, Mode, Unif, Context, GoalExpr, !HI) :- ( RHS0 = rhs_lambda_goal(A, B, C, D, E, F, G, LambdaGoal0), convert_goal_to_hhf(NonLocals, LambdaGoal0, LambdaGoal, !HI), RHS = rhs_lambda_goal(A, B, C, D, E, F, G, LambdaGoal), GoalExpr = unify(X, RHS, Mode, Unif, Context) ; RHS0 = rhs_var(_), GoalExpr = unify(X, RHS0, Mode, Unif, Context) ; RHS0 = rhs_functor(ConsId0, IsExistConstruct, ArgsA), qualify_cons_id(ArgsA, ConsId0, _, ConsId), InstGraph0 = !.HI ^ hhfi_inst_graph, map.lookup(InstGraph0, X, node(Functors0, MaybeParent)), ( if map.search(Functors0, ConsId, ArgsB) then make_unifications(ArgsA, ArgsB, GoalInfo0, Mode, Unif, Context, Unifications), Args = ArgsB else add_unifications(ArgsA, NonLocals, GoalInfo0, Mode, Unif, Context, Args, Unifications, !HI), InstGraph1 = !.HI ^ hhfi_inst_graph, map.det_insert(ConsId, Args, Functors0, Functors), map.det_update(X, node(Functors, MaybeParent), InstGraph1, InstGraph2), list.foldl(inst_graph.set_parent(X), Args, InstGraph2, InstGraph), !HI ^ hhfi_inst_graph := InstGraph ), GINonlocals0 = goal_info_get_nonlocals(GoalInfo0), GINonlocals = set_of_var.union(GINonlocals0, list_to_set(Args)), goal_info_set_nonlocals(GINonlocals, GoalInfo0, GoalInfo), RHS = rhs_functor(ConsId, IsExistConstruct, Args), UnifyGoalExpr = unify(X, RHS, Mode, Unif, Context), UnifyGoal = hlds_goal(UnifyGoalExpr, GoalInfo), GoalExpr = conj(plain_conj, [UnifyGoal | Unifications]) ). :- pred make_unifications(list(prog_var)::in, list(prog_var)::in, hlds_goal_info::in, unify_mode::in, unification::in, unify_context::in, hlds_goals::out) is det. make_unifications([], [], _, _, _, _, []). make_unifications([_ | _], [], _, _, _, _, _) :- unexpected($pred, "length mismatch (1)"). make_unifications([], [_ | _], _, _, _, _, _) :- unexpected($pred, "length mismatch (2)"). make_unifications([A | As], [B | Bs], GI0, M, U, C, [hlds_goal(unify(A, rhs_var(B), M, U, C), GI) | Us]) :- GINonlocals0 = goal_info_get_nonlocals(GI0), set_of_var.insert_list([A, B], GINonlocals0, GINonlocals), goal_info_set_nonlocals(GINonlocals, GI0, GI), make_unifications(As, Bs, GI0, M, U, C, Us). :- pred add_unifications(list(prog_var)::in, set_of_progvar::in, hlds_goal_info::in, unify_mode::in, unification::in, unify_context::in, list(prog_var)::out, hlds_goals::out, hhf_info::in, hhf_info::out) is det. add_unifications([], _, _, _, _, _, [], [], !HI). add_unifications([A | As], NonLocals, GI0, M, U, C, [V | Vs], Goals, !HI) :- add_unifications(As, NonLocals, GI0, M, U, C, Vs, Goals0, !HI), InstGraph0 = !.HI ^ hhfi_inst_graph, ( if ( map.lookup(InstGraph0, A, Node), Node = node(_, parent(_)) ; set_of_var.member(NonLocals, A) ) then VarTable0 = !.HI ^ hhfi_var_table, lookup_var_entry(VarTable0, A, EntryA), EntryV = EntryA ^ vte_name := "", add_var_entry(EntryV, V, VarTable0, VarTable), map.init(Empty), map.det_insert(V, node(Empty, top_level), InstGraph0, InstGraph), !HI ^ hhfi_var_table := VarTable, !HI ^ hhfi_inst_graph := InstGraph, GINonlocals0 = goal_info_get_nonlocals(GI0), set_of_var.insert(V, GINonlocals0, GINonlocals), goal_info_set_nonlocals(GINonlocals, GI0, GI), Goals = [hlds_goal(unify(A, rhs_var(V), M, U, C), GI) | Goals0] else V = A, Goals = Goals0 ). :- pred complete_inst_graph(hhf_info::in, hhf_info::out) is det. complete_inst_graph(!HI) :- InstGraph0 = !.HI ^ hhfi_inst_graph, map.keys(InstGraph0, Vars), list.foldl(complete_inst_graph_node(Vars), Vars, !HI). :- pred complete_inst_graph_node(list(prog_var)::in, prog_var::in, hhf_info::in, hhf_info::out) is det. complete_inst_graph_node(BaseVars, Var, !HI) :- ModuleInfo = !.HI ^ hhfi_module_info, VarTable0 = !.HI ^ hhfi_var_table, lookup_var_type(VarTable0, Var, Type), ( if type_constructors(ModuleInfo, Type, Constructors), type_to_ctor(Type, TypeCtor) then TypeCtor = type_ctor(TypeCtorSymName, _), ( TypeCtorSymName = unqualified(_), unexpected($pred, "unqualified TypeCtorSymName") ; TypeCtorSymName = qualified(TypeCtorModuleName, _) ), list.foldl( maybe_add_cons_id(Var, BaseVars, TypeCtor, TypeCtorModuleName), Constructors, !HI) else true ). :- pred maybe_add_cons_id(prog_var::in, list(prog_var)::in, type_ctor::in, module_name::in, constructor::in, hhf_info::in, hhf_info::out) is det. maybe_add_cons_id(Var, BaseVars, TypeCtor, TypeCtorModuleName, Ctor, !HI) :- Ctor = ctor(_, _, Name, Args, Arity, _), SymName = qualified(TypeCtorModuleName, unqualify_name(Name)), ConsId = cons(SymName, Arity, TypeCtor), map.lookup(!.HI ^ hhfi_inst_graph, Var, node(Functors0, MaybeParent)), ( if map.contains(Functors0, ConsId) then true else list.map_foldl(add_cons_id(Var, BaseVars), Args, NewVars, !HI), map.det_insert(ConsId, NewVars, Functors0, Functors), !HI ^ hhfi_inst_graph := map.det_update(!.HI ^ hhfi_inst_graph, Var, node(Functors, MaybeParent)) ). :- pred add_cons_id(prog_var::in, list(prog_var)::in, constructor_arg::in, prog_var::out, hhf_info::in, hhf_info::out) is det. add_cons_id(Var, BaseVars, Arg, NewVar, !HI) :- ArgType = Arg ^ arg_type, !.HI = hhf_info(ModuleInfo, InstGraph0, VarTable0), ( if find_var_with_type(Var, ArgType, InstGraph0, VarTable0, BaseVars, NewVar0) then NewVar = NewVar0 else IsDummy = is_type_a_dummy(ModuleInfo, ArgType), NewVarEntry = vte("", ArgType, IsDummy), add_var_entry(NewVarEntry, NewVar, VarTable0, VarTable), map.init(Empty), map.det_insert(NewVar, node(Empty, parent(Var)), InstGraph0, InstGraph), !:HI = hhf_info(ModuleInfo, InstGraph, VarTable), complete_inst_graph_node(BaseVars, NewVar, !HI) ). :- pred find_var_with_type(prog_var::in, mer_type::in, inst_graph::in, var_table::in, list(prog_var)::in, prog_var::out) is semidet. find_var_with_type(Var0, Type, InstGraph, VarTable, BaseVars, Var) :- lookup_var_type(VarTable, Var0, Type0), ( if same_type(Type0, Type) then Var = Var0 else map.lookup(InstGraph, Var0, node(_, parent(Var1))), \+ Var1 `list.member` BaseVars, find_var_with_type(Var1, Type, InstGraph, VarTable, BaseVars, Var) ). :- pred same_type(mer_type::in, mer_type::in) is semidet. same_type(A0, B0) :- A = strip_kind_annotation(A0), B = strip_kind_annotation(B0), same_type_2(A, B). :- pred same_type_2(non_kinded_type::in, non_kinded_type::in) is semidet. same_type_2(type_variable(_, _), type_variable(_, _)). same_type_2(defined_type(Name, ArgsA, _), defined_type(Name, ArgsB, _)) :- same_type_list(ArgsA, ArgsB). same_type_2(builtin_type(BuiltinType), builtin_type(BuiltinType)). same_type_2(higher_order_type(PorF, ArgsA, HOInstInfo, Purity, EvalMethod), higher_order_type(PorF, ArgsB, HOInstInfo, Purity, EvalMethod)) :- same_type_list(ArgsA, ArgsB). same_type_2(tuple_type(ArgsA, _), tuple_type(ArgsB, _)) :- same_type_list(ArgsA, ArgsB). same_type_2(apply_n_type(_, ArgsA, _), apply_n_type(_, ArgsB, _)) :- same_type_list(ArgsA, ArgsB). :- pred same_type_list(list(mer_type)::in, list(mer_type)::in) is semidet. same_type_list([], []). same_type_list([A | As], [B | Bs]) :- same_type(A, B), same_type_list(As, Bs). %------------------------------------------------------------------------% % % Add the information from the procedure's mode declaration % % to the inst_graph. % :- pred process_proc(module_info::in, list(prog_var)::in, proc_id::in, % proc_info::in, inst_graph::out, prog_varset::out) is det. % % process_proc(ModuleInfo, HeadVars, _ProcId, ProcInfo, Info0, Info) :- % proc_info_get_argmodes(ProcInfo, ArgModes), % % mode_list_get_initial_insts(ArgModes, ModuleInfo, InstsI), % assoc_list.from_corresponding_lists(HeadVars, InstsI, VarInstsI), % list.foldl(process_arg(ModuleInfo), VarInstsI, Info0, Info), % % mode_list_get_final_insts(ArgModes, ModuleInfo, InstsF), % assoc_list.from_corresponding_lists(HeadVars, InstsF, VarInstsF), % list.foldl(process_arg(ModuleInfo), VarInstsF, Info0, Info). % % :- pred process_arg(module_info::in, pair(prog_var, inst)::in, % inst_graph_info::in, inst_graph_info::out) is det. % % process_arg(ModuleInfo, Var - Inst, Info0, Info) :- % map.init(Seen0), % process_arg_inst(ModuleInfo, Var, Seen0, Inst, Info0, Info). % % :- pred process_arg_inst(module_info::in, prog_var::in, % map(inst_name, prog_var)::in, inst::in, inst_graph_info::in, % inst_graph_info::out) is det. % % process_arg_inst(ModuleInfo, Var, Seen0, Inst0, Info0, Info) :- % ( if Inst0 = defined_inst(InstName) then % map.det_insert(Seen0, InstName, Var, Seen), % inst_lookup(ModuleInfo, InstName, Inst), % process_arg_inst(Inst, ModuleInfo, Var, Seen, Info0, Info) % else if Inst0 = bound(_, BoundInsts) then % list.foldl(process_bound_inst(ModuleInfo, Var, Seen0), % BoundInts, Info0, Info) % else % Info = Info0 % ). % % :- pred process_bound_inst(module_info::in, prog_var::in, % map(inst_name, prog_var)::in, bound_inst::in, % inst_graph_info::in, inst_graph_info::out) is det. %------------------------------------------------------------------------% :- end_module hlds.hhf. %------------------------------------------------------------------------%