[m-rev.] for review: untupling transformation
Peter Wang
wangp at students.cs.mu.OZ.AU
Mon Jan 31 15:33:57 AEDT 2005
For review by anyone.
Estimated hours taken: 80
Branches: main
This change adds a --untuple option to the compiler which invokes a new
transformation pass. The transformation takes an HLDS structure as its
input and transforms the locally-defined procedures as follows: if the
formal parameter of a procedure has a type consisting of a single function
symbol then that parameter is expanded into multiple parameters (one for
each field of the functor). Tuple types are also expanded. The argument
lists are expanded as deeply (flatly) as possible. Calls within the
same module are updated to use the new versions of the procedures.
compiler/untupling.m:
New file.
compiler/transform_hlds.m:
Add the new untupling submodule to the transform_hlds module.
compiler/handle_options.m:
compiler/options.m:
Add a new boolean option --untuple to the compiler.
compiler/mercury_compile.m:
Add code to run the untupling pass if the --untuple option is given.
compiler/hlds_pred.m:
compiler/layout_out.m:
Add a untuple constructor to the pred_transformation type.
Add a untuple_proc_info field to proc_sub_info and associated
predicates proc_info_get_maybe_untuple_info and
proc_info_set_maybe_untuple_info.
compiler/hlds_out.m:
Add code to print out the information stored in the
untuple_proc_info field of proc_sub_info.
compiler/hlds_goal.m:
Add new utility predicates construct_functor and deconstruct_functor
for creating construct and deconstruct unification goals.
Make construct_tuple and deconstruct_tuple be special cases of
construct_functor and deconstruct_functor, respectively.
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.216
diff -u -r1.216 handle_options.m
--- compiler/handle_options.m 27 Jan 2005 03:38:07 -0000 1.216
+++ compiler/handle_options.m 31 Jan 2005 03:07:23 -0000
@@ -830,6 +830,7 @@
globals__io_set_option(optimize_saved_vars_cell,
bool(no)),
globals__io_set_option(loop_invariants, bool(no)),
+ globals__io_set_option(untuple, bool(no)),
% For the IL backend we turn off optimize_peep
% so that we don't optimize away references to the
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.123
diff -u -r1.123 hlds_goal.m
--- compiler/hlds_goal.m 28 Jan 2005 07:11:45 -0000 1.123
+++ compiler/hlds_goal.m 30 Jan 2005 22:55:57 -0000
@@ -1063,6 +1063,17 @@
%
% Produce a goal to construct or deconstruct a
+ % unification with a functor. It fills in the
+ % non-locals, instmap_delta and determinism fields
+ % of the goal_info.
+ %
+:- pred construct_functor(prog_var::in, cons_id::in, list(prog_var)::in,
+ hlds_goal::out) is det.
+:- pred deconstruct_functor(prog_var::in, cons_id::in, list(prog_var)::in,
+ hlds_goal::out) is det.
+
+ %
+ % Produce a goal to construct or deconstruct a
% tuple containing the given list of arguments,
% filling in the non-locals, instmap_delta and
% determinism fields of the goal_info.
@@ -2036,40 +2047,48 @@
instmap_delta_insert(InstMapDelta0, Var, Inst, InstMapDelta),
goal_info_init(NonLocals, InstMapDelta, det, pure, GoalInfo).
-construct_tuple(Tuple, Args, Goal) :-
+construct_functor(Var, ConsId, Args, Goal) :-
list__length(Args, Arity),
- ConsId = cons(unqualified("{}"), Arity),
Rhs = functor(ConsId, no, Args),
UnifyMode = (free_inst -> ground_inst) - (ground_inst -> ground_inst),
UniMode = ((free_inst - ground_inst) -> (ground_inst - ground_inst)),
list__duplicate(Arity, UniMode, UniModes),
- Unification = construct(Tuple, ConsId, Args, UniModes,
+ Unification = construct(Var, ConsId, Args, UniModes,
construct_dynamically, cell_is_unique, no),
UnifyContext = unify_context(explicit, []),
- Unify = unify(Tuple, Rhs, UnifyMode, Unification, UnifyContext),
- set__list_to_set([Tuple | Args], NonLocals),
- instmap_delta_from_assoc_list([Tuple - ground_inst], InstMapDelta),
+ Unify = unify(Var, Rhs, UnifyMode, Unification, UnifyContext),
+ set__list_to_set([Var | Args], NonLocals),
+ instmap_delta_from_assoc_list([Var - ground_inst], InstMapDelta),
goal_info_init(NonLocals, InstMapDelta, det, pure, GoalInfo),
Goal = Unify - GoalInfo.
-deconstruct_tuple(Tuple, Args, Goal) :-
+deconstruct_functor(Var, ConsId, Args, Goal) :-
list__length(Args, Arity),
- ConsId = cons(unqualified("{}"), Arity),
Rhs = functor(ConsId, no, Args),
UnifyMode = (ground_inst -> free_inst) - (ground_inst -> ground_inst),
UniMode = ((ground_inst - free_inst) -> (ground_inst - ground_inst)),
list__duplicate(Arity, UniMode, UniModes),
UnifyContext = unify_context(explicit, []),
CanGC = no,
- Unification = deconstruct(Tuple, ConsId, Args,
+ Unification = deconstruct(Var, ConsId, Args,
UniModes, cannot_fail, CanGC),
- Unify = unify(Tuple, Rhs, UnifyMode, Unification, UnifyContext),
- set__list_to_set([Tuple | Args], NonLocals),
+ Unify = unify(Var, Rhs, UnifyMode, Unification, UnifyContext),
+ set__list_to_set([Var | Args], NonLocals),
list__duplicate(Arity, ground_inst, DeltaValues),
assoc_list__from_corresponding_lists(Args, DeltaValues, DeltaAL),
instmap_delta_from_assoc_list(DeltaAL, InstMapDelta),
goal_info_init(NonLocals, InstMapDelta, det, pure, GoalInfo),
Goal = Unify - GoalInfo.
+
+construct_tuple(Tuple, Args, Goal) :-
+ list__length(Args, Arity),
+ ConsId = cons(unqualified("{}"), Arity),
+ construct_functor(Tuple, ConsId, Args, Goal).
+
+deconstruct_tuple(Tuple, Args, Goal) :-
+ list__length(Args, Arity),
+ ConsId = cons(unqualified("{}"), Arity),
+ deconstruct_functor(Tuple, ConsId, Args, Goal).
%-----------------------------------------------------------------------------%
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.345
diff -u -r1.345 hlds_out.m
--- compiler/hlds_out.m 27 Jan 2005 03:38:07 -0000 1.345
+++ compiler/hlds_out.m 30 Jan 2005 22:55:57 -0000
@@ -3099,6 +3099,28 @@
hlds_out__write_var_to_abs_locns(VarLocs, VarSet, AppendVarNums, Indent,
!IO).
+:- pred hlds_out__write_untuple_info(untuple_proc_info::in, prog_varset::in,
+ bool::in, int::in, io::di, io::uo) is det.
+
+hlds_out__write_untuple_info(untuple_proc_info(UntupleMap), VarSet,
+ AppendVarNums, Indent, !IO) :-
+ hlds_out__write_indent(Indent, !IO),
+ io__write_string("% untuple:\n", !IO),
+ map__foldl(hlds_out__write_untuple_info_2(VarSet, AppendVarNums,
+ Indent), UntupleMap, !IO).
+
+:- pred hlds_out__write_untuple_info_2(prog_varset::in, bool::in, int::in,
+ prog_var::in, prog_vars::in, io::di, io::uo) is det.
+
+hlds_out__write_untuple_info_2(VarSet, AppendVarNums, Indent,
+ OldVar, NewVars, !IO) :-
+ hlds_out__write_indent(Indent, !IO),
+ io__write_string("%\t", !IO),
+ mercury_output_var(OldVar, VarSet, AppendVarNums, !IO),
+ io__write_string("\t-> ", !IO),
+ mercury_output_vars(NewVars, VarSet, AppendVarNums, !IO),
+ io__nl(!IO).
+
%-----------------------------------------------------------------------------%
:- pred hlds_out__write_types(int::in, type_table::in, io::di, io::uo) is det.
@@ -3583,6 +3605,7 @@
proc_info_is_address_taken(Proc, IsAddressTaken),
proc_info_get_call_table_tip(Proc, MaybeCallTableTip),
proc_info_get_maybe_deep_profile_info(Proc, MaybeDeepProfileInfo),
+ proc_info_get_maybe_untuple_info(Proc, MaybeUntupleInfo),
Indent1 = Indent + 1,
hlds_out__write_indent(Indent1, !IO),
@@ -3697,6 +3720,14 @@
)
;
MaybeDeepProfileInfo = no
+ ),
+
+ (
+ MaybeUntupleInfo = yes(UntupleInfo),
+ hlds_out__write_untuple_info(UntupleInfo, VarSet,
+ AppendVarNums, Indent, !IO)
+ ;
+ MaybeUntupleInfo = no
),
hlds_out__write_indent(Indent, !IO),
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.155
diff -u -r1.155 hlds_pred.m
--- compiler/hlds_pred.m 21 Jan 2005 06:20:39 -0000 1.155
+++ compiler/hlds_pred.m 28 Jan 2005 01:22:38 -0000
@@ -655,6 +655,10 @@
int % The procedure number of the original
% procedure.
)
+ ; untuple(
+ int % The procedure number of the original
+ % procedure.
+ )
; table_generator
; dnf(
int % This predicate was originally part of a
@@ -1839,6 +1843,11 @@
gen_arg_infos :: table_arg_infos
).
+:- type untuple_proc_info
+ ---> untuple_proc_info(
+ map(prog_var, prog_vars)
+ ).
+
:- pred proc_info_init(prog_context::in, arity::in, list(type)::in,
maybe(list(mode))::in, list(mode)::in, maybe(list(is_live))::in,
maybe(determinism)::in, is_address_taken::in, proc_info::out) is det.
@@ -1906,6 +1915,8 @@
maybe(proc_table_info)::out) is det.
:- pred proc_info_get_maybe_deep_profile_info(proc_info::in,
maybe(deep_profile_proc_info)::out) is det.
+:- pred proc_info_get_maybe_untuple_info(proc_info::in,
+ maybe(untuple_proc_info)::out) is det.
% Predicates to set fields of proc_infos.
@@ -1956,6 +1967,9 @@
:- pred proc_info_set_maybe_deep_profile_info(
maybe(deep_profile_proc_info)::in,
proc_info::in, proc_info::out) is det.
+:- pred proc_info_set_maybe_untuple_info(
+ maybe(untuple_proc_info)::in,
+ proc_info::in, proc_info::out) is det.
:- pred proc_info_head_modes_constraint(proc_info::in, mode_constraint::out)
is det.
@@ -2235,7 +2249,14 @@
% sufficient for debugging most
% problems in the tabling system.
maybe_deep_profile_proc_info
- :: maybe(deep_profile_proc_info)
+ :: maybe(deep_profile_proc_info),
+ maybe_untuple_info :: maybe(untuple_proc_info)
+ % If set, it means this procedure was
+ % created from another procedure by the
+ % untupling transformation. This slot
+ % records which of the procedure's
+ % arguments were derived from which
+ % arguments in the original procedure.
).
% Some parts of the procedure aren't known yet. We initialize
@@ -2266,7 +2287,7 @@
MaybeDet, InferredDet, ClauseBody, CanProcess, ModeErrors,
TVarsMap, TCVarsMap, eval_normal,
proc_sub_info(no, no, IsAddressTaken, StackSlots,
- ArgInfo, InitialLiveness, no, no, no, no)).
+ ArgInfo, InitialLiveness, no, no, no, no, no)).
proc_info_set(Context, BodyVarSet, BodyTypes, HeadVars, InstVarSet, HeadModes,
HeadLives, DeclaredDetism, InferredDetism, Goal, CanProcess,
@@ -2278,7 +2299,7 @@
DeclaredDetism, InferredDetism, Goal, CanProcess, ModeErrors,
TVarMap, TCVarsMap, eval_normal,
proc_sub_info(ArgSizes, Termination, IsAddressTaken,
- StackSlots, ArgInfo, Liveness, no, no, no, no)).
+ StackSlots, ArgInfo, Liveness, no, no, no, no, no)).
proc_info_create(Context, VarSet, VarTypes, HeadVars, InstVarSet,
HeadModes, Detism, Goal, TVarMap, TCVarsMap,
@@ -2299,7 +2320,7 @@
MaybeDeclaredDetism, Detism, Goal, yes, ModeErrors,
TVarMap, TCVarsMap, eval_normal,
proc_sub_info(no, no, IsAddressTaken,
- StackSlots, no, Liveness, no, no, no, no)).
+ StackSlots, no, Liveness, no, no, no, no, no)).
proc_info_set_body(VarSet, VarTypes, HeadVars, Goal, TI_VarMap, TCI_VarMap,
ProcInfo0, ProcInfo) :-
@@ -2337,6 +2358,8 @@
proc_info_get_maybe_proc_table_info(PI, PI ^ proc_sub_info ^ maybe_table_info).
proc_info_get_maybe_deep_profile_info(PI,
PI ^ proc_sub_info ^ maybe_deep_profile_proc_info).
+proc_info_get_maybe_untuple_info(PI,
+ PI ^ proc_sub_info ^ maybe_untuple_info).
proc_info_set_varset(VS, PI, PI ^ prog_varset := VS).
proc_info_set_vartypes(VT, PI, PI ^ var_types := VT).
@@ -2371,6 +2394,8 @@
PI ^ proc_sub_info ^ maybe_table_info := MTI).
proc_info_set_maybe_deep_profile_info(DPI, PI,
PI ^ proc_sub_info ^ maybe_deep_profile_proc_info := DPI).
+proc_info_set_maybe_untuple_info(MUI, PI,
+ PI ^ proc_sub_info ^ maybe_untuple_info := MUI).
proc_info_head_modes_constraint(ProcInfo, HeadModesConstraint) :-
MaybeHeadModesConstraint = ProcInfo ^ maybe_head_modes_constraint,
Index: compiler/layout_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/layout_out.m,v
retrieving revision 1.41
diff -u -r1.41 layout_out.m
--- compiler/layout_out.m 21 Jan 2005 06:20:40 -0000 1.41
+++ compiler/layout_out.m 28 Jan 2005 00:51:42 -0000
@@ -1145,6 +1145,7 @@
pred_transform_name(accumulator(Posns)) = "acc_" ++
string__join_list("_", list__map(int_to_string, Posns)).
pred_transform_name(loop_invariant(Proc)) = "inv_" ++ int_to_string(Proc).
+pred_transform_name(untuple(Proc)) = "untup_" ++ int_to_string(Proc).
pred_transform_name(table_generator) = "table_gen".
pred_transform_name(dnf(N)) = "dnf_" ++ int_to_string(N).
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.323
diff -u -r1.323 mercury_compile.m
--- compiler/mercury_compile.m 27 Jan 2005 03:38:09 -0000 1.323
+++ compiler/mercury_compile.m 31 Jan 2005 03:05:48 -0000
@@ -69,6 +69,7 @@
:- import_module transform_hlds__exception_analysis.
:- import_module transform_hlds__higher_order.
:- import_module transform_hlds__accumulator.
+:- import_module transform_hlds__untupling.
:- import_module transform_hlds__inlining.
:- import_module transform_hlds__loop_inv.
:- import_module transform_hlds__deforest.
@@ -2328,6 +2329,9 @@
!IO),
% stage number 31 is used by mercury_compile__maybe_bytecodes
+ mercury_compile__maybe_untuple_arguments(Verbose, Stats, !HLDS, !IO),
+ mercury_compile__maybe_dump_hlds(!.HLDS, 133, "untupling", !IO),
+
mercury_compile__maybe_higher_order(Verbose, Stats, !HLDS, !IO),
mercury_compile__maybe_dump_hlds(!.HLDS, 135, "higher_order", !IO),
@@ -3250,6 +3254,21 @@
maybe_flush_output(Verbose, !IO),
output_bytecode_file(BytecodeFile, Bytecode, !IO),
maybe_write_string(Verbose, " done.\n", !IO),
+ maybe_report_stats(Stats, !IO)
+ ;
+ true
+ ).
+
+:- pred mercury_compile__maybe_untuple_arguments(bool::in, bool::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+mercury_compile__maybe_untuple_arguments(Verbose, Stats, !HLDS, !IO) :-
+ globals.io_lookup_bool_option(untuple, Untuple, !IO),
+ ( Untuple = yes ->
+ maybe_write_string(Verbose, "% Untupling...\n", !IO),
+ maybe_flush_output(Verbose, !IO),
+ untuple_arguments(!HLDS, !IO),
+ maybe_write_string(Verbose, "% done.\n", !IO),
maybe_report_stats(Stats, !IO)
;
true
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.441
diff -u -r1.441 options.m
--- compiler/options.m 27 Jan 2005 03:38:09 -0000 1.441
+++ compiler/options.m 31 Jan 2005 02:58:38 -0000
@@ -491,6 +491,7 @@
; termination_error_limit
; termination_path_limit
; analyse_exceptions
+ ; untuple
% - HLDS->LLDS
; smart_indexing
; dense_switch_req_density
@@ -1099,6 +1100,7 @@
deforestation_cost_factor - int(1000),
deforestation_vars_threshold - int(200),
deforestation_size_threshold - int(15),
+ untuple - bool(no),
% HLDS -> LLDS
smart_indexing - bool(no),
@@ -1767,6 +1769,7 @@
long_option("termination-path-limit", termination_path_limit).
long_option("term-path-limit", termination_path_limit).
long_option("analyse-exceptions", analyse_exceptions).
+long_option("untuple", untuple).
% HLDS->LLDS optimizations
long_option("smart-indexing", smart_indexing).
Index: compiler/transform_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/transform_hlds.m,v
retrieving revision 1.13
diff -u -r1.13 transform_hlds.m
--- compiler/transform_hlds.m 22 Jan 2005 06:10:53 -0000 1.13
+++ compiler/transform_hlds.m 25 Jan 2005 04:11:23 -0000
@@ -61,6 +61,7 @@
:- include_module const_prop.
:- include_module loop_inv.
:- include_module size_prof.
+:- include_module untupling.
:- include_module mmc_analysis.
Index: compiler/untupling.m
===================================================================
RCS file: compiler/untupling.m
diff -N compiler/untupling.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/untupling.m 31 Jan 2005 04:30:18 -0000
@@ -0,0 +1,689 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2005 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: untupling.m.
+%
+% Author: wangp.
+%
+% This module takes an HLDS structure as its input and transforms the
+% locally-defined procedures as follows: if the formal parameter of a
+% procedure has a type consisting of a single function symbol then that
+% parameter is expanded into multiple parameters (one for each field of the
+% functor). Tuple types are also expanded. The argument lists are expanded
+% as deeply (flatly) as possible.
+%
+% e.g. for the following module,
+%
+% :- type t ---> t(u).
+% :- type u ---> u(v, w).
+% :- type v ---> v1 ; v2.
+% :- type w ---> w(int, string).
+%
+% :- pred f(t::in) is det.
+% f(T) :- blah.
+%
+% a transformed version of f/1 would be added:
+%
+% :- pred f_untupled(v::in, int::in, string::in) is det.
+% f_untupled(V, W1, W2) :- blah.
+%
+% After all the procedures have been processed in that way, a second pass is
+% made to update all the calls in the module which refer to the old procedures
+% to call the transformed procedures. This is done by adding deconstruction
+% and construction unifications as needed, which can later be simplified by a
+% simplification pass.
+%
+%-----------------------------------------------------------------------------%
+
+:- module transform_hlds__untupling.
+
+:- interface.
+
+:- import_module hlds__hlds_module.
+
+:- import_module io.
+
+:- pred untuple_arguments(module_info::in, module_info::out, io::di, io::uo)
+ is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module check_hlds__det_analysis.
+:- import_module check_hlds__mode_util.
+:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_goal.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__quantification.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__prog_data.
+:- import_module parse_tree__prog_mode.
+:- import_module parse_tree__prog_type.
+:- import_module parse_tree__prog_util.
+
+:- import_module bool, list, map, require, std_util, string, svmap.
+:- import_module svvarset, term, varset.
+
+ % The transform_map structure records which procedures were
+ % transformed into what procedures during the first pass.
+ %
+:- type transform_map == map(pred_proc_id, transformed_proc).
+
+:- type transformed_proc
+ ---> transformed_proc(
+ pred_proc_id,
+ % The predicate and procedure that the old
+ % procedure was transformed into.
+ hlds_goal
+ % A call goal template that is used to update
+ % calls refering to the old procedure to the
+ % new procedure.
+ ).
+
+untuple_arguments(!ModuleInfo, !IO) :-
+ expand_args_in_module(!ModuleInfo, TransformMap),
+ fix_calls_to_expanded_procs(TransformMap, !ModuleInfo).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ % This is the top level of the first pass. It expands procedure
+ % arguments where possible, adding new versions of the transformed
+ % procedures into the module and recording the mapping between the old
+ % and new procedures in the transform map.
+ %
+:- pred expand_args_in_module(module_info::in, module_info::out,
+ transform_map::out) is det.
+
+expand_args_in_module(!ModuleInfo, TransformMap) :-
+ module_info_predids(!.ModuleInfo, PredIds),
+ list__foldl2(expand_args_in_pred, PredIds,
+ !ModuleInfo, map__init, TransformMap).
+
+:- pred expand_args_in_pred(pred_id::in, module_info::in, module_info::out,
+ transform_map::in, transform_map::out) is det.
+
+expand_args_in_pred(PredId, !ModuleInfo, !TransformMap) :-
+ module_info_types(!.ModuleInfo, TypeTable),
+ module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
+ (
+ % Only perform the transformation on predicates which
+ % satisfy the following criteria.
+ pred_info_import_status(PredInfo, local),
+ pred_info_get_goal_type(PredInfo, clauses),
+ pred_info_get_exist_quant_tvars(PredInfo, []),
+ pred_info_get_head_type_params(PredInfo, []),
+ pred_info_get_class_context(PredInfo, constraints([], [])),
+ pred_info_get_origin(PredInfo, user(_)),
+ pred_info_arg_types(PredInfo, TypeVarSet, ExistQVars,
+ ArgTypes),
+ varset__is_empty(TypeVarSet),
+ ExistQVars = [],
+ at_least_one_expandable_type(ArgTypes, TypeTable)
+ ->
+ ProcIds = pred_info_non_imported_procids(PredInfo),
+ list__foldl2(expand_args_in_proc(PredId), ProcIds,
+ !ModuleInfo, !TransformMap)
+ ;
+ true
+ ).
+
+:- pred at_least_one_expandable_type(list(type)::in, type_table::in)
+ is semidet.
+
+at_least_one_expandable_type([Type | Types], TypeTable) :-
+ ( expand_type(Type, TypeTable, yes(_))
+ ; at_least_one_expandable_type(Types, TypeTable)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % This structure records the mapping between a head variable of the
+ % original procedure, and the list of variables that it was finally
+ % expanded into. If the head variable expands into some intermediate
+ % variables which are then expanded further, the intermediate
+ % variables are not listed in the mapping.
+ %
+:- type untuple_map == map(prog_var, prog_vars).
+
+:- pred expand_args_in_proc(pred_id::in, proc_id::in, module_info::in,
+ module_info::out, transform_map::in, transform_map::out) is det.
+
+expand_args_in_proc(PredId, ProcId, !ModuleInfo, !TransformMap) :-
+ some [!ProcInfo] (
+ module_info_types(!.ModuleInfo, TypeTable),
+ module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId,
+ PredInfo0, !:ProcInfo),
+
+ proc_info_headvars(!.ProcInfo, HeadVars0),
+ proc_info_argmodes(!.ProcInfo, ArgModes0),
+ proc_info_goal(!.ProcInfo, Goal0),
+ proc_info_vartypes(!.ProcInfo, VarTypes0),
+ proc_info_varset(!.ProcInfo, VarSet0),
+
+ expand_args_in_proc_2(HeadVars0, ArgModes0, HeadVars, ArgModes,
+ Goal0, Goal, VarSet0, VarSet, VarTypes0, VarTypes,
+ TypeTable, UntupleMap),
+
+ proc_info_set_headvars(HeadVars, !ProcInfo),
+ proc_info_set_argmodes(ArgModes, !ProcInfo),
+ proc_info_set_goal(Goal, !ProcInfo),
+ proc_info_set_varset(VarSet, !ProcInfo),
+ proc_info_set_vartypes(VarTypes, !ProcInfo),
+ requantify_proc(!ProcInfo),
+ recompute_instmap_delta_proc(yes, !ProcInfo, !ModuleInfo),
+
+ create_aux_pred(PredId, ProcId, PredInfo0, !.ProcInfo,
+ AuxPredId, AuxProcId, CallAux,
+ AuxPredInfo, AuxProcInfo0, !ModuleInfo),
+ proc_info_set_maybe_untuple_info(
+ yes(untuple_proc_info(UntupleMap)),
+ AuxProcInfo0, AuxProcInfo),
+ module_info_set_pred_proc_info(AuxPredId, AuxProcId,
+ AuxPredInfo, AuxProcInfo, !ModuleInfo),
+ svmap__det_insert(proc(PredId, ProcId),
+ transformed_proc(proc(AuxPredId, AuxProcId), CallAux),
+ !TransformMap)
+ ).
+
+:- pred expand_args_in_proc_2(prog_vars::in, list(mode)::in,
+ prog_vars::out, list(mode)::out, hlds_goal::in, hlds_goal::out,
+ prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
+ type_table::in, untuple_map::out) is det.
+
+expand_args_in_proc_2(HeadVars0, ArgModes0, HeadVars, ArgModes,
+ !Goal, !VarSet, !VarTypes, TypeTable, UntupleMap) :-
+ expand_args_in_proc_3(HeadVars0, ArgModes0, ListOfHeadVars,
+ ListOfArgModes, !Goal, !VarSet, !VarTypes, TypeTable),
+ list__condense(ListOfHeadVars, HeadVars),
+ list__condense(ListOfArgModes, ArgModes),
+ build_untuple_map(HeadVars0, ListOfHeadVars, map__init, UntupleMap).
+
+:- pred expand_args_in_proc_3(list(prog_var)::in, list(mode)::in,
+ list(list(prog_var))::out, list(list(mode))::out,
+ hlds_goal::in, hlds_goal::out, prog_varset::in, prog_varset::out,
+ vartypes::in, vartypes::out, type_table::in) is det.
+
+expand_args_in_proc_3([], [], [], [], !_, !_, !_, _).
+expand_args_in_proc_3([HeadVar0 | HeadVars0], [ArgMode0 | ArgModes0],
+ [HeadVar | HeadVars], [ArgMode | ArgModes],
+ !Goal, !VarSet, !VarTypes, TypeTable) :-
+ expand_one_arg_in_proc(HeadVar0, ArgMode0, HeadVar, ArgMode,
+ !Goal, !VarSet, !VarTypes, TypeTable),
+ expand_args_in_proc_3(HeadVars0, ArgModes0, HeadVars, ArgModes,
+ !Goal, !VarSet, !VarTypes, TypeTable).
+expand_args_in_proc_3([], [_|_], _, _, !_, !_, !_, _) :-
+ unexpected(this_file, "expand_args_in_proc_3: length mismatch").
+expand_args_in_proc_3([_|_], [], _, _, !_, !_, !_, _) :-
+ unexpected(this_file, "expand_args_in_proc_3: length mismatch").
+
+:- pred expand_one_arg_in_proc(prog_var::in, (mode)::in, prog_vars::out,
+ list(mode)::out, hlds_goal::in, hlds_goal::out, prog_varset::in,
+ prog_varset::out, vartypes::in, vartypes::out, type_table::in)
+ is det.
+
+expand_one_arg_in_proc(HeadVar0, ArgMode0, HeadVars, ArgModes,
+ !Goal, !VarSet, !VarTypes, TypeTable) :-
+ expand_one_arg_in_proc_2(HeadVar0, ArgMode0, MaybeHeadVarsAndArgModes,
+ !Goal, !VarSet, !VarTypes, TypeTable),
+ (
+ MaybeHeadVarsAndArgModes = yes(HeadVars1 - ArgModes1),
+ expand_args_in_proc_3(HeadVars1, ArgModes1, ListOfHeadVars,
+ ListOfArgModes, !Goal, !VarSet, !VarTypes, TypeTable),
+ HeadVars = list__condense(ListOfHeadVars),
+ ArgModes = list__condense(ListOfArgModes)
+ ;
+ MaybeHeadVarsAndArgModes = no,
+ HeadVars = [HeadVar0],
+ ArgModes = [ArgMode0]
+ ).
+
+:- pred expand_one_arg_in_proc_2(prog_var::in, (mode)::in,
+ maybe(pair(list(prog_var), list(mode)))::out,
+ hlds_goal::in, hlds_goal::out, prog_varset::in, prog_varset::out,
+ vartypes::in, vartypes::out, type_table::in) is det.
+
+expand_one_arg_in_proc_2(HeadVar0, ArgMode0, MaybeHeadVarsAndArgModes,
+ !Goal, !VarSet, !VarTypes, TypeTable) :-
+ map__lookup(!.VarTypes, HeadVar0, Type),
+ (
+ expand_argument(ArgMode0, Type, TypeTable,
+ yes(ConsId - NewTypes))
+ ->
+ NumVars = list__length(NewTypes),
+ svvarset__new_vars(NumVars, NewHeadVars, !VarSet),
+ svmap__det_insert_from_corresponding_lists(
+ NewHeadVars, NewTypes, !VarTypes),
+ list__duplicate(list__length(NewHeadVars), ArgMode0,
+ NewArgModes),
+ MaybeHeadVarsAndArgModes = yes(NewHeadVars - NewArgModes),
+ ( ArgMode0 = in_mode ->
+ construct_functor(HeadVar0, ConsId, NewHeadVars,
+ UnifGoal),
+ conjoin_goals_keep_detism(UnifGoal, !Goal)
+ ; ArgMode0 = out_mode ->
+ deconstruct_functor(HeadVar0, ConsId, NewHeadVars,
+ UnifGoal),
+ conjoin_goals_keep_detism(!.Goal, UnifGoal, !:Goal)
+ ;
+ unexpected(this_file,
+ "expand_one_arg_in_proc_2: " ++
+ "unsupported mode encountered")
+ )
+ ;
+ MaybeHeadVarsAndArgModes = no
+ ).
+
+:- pred conjoin_goals_keep_detism(hlds_goal::in, hlds_goal::in,
+ hlds_goal::out) is det.
+
+conjoin_goals_keep_detism(GoalA, GoalB, conj(GoalList) - GoalInfo) :-
+ goal_to_conj_list(GoalA, GoalListA),
+ goal_to_conj_list(GoalB, GoalListB),
+ list__append(GoalListA, GoalListB, GoalList),
+ goal_list_determinism(GoalList, Determinism),
+ goal_info_init(GoalInfo0),
+ goal_info_set_determinism(GoalInfo0, Determinism, GoalInfo).
+
+:- pred build_untuple_map(list(prog_var)::in, list(list(prog_var))::in,
+ untuple_map::in, untuple_map::out) is det.
+
+build_untuple_map([], [], !UntupleMap).
+build_untuple_map([OldVar | OldVars], [NewVars | NewVarss], !UntupleMap) :-
+ ( NewVars = [OldVar] ->
+ build_untuple_map(OldVars, NewVarss, !UntupleMap)
+ ;
+ svmap__det_insert(OldVar, NewVars, !UntupleMap),
+ build_untuple_map(OldVars, NewVarss, !UntupleMap)
+ ).
+build_untuple_map([], [_|_], !_) :-
+ unexpected(this_file, "build_untuple_map: length mismatch").
+build_untuple_map([_|_], [], !_) :-
+ unexpected(this_file, "build_untuple_map: length mismatch").
+
+%-----------------------------------------------------------------------------%
+
+ % Similar to the create_aux_pred in loop_inv.m.
+ %
+:- pred create_aux_pred(pred_id::in, proc_id::in, pred_info::in, proc_info::in,
+ pred_id::out, proc_id::out, hlds_goal::out, pred_info::out,
+ proc_info::out, module_info::in, module_info::out) is det.
+
+create_aux_pred(PredId, ProcId, PredInfo, ProcInfo,
+ AuxPredId, AuxProcId, CallAux, AuxPredInfo, AuxProcInfo,
+ ModuleInfo0, ModuleInfo) :-
+ module_info_name(ModuleInfo0, ModuleName),
+
+ proc_info_headvars(ProcInfo, AuxHeadVars),
+ proc_info_goal(ProcInfo, Goal @ (_GoalExpr - GoalInfo)),
+ proc_info_get_initial_instmap(ProcInfo, ModuleInfo0,
+ InitialAuxInstMap),
+ pred_info_typevarset(PredInfo, TVarSet),
+ proc_info_vartypes(ProcInfo, VarTypes),
+ pred_info_get_class_context(PredInfo, ClassContext),
+ proc_info_typeinfo_varmap(ProcInfo, TVarMap),
+ proc_info_typeclass_info_varmap(ProcInfo, TCVarMap),
+ proc_info_varset(ProcInfo, VarSet),
+ proc_info_inst_varset(ProcInfo, InstVarSet),
+ pred_info_get_markers(PredInfo, Markers),
+ pred_info_get_aditi_owner(PredInfo, Owner),
+ pred_info_get_origin(PredInfo, OrigOrigin),
+
+ PredName = pred_info_name(PredInfo),
+ goal_info_get_context(GoalInfo, Context),
+ term__context_line(Context, Line),
+ proc_id_to_int(ProcId, ProcNo),
+ AuxNamePrefix = string__format("untupling_%d", [i(ProcNo)]),
+ make_pred_name_with_context(ModuleName, AuxNamePrefix,
+ predicate, PredName, Line, 1, AuxPredSymName),
+ (
+ AuxPredSymName = unqualified(AuxPredName)
+ ;
+ AuxPredSymName = qualified(_ModuleSpecifier, AuxPredName)
+ ),
+
+ Origin = transformed(untuple(ProcNo), OrigOrigin, PredId),
+ hlds_pred__define_new_pred(
+ Origin, % in
+ Goal, % in
+ CallAux, % out
+ AuxHeadVars, % in
+ _ExtraArgs, % out
+ InitialAuxInstMap, % in
+ AuxPredName, % in
+ TVarSet, % in
+ VarTypes, % in
+ ClassContext, % in
+ TVarMap, % in
+ TCVarMap, % in
+ VarSet, % in
+ InstVarSet, % in
+ Markers, % in
+ Owner, % in
+ address_is_not_taken, % in
+ ModuleInfo0,
+ ModuleInfo,
+ proc(AuxPredId, AuxProcId)
+ % out
+ ),
+
+ module_info_pred_proc_info(ModuleInfo, AuxPredId, AuxProcId,
+ AuxPredInfo, AuxProcInfo).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ % This is the top level of the second pass. It takes the transform
+ % map built during the first pass as input. For every call to a
+ % procedure in the transform map, it rewrites the call to use the new
+ % procedure instead, inserting unifications before and after the call
+ % as necessary.
+ %
+:- pred fix_calls_to_expanded_procs(transform_map::in, module_info::in,
+ module_info::out) is det.
+
+fix_calls_to_expanded_procs(TransformMap, !ModuleInfo) :-
+ module_info_predids(!.ModuleInfo, PredIds),
+ list__foldl(fix_calls_in_pred(TransformMap), PredIds, !ModuleInfo).
+
+:- pred fix_calls_in_pred(transform_map::in, pred_id::in, module_info::in,
+ module_info::out) is det.
+
+fix_calls_in_pred(TransformMap, PredId, !ModuleInfo) :-
+ module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
+ ProcIds = pred_info_non_imported_procids(PredInfo),
+ list__foldl(fix_calls_in_proc(TransformMap, PredId), ProcIds,
+ !ModuleInfo).
+
+:- pred fix_calls_in_proc(transform_map::in, pred_id::in, proc_id::in,
+ module_info::in, module_info::out) is det.
+
+fix_calls_in_proc(TransformMap, PredId, ProcId, !ModuleInfo) :-
+ some [!ProcInfo] (
+ module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId,
+ PredInfo, !:ProcInfo),
+ proc_info_goal(!.ProcInfo, Goal0),
+ proc_info_vartypes(!.ProcInfo, VarTypes0),
+ proc_info_varset(!.ProcInfo, VarSet0),
+ fix_calls_in_goal(Goal0, Goal, VarSet0, VarSet,
+ VarTypes0, VarTypes, TransformMap, !.ModuleInfo),
+ ( Goal0 \= Goal ->
+ proc_info_set_goal(Goal, !ProcInfo),
+ proc_info_set_varset(VarSet, !ProcInfo),
+ proc_info_set_vartypes(VarTypes, !ProcInfo),
+ requantify_proc(!ProcInfo),
+ recompute_instmap_delta_proc(yes, !ProcInfo,
+ !ModuleInfo),
+ module_info_set_pred_proc_info(PredId, ProcId,
+ PredInfo, !.ProcInfo, !ModuleInfo)
+ ;
+ true
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred fix_calls_in_goal(hlds_goal::in, hlds_goal::out, prog_varset::in,
+ prog_varset::out, vartypes::in, vartypes::out, transform_map::in,
+ module_info::in) is det.
+
+fix_calls_in_goal(Goal - GoalInfo, Goal - GoalInfo, !_, !_, _, _) :-
+ Goal = foreign_proc(_, _, _, _, _, _).
+
+fix_calls_in_goal(Goal - GoalInfo, Goal - GoalInfo, !_, !_, _, _) :-
+ Goal = generic_call(_, _, _, _).
+
+fix_calls_in_goal(Goal0 - GoalInfo0, Goal, !VarSet, !VarTypes,
+ TransformMap, ModuleInfo) :-
+ Goal0 = call(CalleePredId, CalleeProcId, OrigArgs, _, _, _),
+ (
+ map__search(TransformMap,
+ proc(CalleePredId, CalleeProcId),
+ transformed_proc(_, CallAux0 - CallAuxInfo))
+ ->
+ module_info_types(ModuleInfo, TypeTable),
+ module_info_pred_proc_info(ModuleInfo, CalleePredId,
+ CalleeProcId, _CalleePredInfo, CalleeProcInfo),
+ proc_info_argmodes(CalleeProcInfo, OrigArgModes),
+ expand_call_args(OrigArgs, OrigArgModes, Args,
+ EnterUnifs, ExitUnifs, !VarSet, !VarTypes, TypeTable),
+ (
+ CallAux = CallAux0 ^ call_args := Args
+ ->
+ Call = CallAux - CallAuxInfo,
+ ConjList = EnterUnifs ++ [Call] ++ ExitUnifs,
+ conj_list_to_goal(ConjList, GoalInfo0, Goal)
+ ;
+ unexpected(this_file,
+ "fix_calls_in_goal: not a call template")
+ )
+ ;
+ Goal = Goal0 - GoalInfo0
+ ).
+
+fix_calls_in_goal(Goal - GoalInfo, Goal - GoalInfo, !_, !_, _, _) :-
+ Goal = unify(_, _, _, _, _).
+
+fix_calls_in_goal(not(Goal0) - GoalInfo, not(Goal) - GoalInfo,
+ !VarSet, !VarTypes, TransformMap, ModuleInfo) :-
+ fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo).
+
+fix_calls_in_goal(some(Vars, CanRemove, Goal0) - GoalInfo,
+ some(Vars, CanRemove, Goal) - GoalInfo,
+ !VarSet, !VarTypes, TransformMap, ModuleInfo) :-
+ fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo).
+
+fix_calls_in_goal(conj(Goals0) - GoalInfo, conj(Goals) - GoalInfo,
+ !VarSet, !VarTypes, TransformMap, ModuleInfo) :-
+ fix_calls_in_conj(Goals0, Goals, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo).
+
+fix_calls_in_goal(par_conj(Goals0) - GoalInfo, par_conj(Goals) - GoalInfo,
+ !VarSet, !VarTypes, TransformMap, ModuleInfo) :-
+ fix_calls_in_par_conj(Goals0, Goals, !VarSet, !VarTypes,
+ TransformMap, ModuleInfo).
+
+fix_calls_in_goal(disj(Goals0) - GoalInfo, disj(Goals) - GoalInfo,
+ !VarSet, !VarTypes, TransformMap, ModuleInfo) :-
+ fix_calls_in_disj(Goals0, Goals, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo).
+
+fix_calls_in_goal(switch(Var, CanFail, Cases0) - GoalInfo,
+ switch(Var, CanFail, Cases) - GoalInfo,
+ !VarSet, !VarTypes, TransformMap, ModuleInfo) :-
+ fix_calls_in_cases(Cases0, Cases, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo).
+
+fix_calls_in_goal(if_then_else(Vars, Cond0, Then0, Else0) - GoalInfo,
+ if_then_else(Vars, Cond, Then, Else) - GoalInfo,
+ !VarSet, !VarTypes, TransformMap, ModuleInfo) :-
+ fix_calls_in_goal(Cond0, Cond, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo),
+ fix_calls_in_goal(Then0, Then, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo),
+ fix_calls_in_goal(Else0, Else, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo).
+
+fix_calls_in_goal(shorthand(_) - _, _, !_, !_, _, _) :-
+ unexpected(this_file, "fix_calls_in_goal: unexpected shorthand").
+
+%-----------------------------------------------------------------------------%
+
+:- pred fix_calls_in_conj(hlds_goals::in, hlds_goals::out, prog_varset::in,
+ prog_varset::out, vartypes::in, vartypes::out, transform_map::in,
+ module_info::in) is det.
+
+fix_calls_in_conj([], [], !VarSet, !VarTypes, _, _).
+fix_calls_in_conj([Goal0 | Goals0], Goals, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo) :-
+ fix_calls_in_goal(Goal0, Goal1, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo),
+ fix_calls_in_conj(Goals0, Goals1, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo),
+ (if Goal1 = conj(ConjGoals) - _ then
+ Goals = ConjGoals ++ Goals1
+ else
+ Goals = [Goal1 | Goals1]
+ ).
+
+:- pred fix_calls_in_par_conj(hlds_goals::in, hlds_goals::out,
+ prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
+ transform_map::in, module_info::in) is det.
+
+fix_calls_in_par_conj([], [], !VarSet, !VarTypes, _, _).
+fix_calls_in_par_conj([Goal0 | Goals0], [Goal | Goals], !VarSet, !VarTypes,
+ TransformMap, ModuleInfo) :-
+ fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo),
+ fix_calls_in_par_conj(Goals0, Goals, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo).
+
+:- pred fix_calls_in_disj(hlds_goals::in, hlds_goals::out, prog_varset::in,
+ prog_varset::out, vartypes::in, vartypes::out, transform_map::in,
+ module_info::in) is det.
+
+fix_calls_in_disj([], [], !VarSet, !VarTypes, _, _).
+fix_calls_in_disj([Goal0 | Goals0], [Goal | Goals], !VarSet, !VarTypes,
+ TransformMap, ModuleInfo) :-
+ fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo),
+ fix_calls_in_disj(Goals0, Goals, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo).
+
+:- pred fix_calls_in_cases(list(case)::in, list(case)::out, prog_varset::in,
+ prog_varset::out, vartypes::in, vartypes::out, transform_map::in,
+ module_info::in) is det.
+
+fix_calls_in_cases([], [], !VarSet, !VarTypes, _, _).
+fix_calls_in_cases([Case0 | Cases0], [Case | Cases], !VarSet, !VarTypes,
+ TransformMap, ModuleInfo) :-
+ Case0 = case(Functor, Goal0),
+ fix_calls_in_goal(Goal0, Goal, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo),
+ Case = case(Functor, Goal),
+ fix_calls_in_cases(Cases0, Cases, !VarSet, !VarTypes, TransformMap,
+ ModuleInfo).
+
+%-----------------------------------------------------------------------------%
+
+:- pred expand_call_args(prog_vars::in, list(mode)::in, prog_vars::out,
+ hlds_goals::out, hlds_goals::out, prog_varset::in, prog_varset::out,
+ vartypes::in, vartypes::out, type_table::in) is det.
+
+expand_call_args([], [], [], [], [], !VarSet, !VarTypes, _).
+expand_call_args([Arg0 | Args0], [ArgMode | ArgModes], Args,
+ EnterUnifs, ExitUnifs, !VarSet, !VarTypes, TypeTable) :-
+ map__lookup(!.VarTypes, Arg0, Arg0Type),
+ (
+ expand_argument(ArgMode, Arg0Type, TypeTable,
+ yes(ConsId - Types))
+ ->
+ NumVars = list__length(Types),
+ svvarset__new_vars(NumVars, ReplacementArgs, !VarSet),
+ svmap__det_insert_from_corresponding_lists(
+ ReplacementArgs, Types, !VarTypes),
+ list__duplicate(NumVars, ArgMode, ReplacementModes),
+ ( ArgMode = in_mode ->
+ deconstruct_functor(Arg0, ConsId,
+ ReplacementArgs, Unif),
+ EnterUnifs = [Unif | EnterUnifs1],
+ expand_call_args(ReplacementArgs ++ Args0,
+ ReplacementModes ++ ArgModes,
+ Args, EnterUnifs1, ExitUnifs,
+ !VarSet, !VarTypes, TypeTable)
+ ; ArgMode = out_mode ->
+ construct_functor(Arg0, ConsId,
+ ReplacementArgs, Unif),
+ ExitUnifs = ExitUnifs1 ++ [Unif],
+ expand_call_args(ReplacementArgs ++ Args0,
+ ReplacementModes ++ ArgModes,
+ Args, EnterUnifs, ExitUnifs1,
+ !VarSet, !VarTypes, TypeTable)
+ ;
+ unexpected(this_file,
+ "expand_call_args: unsupported mode")
+ )
+ ;
+ Args = [Arg0 | Args1],
+ expand_call_args(Args0, ArgModes, Args1, EnterUnifs,
+ ExitUnifs, !VarSet, !VarTypes, TypeTable)
+ ).
+
+expand_call_args([], [_|_], _, _, _, !_, !_, _) :-
+ unexpected(this_file, "expand_call_args: length mismatch").
+expand_call_args([_|_], [], _, _, _, !_, !_, _) :-
+ unexpected(this_file, "expand_call_args: length mismatch").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ % expand_argument(ArgMode, ArgType, TypeTable, MaybeConsIdAndTypes)
+ % This predicate tries to expand the argument of the given mode and
+ % type. If this is possible then MaybeConsIdAndTypes is unified with
+ % a pair consisting of the cons_id of the constructor which was
+ % expanded and the types for that constructor.
+ %
+:- pred expand_argument((mode)::in, (type)::in, type_table::in,
+ maybe(pair(cons_id, list(type)))::out) is det.
+
+expand_argument(ArgMode, ArgType, TypeTable, MaybeConsIdAndTypes) :-
+ ( expandable_arg_mode(ArgMode) ->
+ expand_type(ArgType, TypeTable, MaybeConsIdAndTypes)
+ ;
+ MaybeConsIdAndTypes = no
+ ).
+
+ % This module so far only knows how to expand arguments which have
+ % the following modes.
+ %
+:- pred expandable_arg_mode((mode)::in) is semidet.
+
+expandable_arg_mode(in_mode).
+expandable_arg_mode(out_mode).
+
+:- pred expand_type((type)::in, type_table::in,
+ maybe(pair(cons_id, list(type)))::out) is det.
+
+expand_type(Type, TypeTable, MaybeConsIdAndTypes) :-
+ (
+ % Always expand tuple types.
+ type_to_ctor_and_args(Type, TypeCtor, TypeArgs),
+ type_ctor_is_tuple(TypeCtor)
+ ->
+ Arity = list__length(TypeArgs),
+ ConsId = cons(unqualified("{}"), Arity),
+ MaybeConsIdAndTypes = yes(ConsId - TypeArgs)
+ ;
+ % Expand a discriminated union type if it has only a
+ % single functor and the type has no parameters.
+ type_to_ctor_and_args(Type, TypeCtor, []),
+ map__search(TypeTable, TypeCtor, TypeDefn),
+ get_type_defn_tparams(TypeDefn, []),
+ get_type_defn_body(TypeDefn, TypeBody),
+ TypeBody ^ du_type_ctors = [SingleCtor],
+ SingleCtor ^ cons_exist = [],
+
+ SingleCtorName = SingleCtor ^ cons_name,
+ SingleCtorArgs = SingleCtor ^ cons_args,
+ SingleCtorArgs \= []
+ ->
+ Arity = list__length(SingleCtorArgs),
+ ConsId = cons(SingleCtorName, Arity),
+ ExpandedTypes = list__map(snd, SingleCtorArgs),
+ MaybeConsIdAndTypes = yes(ConsId - ExpandedTypes)
+ ;
+ MaybeConsIdAndTypes = no
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "untupling.m".
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list