[m-dev.] diff: MLDS back-end: fix existential types bug
Fergus Henderson
fjh at cs.mu.OZ.AU
Thu May 18 03:38:50 AEST 2000
This diff fixes bug B2 on the list that I posted the other day:
(B2) XXX bug with existentially typed procedures that return float
(or anything that doesn't map to `Word')
----------
Estimated hours taken: 4
Fix a bug in the MLDS back-end that broke
tests/typeclasses/typeclass_exist_method.m.
compiler/ml_code_gen.m:
compiler/ml_code_util.m:
Add code to handle boxing of existentially typed output arguments.
tests/hard_coded/Mmakefile:
tests/hard_coded/existential_float.m:
tests/hard_coded/existential_float.exp:
Add another test case which tests more specifically
for this bug.
Workspace: /home/pgrad/fjh/ws/hg
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.43
diff -u -d -r1.43 ml_code_gen.m
--- compiler/ml_code_gen.m 2000/05/16 21:23:27 1.43
+++ compiler/ml_code_gen.m 2000/05/17 17:12:54
@@ -667,7 +667,7 @@
:- import_module goal_util, type_util, mode_util, builtin_ops.
:- import_module passes_aux, modules.
-:- import_module bool, string, list, map, set, require, std_util.
+:- import_module bool, string, list, map, set, term, require, std_util.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -869,8 +869,10 @@
ml_gen_proc_defn(ModuleInfo, PredId, ProcId, MLDS_ProcDefnBody, ExtraDefns) :-
module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
- _PredInfo, ProcInfo),
+ PredInfo, ProcInfo),
+ pred_info_arg_types(PredInfo, ArgTypes),
proc_info_interface_code_model(ProcInfo, CodeModel),
+ proc_info_headvars(ProcInfo, HeadVars),
proc_info_goal(ProcInfo, Goal0),
%
@@ -881,7 +883,6 @@
% which occur in the top-level non-locals but which
% are not really non-local will not be declared.
%
- proc_info_headvars(ProcInfo, HeadVars),
Goal0 = GoalExpr - GoalInfo0,
goal_info_get_code_gen_nonlocals(GoalInfo0, NonLocals0),
set__list_to_set(HeadVars, HeadVarsSet),
@@ -892,7 +893,7 @@
goal_info_get_context(GoalInfo, Context),
MLDSGenInfo0 = ml_gen_info_init(ModuleInfo, PredId, ProcId),
- MLDS_Params = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
+ MLDS_Params0 = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
( CodeModel = model_non ->
% set up the initial success continuation
ml_initial_cont(InitialCont, MLDSGenInfo0, MLDSGenInfo1),
@@ -901,18 +902,20 @@
;
MLDSGenInfo2 = MLDSGenInfo0
),
+
% This would generate all the local variables at the top of the
% function:
% proc_info_varset(ProcInfo, VarSet),
% proc_info_vartypes(ProcInfo, VarTypes),
- % proc_info_headvars(ProcInfo, HeadVars),
% MLDS_LocalVars = ml_gen_all_local_var_decls(Goal, VarSet,
% VarTypes, HeadVars),
% But instead we now generate them locally for each goal.
% We just declare the `succeeded' var here.
MLDS_Context = mlds__make_context(Context),
MLDS_LocalVars = [ml_gen_succeeded_var_decl(MLDS_Context)],
- ml_gen_proc_body(CodeModel, Goal, MLDS_Decls0, MLDS_Statements,
+ ml_gen_proc_body(CodeModel, HeadVars, ArgTypes, Goal,
+ MLDS_Decls0, MLDS_Statements,
+ MLDS_Params0, MLDS_Params,
MLDSGenInfo2, MLDSGenInfo),
ml_gen_info_get_extra_defns(MLDSGenInfo, ExtraDefns),
MLDS_Decls = list__append(MLDS_LocalVars, MLDS_Decls0),
@@ -963,29 +966,177 @@
% Generate the code for a procedure body.
%
-:- pred ml_gen_proc_body(code_model, hlds_goal, mlds__defns, mlds__statements,
- ml_gen_info, ml_gen_info).
-:- mode ml_gen_proc_body(in, in, out, out, in, out) is det.
+:- pred ml_gen_proc_body(code_model, list(prog_var), list(prog_type),
+ hlds_goal, mlds__defns, mlds__statements,
+ mlds__func_params, mlds__func_params,
+ ml_gen_info, ml_gen_info).
+:- mode ml_gen_proc_body(in, in, in, in, out, out, in, out, in, out) is det.
-ml_gen_proc_body(CodeModel, Goal, MLDS_Decls, MLDS_Statements) -->
+ml_gen_proc_body(CodeModel, HeadVars, ArgTypes, Goal,
+ MLDS_Decls, MLDS_Statements, MLDS_Params0, MLDS_Params) -->
+ { Goal = _ - GoalInfo },
+ { goal_info_get_context(GoalInfo, Context) },
+
%
% First just generate the code for the procedure's goal.
%
- ml_gen_goal(CodeModel, Goal, MLDS_Decls, MLDS_Statements0),
+ { DoGenGoal = ml_gen_goal(CodeModel, Goal) },
+
%
- % Then append an appropriate `return' statement, if needed.
+ % For existentially typed procedures, we may need to
+ % box the existentially typed output arguments.
+ %
+ ml_gen_box_existential_outputs(HeadVars, ArgTypes,
+ Context, MLDS_Params0, MLDS_Params, BoxDecls, BoxStatements),
+ { DoBoxOutputs = (pred(Decls::out, Statements::out, in, out) is det -->
+ { Decls = BoxDecls, Statements = BoxStatements }
+ ) },
+
+ ml_combine_conj(CodeModel, Context,
+ DoGenGoal, DoBoxOutputs, MLDS_Decls, MLDS_Statements0),
+
%
+ % Finally append an appropriate `return' statement, if needed.
+ %
( { CodeModel = model_semi } ->
ml_gen_test_success(Succeeded),
{ ReturnStmt = return([Succeeded]) },
- { Goal = _ - GoalInfo },
- { goal_info_get_context(GoalInfo, Context) },
{ ReturnStatement = mlds__statement(ReturnStmt,
mlds__make_context(Context)) },
{ MLDS_Statements = list__append(MLDS_Statements0,
[ReturnStatement]) }
;
{ MLDS_Statements = MLDS_Statements0 }
+ ).
+
+%
+% For existentially typed procedures, the type of each parameter
+% can be an existentially quantified type variable, and the type
+% of the corresponding actual variable in the procedure may be
+% some concrete type. In such cases, we need to generate code
+% to box the argument, to convert from the concrete type to
+% the polymorphic type. (Note: this can only happen for output
+% arguments, so it's always boxing, never unboxing, that we need to do.)
+% This procedure handles the boxing of such arguments.
+%
+:- pred ml_gen_box_existential_outputs(list(prog_var), list(prog_type),
+ prog_context, mlds__func_params, mlds__func_params,
+ mlds__defns, mlds__statements, ml_gen_info, ml_gen_info).
+:- mode ml_gen_box_existential_outputs(in, in, in, in, out, out, out,
+ in, out) is det.
+
+ml_gen_box_existential_outputs(HeadVars, HeadTypes, Context,
+ Params0, Params, Decls, Statements) -->
+ ml_gen_box_existential_output_args(HeadVars, HeadTypes, Context,
+ BoxedExistentialVars, Decls, Statements),
+ { Params0 = func_params(Arguments0, RetType) },
+ { Arguments = list__map(ml_update_param(BoxedExistentialVars),
+ Arguments0) },
+ { Params = func_params(Arguments, RetType) }.
+
+:- pred ml_gen_box_existential_output_args(list(prog_var), list(prog_type),
+ prog_context, list(mlds__var_name),
+ mlds__defns, mlds__statements, ml_gen_info, ml_gen_info).
+:- mode ml_gen_box_existential_output_args(in, in, in, out, out, out, in, out)
+ is det.
+ml_gen_box_existential_output_args([], [], _, [], [], []) --> [].
+ml_gen_box_existential_output_args([Var|Vars], [ArgType|ArgTypes],
+ Context, BoxedExistentialVars, Decls, Statements) -->
+ ml_variable_type(Var, VarType),
+ (
+ %
+ % If the ArgType from the pred decl is polymorphic,
+ % but the actual VarType from the procedure body
+ % is monomorphic, then this must be an existentially
+ % quantified output argument, and we'll need to box it.
+ %
+ { VarType = term__functor(_, _, _) },
+ { ArgType = term__variable(_) }
+ ->
+ %
+ % Instead of
+ %
+ % foo(..., ArgType *VarName, ...) {
+ % ... code that assigns to *VarName ...
+ % }
+ %
+ % we generate
+ %
+ % foo(..., ArgType *head_VarName, ...) {
+ % VarType VarName;
+ % ... code that assigns to VarName ...
+ % *head_VarName = box(VarName);
+ % }
+ %
+ % Note that select_output_vars in ml_code_util.m
+ % already ensures that the generated code for the
+ % body will assign to VarName rather than to *VarName.
+ % And ml_update_param will handle the renaming of
+ % the parameter.
+ % So all we need to do here is to declare VarName
+ % as a local and generate the assignment to *head_VarName.
+ %
+
+ % create a fresh variable name for the boxed parameter
+ =(MLDSGenInfo),
+ { ml_gen_info_get_varset(MLDSGenInfo, VarSet) },
+ { VarName = ml_gen_var_name(VarSet, Var) },
+ { string__append("head_", VarName, HeadVarName) },
+
+ ( { type_util__is_dummy_argument_type(VarType) } ->
+ % if it has a dummy argument type (e.g. io__state),
+ % then we don't need to bother declaring the
+ % variable or assigning from it
+ { ConvStatements = [] },
+ { LocalVarDecls = [] }
+ ;
+ % generate a declaration for the variable (which
+ % will now become a local rather than a parameter)
+ { VarDecl = ml_gen_var_decl(VarName, VarType,
+ mlds__make_context(Context)) },
+ { LocalVarDecls = [VarDecl] },
+
+ % generate the assignment of the boxed variable
+ % to the dereferenced headvar
+ ml_qualify_var(VarName, VarLval),
+ ml_qualify_var(HeadVarName, HeadVarLval),
+ { BoxedVarRval = unop(box(mercury_type(VarType)),
+ lval(VarLval)) },
+ { AssignStatement = ml_gen_assign(
+ mem_ref(lval(HeadVarLval),
+ mercury_type(ArgType)),
+ BoxedVarRval, Context) },
+ { ConvStatements = [AssignStatement] }
+ ),
+ ml_gen_box_existential_output_args(Vars, ArgTypes, Context,
+ BoxedExistentialVars1, Decls1, Statements1),
+ { BoxedExistentialVars = [VarName | BoxedExistentialVars1] },
+ { list__append(LocalVarDecls, Decls1, Decls) },
+ { list__append(ConvStatements, Statements1, Statements) }
+ ;
+ ml_gen_box_existential_output_args(Vars, ArgTypes, Context,
+ BoxedExistentialVars, Decls, Statements)
+ ).
+ml_gen_box_existential_output_args([], [_|_], _, _, _, _) -->
+ { error("ml_gen_box_existential_outputs: length mismatch") }.
+ml_gen_box_existential_output_args([_|_], [], _, _, _, _) -->
+ { error("ml_gen_box_existential_outputs: length mismatch") }.
+
+%
+% If this parameter occurs in BoxedExistentialVars,
+% then prepend `head_' to its name.
+%
+:- type mlds_argument == pair(mlds__entity_name, mlds__type).
+:- func ml_update_param(list(mlds__var_name), mlds_argument) = mlds_argument.
+ml_update_param(BoxedExistentialVars, Arg0) = Arg :-
+ (
+ Arg0 = data(var(Name0)) - Type,
+ list__member(Name0, BoxedExistentialVars)
+ ->
+ string__append("head_", Name0, Name),
+ Arg = data(var(Name)) - Type
+ ;
+ Arg = Arg0
).
%-----------------------------------------------------------------------------%
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.12
diff -u -d -r1.12 ml_code_util.m
--- compiler/ml_code_util.m 2000/05/17 16:01:40 1.12
+++ compiler/ml_code_util.m 2000/05/17 17:24:20
@@ -1255,19 +1255,23 @@
ml_gen_info_init(ModuleInfo, PredId, ProcId) = MLDSGenInfo :-
module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
- _PredInfo, ProcInfo),
+ PredInfo, ProcInfo),
proc_info_headvars(ProcInfo, HeadVars),
proc_info_varset(ProcInfo, VarSet),
proc_info_vartypes(ProcInfo, VarTypes),
proc_info_argmodes(ProcInfo, HeadModes),
+ pred_info_arg_types(PredInfo, ArgTypes),
+ map__from_corresponding_lists(HeadVars, ArgTypes, HeadVarTypes),
OutputVars = select_output_vars(ModuleInfo, HeadVars, HeadModes,
- VarTypes),
+ HeadVarTypes, VarTypes),
+
FuncLabelCounter = 0,
CommitLabelCounter = 0,
CondVarCounter = 0,
ConvVarCounter = 0,
stack__init(SuccContStack),
ExtraDefns = [],
+
MLDSGenInfo = ml_gen_info(
ModuleInfo,
PredId,
@@ -1342,20 +1346,34 @@
% an output mode.
%
:- func select_output_vars(module_info, list(prog_var), list(mode),
- map(prog_var, prog_type)) = list(prog_var).
+ vartypes, vartypes) = list(prog_var).
-select_output_vars(ModuleInfo, HeadVars, HeadModes, VarTypes) = OutputVars :-
+select_output_vars(ModuleInfo, HeadVars, HeadModes, HeadVarTypes, VarTypes)
+ = OutputVars :-
( HeadVars = [], HeadModes = [] ->
OutputVars = []
; HeadVars = [Var|Vars], HeadModes = [Mode|Modes] ->
- map__lookup(VarTypes, Var, Type),
- ( \+ mode_to_arg_mode(ModuleInfo, Mode, Type, top_in) ->
+ map__lookup(VarTypes, Var, VarType),
+ map__lookup(HeadVarTypes, Var, HeadType),
+ (
+ \+ mode_to_arg_mode(ModuleInfo, Mode, VarType, top_in),
+ %
+ % if this argument is an existentially typed output
+ % that we need to box, then don't include it in the
+ % output_vars; ml_gen_box_existential_outputs
+ % will handle these outputs separately.
+ %
+ \+ (
+ HeadType = term__variable(_),
+ VarType = term__functor(_, _, _)
+ )
+ ->
OutputVars1 = select_output_vars(ModuleInfo,
- Vars, Modes, VarTypes),
+ Vars, Modes, HeadVarTypes, VarTypes),
OutputVars = [Var | OutputVars1]
;
OutputVars = select_output_vars(ModuleInfo,
- Vars, Modes, VarTypes)
+ Vars, Modes, HeadVarTypes, VarTypes)
)
;
error("select_output_vars: length mismatch")
Index: tests/hard_coded/existential_float.exp
===================================================================
RCS file: existential_float.exp
diff -N existential_float.exp
--- /dev/null Thu Mar 30 14:06:13 2000
+++ existential_float.exp Thu May 18 03:20:01 2000
@@ -0,0 +1,18 @@
+'c'
+'c'
+42.0000000000000
+42.0000000000000
+'<<predicate>>'
+'<<predicate>>'
+'c'
+'c'
+42.0000000000000
+42.0000000000000
+'<<predicate>>'
+'<<predicate>>'
+'c'
+42.0000000000000
+'<<predicate>>'
+'c'
+42.0000000000000
+'<<predicate>>'
Index: tests/hard_coded/existential_float.m
===================================================================
RCS file: existential_float.m
diff -N existential_float.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ existential_float.m Thu May 18 03:19:21 2000
@@ -0,0 +1,55 @@
+% This module tests the use of existential types,
+% including type inference,
+% but not including type class constraints.
+% This test is designed to test boxing/unboxing
+% of types with non-word size, i.e. chars and floats.
+
+:- module existential_float.
+:- interface.
+:- import_module std_util.
+
+:- some [T] func call_univ_value(univ) = T.
+
+:- some [T] func my_exist_c = T.
+:- some [T] func my_exist_f = T.
+:- some [T] func my_exist_fn = T.
+
+:- import_module io.
+
+:- pred main(io__state::di, state::uo) is det.
+
+:- implementation.
+:- import_module int.
+
+main -->
+ foo(univ(my_exist_c)),
+ foo(univ(my_exist_f)),
+ foo(univ(my_exist_fn)),
+ foo(univ(call_my_exist_c)),
+ foo(univ(call_my_exist_f)),
+ foo(univ(call_my_exist_fn)),
+ write(my_exist_c), nl,
+ write(my_exist_f), nl,
+ write(my_exist_fn), nl,
+ write(call_my_exist_c), nl,
+ write(call_my_exist_f), nl,
+ write(call_my_exist_fn), nl.
+
+my_exist_c = 'c'.
+
+my_exist_f = 42.0.
+
+my_exist_fn = (func(X) = 2 * X).
+
+call_my_exist_c = my_exist_c.
+
+call_my_exist_f = my_exist_f.
+
+call_my_exist_fn = my_exist_fn.
+
+:- pred foo(univ::in, io__state::di, state::uo) is det.
+foo(X) -->
+ write(univ_value(X)), nl,
+ write(call_univ_value(X)), nl.
+
+call_univ_value(Univ) = univ_value(Univ).
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.85
diff -u -d -r1.85 Mmakefile
--- tests/hard_coded/Mmakefile 2000/05/17 07:18:26 1.85
+++ tests/hard_coded/Mmakefile 2000/05/17 12:09:37
@@ -34,6 +34,7 @@
dupcall_types_bug \
elim_special_pred \
existential_bound_tvar \
+ existential_float \
existential_reordering \
existential_type_switch_opt \
existential_types_test \
@@ -134,6 +135,7 @@
MCFLAGS-split_c_files = --trace deep
MCFLAGS-type_spec = --user-guided-type-specialization
MCFLAGS-existential_types_test = --infer-all
+MCFLAGS-existential_float = --infer-all
MCFLAGS-user_defined_equality = --infer-all
MCFLAGS-parse = --trace deep
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh> | of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3 | -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list