[m-rev.] for review: fix a problem with mutables for non-MR_Word types
Zoltan Somogyi
zs at cs.mu.OZ.AU
Thu Feb 23 15:22:27 AEDT 2006
For review by anyone.
Fix a bug reported by Greg Duck. The bug was that the compiler always generated
a global variable of type MR_Word for each mutable, but could then assign
variables of other types to and from this global. If this other type is
float, the assignments discard the fractional part. If this other type
is something else, the result can be even worse.
There are two ways to fix this discrepancy. One is to change the type of the
global, and the other is to change the type of the variables it is assigned
to and from. The former looks cleaner, but it would mean that every call
to the get predicate would require a boxing operation, and that can be
relatively slow, since (e.g. for floats) it may require allocating a heap cell.
This diff implements both solutions.
We use the second solution on the LLDS backend because of its better
performance. We have to use the first solution on the MLDS backend,
because on that backend the type of the mutable variable is reflected
in the signature of the getter and setter predicates (whereas on the
LLDS backend all arguments are always MR_Words).
compiler/options.m:
Add an internal-only option that controls whether we use the first
solution or the second.
compiler/handle_options.m:
Make the MLDS backend imply the first solution.
compiler/prog_data.m:
For each argument of a foreign_proc item, record whether we want to
keep it boxed in the foreign code.
compiler/make_hlds_passes.m:
For each argument of the get and set foreign_procs we create for
mutables, record that we do want to keep it boxed.
Move the action of creating the foreign code for the mutable's
declaration and definition to the third pass, since during the second
pass we don't necessarily know yet what its foreign type is (we may not
have processed a foreign_type declaration affecting it). Move the code
for creating the foreign code here from prog_mutable, since it depends
on the HLDS (and prog_mutable.m is in the parse_tree package).
Hoist some error handling code to put it where it belongs,
and to avoid some errors being reported twice.
compiler/hlds_goal.m:
For each argument of a foreign_proc goal, record whether we want to
keep it boxed in the foreign code.
compiler/llds_out.m:
compiler/pragma_c_gen.m:
compiler/ml_code_gen.m:
compiler/ml_call_gen.m:
If a foreign_proc argument is noted as being kept boxed in the
foreign_proc code, then keep it that way.
compiler/*.m:
Minor changes to conform to the changes in data structures above.
compiler/prog_type.m:
Move a function definition from prog_mutable to prog_type, and
fix the lack of abstraction in its code.
compiler/prog_mutable.m:
Delete the code moved to make_hlds_passes.m and prog_type.m.
compiler/notes/compiler_design.html:
Make the documentation of prog_mutable.m easier to read in source.
tests/hard_coded/float_gv.{m,exp}:
An extended version of Greg's code as a new test case.
tests/hard_coded/Mmakefile:
Enable the new test case.
tests/invalid/bad_mutable.err_exp:
Expect the new output (in which an error is reported just once,
not twice).
cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.22
diff -u -b -r1.22 add_pragma.m
--- compiler/add_pragma.m 22 Feb 2006 08:05:06 -0000 1.22
+++ compiler/add_pragma.m 23 Feb 2006 03:49:22 -0000
@@ -1536,7 +1536,8 @@
map__det_update(Preds0, PredId, !.PredInfo, Preds),
predicate_table_set_preds(Preds, PredTable1, PredTable),
module_info_set_predicate_table(PredTable, !ModuleInfo),
- pragma_get_var_infos(PVars, ArgInfo),
+ pragma_get_var_infos(PVars, ArgInfoBox),
+ assoc_list.keys(ArgInfoBox, ArgInfo),
maybe_warn_pragma_singletons(PragmaImpl, PragmaForeignLanguage,
ArgInfo, Context, PredOrFunc - PredName/Arity,
!.ModuleInfo, !IO)
@@ -1870,7 +1871,7 @@
pragma_get_modes([], []).
pragma_get_modes([PragmaVar | Vars], [Mode | Modes]) :-
- PragmaVar = pragma_var(_Var, _Name, Mode),
+ PragmaVar = pragma_var(_Var, _Name, Mode, _BoxPolicy),
pragma_get_modes(Vars, Modes).
%-----------------------------------------------------------------------------%
@@ -1881,7 +1882,7 @@
pragma_get_vars([], []).
pragma_get_vars([PragmaVar | PragmaVars], [Var | Vars]) :-
- PragmaVar = pragma_var(Var, _Name, _Mode),
+ PragmaVar = pragma_var(Var, _Name, _Mode, _BoxPolicy),
pragma_get_vars(PragmaVars, Vars).
%---------------------------------------------------------------------------%
@@ -1889,12 +1890,13 @@
% Extract the names from the list of pragma_vars.
%
:- pred pragma_get_var_infos(list(pragma_var)::in,
- list(maybe(pair(string, mer_mode)))::out) is det.
+ list(pair(maybe(pair(string, mer_mode)), box_policy))::out) is det.
pragma_get_var_infos([], []).
-pragma_get_var_infos([PragmaVar | PragmaVars], [yes(Name - Mode) | Info]) :-
- PragmaVar = pragma_var(_Var, Name, Mode),
- pragma_get_var_infos(PragmaVars, Info).
+pragma_get_var_infos([PragmaVar | PragmaVars], [Info | Infos]) :-
+ PragmaVar = pragma_var(_Var, Name, Mode, BoxPolicy),
+ Info = yes(Name - Mode) - BoxPolicy,
+ pragma_get_var_infos(PragmaVars, Infos).
module_add_pragma_fact_table(Pred, Arity, FileName, Status, Context,
!ModuleInfo, !QualInfo, !IO) :-
@@ -2026,7 +2028,7 @@
Modes0 = [Mode | ModesTail]
->
varset__lookup_name(VarSet, Var, Name),
- PragmaVar = pragma_var(Var, Name, Mode),
+ PragmaVar = pragma_var(Var, Name, Mode, native_if_possible),
fact_table_pragma_vars(VarsTail, ModesTail, VarSet, PragmaVarsTail),
PragmaVars0 = [PragmaVar | PragmaVarsTail]
;
Index: compiler/add_solver.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_solver.m,v
retrieving revision 1.9
diff -u -b -r1.9 add_solver.m
--- compiler/add_solver.m 28 Nov 2005 04:11:37 -0000 1.9
+++ compiler/add_solver.m 22 Feb 2006 07:44:21 -0000
@@ -209,8 +209,9 @@
% The `func(in) = out(<i_ground>) is det' mode.
%
ToGroundRepnSymName = solver_to_ground_repn_symname(TypeSymName, Arity),
- ToGroundRepnArgs = [ pragma_var(X, "X", in_mode ),
- pragma_var(Y, "Y", OutGroundMode) ],
+ XTGPragmaVar = pragma_var(X, "X", in_mode, native_if_possible),
+ YTGPragmaVar = pragma_var(Y, "Y", OutGroundMode, native_if_possible),
+ ToGroundRepnArgs = [XTGPragmaVar, YTGPragmaVar],
ToGroundRepnForeignProc =
foreign_proc(
Attrs,
@@ -228,8 +229,9 @@
% The `func(in(any)) = out(<i_any>) is det' mode.
%
ToAnyRepnSymName = solver_to_any_repn_symname(TypeSymName, Arity),
- ToAnyRepnArgs = [ pragma_var(X, "X", in_any_mode),
- pragma_var(Y, "Y", OutAnyMode ) ],
+ XTAPragmaVar = pragma_var(X, "X", in_any_mode, native_if_possible),
+ YTAPragmaVar = pragma_var(Y, "Y", OutAnyMode, native_if_possible),
+ ToAnyRepnArgs = [XTAPragmaVar, YTAPragmaVar],
ToAnyRepnForeignProc =
foreign_proc(
Attrs,
@@ -247,8 +249,9 @@
% The `func(in(<i_ground>)) = out is det' mode.
%
FromGroundRepnSymName = repn_to_ground_solver_symname(TypeSymName, Arity),
- FromGroundRepnArgs = [ pragma_var(X, "X", InGroundMode),
- pragma_var(Y, "Y", out_mode) ],
+ XFGPragmaVar = pragma_var(X, "X", InGroundMode, native_if_possible),
+ YFGPragmaVar = pragma_var(Y, "Y", out_mode, native_if_possible),
+ FromGroundRepnArgs = [XFGPragmaVar, YFGPragmaVar],
FromGroundRepnForeignProc =
foreign_proc(
Attrs,
@@ -267,8 +270,9 @@
% The `func(in(<i_any>)) = out(any) is det' mode.
%
FromAnyRepnSymName = repn_to_any_solver_symname(TypeSymName, Arity),
- FromAnyRepnArgs = [ pragma_var(X, "X", InAnyMode ),
- pragma_var(Y, "Y", out_any_mode) ],
+ XFAPragmaVar = pragma_var(X, "X", InAnyMode, native_if_possible),
+ YFAPragmaVar = pragma_var(Y, "Y", out_any_mode, native_if_possible),
+ FromAnyRepnArgs = [XFAPragmaVar, YFAPragmaVar],
FromAnyRepnForeignProc =
foreign_proc(
Attrs,
Index: compiler/add_trail_ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_trail_ops.m,v
retrieving revision 1.29
diff -u -b -r1.29 add_trail_ops.m
--- compiler/add_trail_ops.m 16 Dec 2005 04:08:45 -0000 1.29
+++ compiler/add_trail_ops.m 22 Feb 2006 08:39:47 -0000
@@ -433,7 +433,7 @@
;
GenerateInline = yes,
Args = [foreign_arg(TicketVar, yes("Ticket" - out_mode),
- ticket_type)],
+ ticket_type, native_if_possible)],
ForeignCode = "MR_store_ticket(Ticket);",
trail_generate_foreign_proc("store_ticket", [impure_goal],
[TicketVar - trail_ground_inst], Info ^ module_info, Context,
@@ -452,7 +452,7 @@
;
GenerateInline = yes,
Args = [foreign_arg(TicketVar, yes("Ticket" - in_mode),
- ticket_type)],
+ ticket_type, native_if_possible)],
ForeignCode = "MR_reset_ticket(Ticket, MR_undo);",
trail_generate_foreign_proc("reset_ticket_undo", [impure_goal],
[], Info ^ module_info, Context, Args, ForeignCode,
@@ -471,7 +471,7 @@
;
GenerateInline = yes,
Args = [foreign_arg(TicketVar, yes("Ticket" - in_mode),
- ticket_type)],
+ ticket_type, native_if_possible)],
ForeignCode = "MR_reset_ticket(Ticket, MR_solve);",
trail_generate_foreign_proc("reset_ticket_solve", [impure_goal],
[], Info ^ module_info, Context, Args, ForeignCode,
@@ -490,7 +490,7 @@
;
GenerateInline = yes,
Args = [foreign_arg(TicketVar, yes("Ticket" - in_mode),
- ticket_type)],
+ ticket_type, native_if_possible)],
ForeignCode = "MR_reset_ticket(Ticket, MR_commit);",
trail_generate_foreign_proc("reset_ticket_commit", [impure_goal],
[], Info ^ module_info, Context, Args, ForeignCode,
@@ -548,7 +548,8 @@
;
GenerateInline = yes,
Args = [foreign_arg(SavedTicketCounterVar,
- yes("TicketCounter" - out_mode), ticket_counter_type)],
+ yes("TicketCounter" - out_mode), ticket_counter_type,
+ native_if_possible)],
ForeignCode = "MR_mark_ticket_stack(TicketCounter);",
trail_generate_foreign_proc("mark_ticket_stack", [impure_goal],
[], Info ^ module_info, Context, Args, ForeignCode,
@@ -569,7 +570,8 @@
;
GenerateInline = yes,
Args = [foreign_arg(SavedTicketCounterVar,
- yes("TicketCounter" - in_mode), ticket_counter_type)],
+ yes("TicketCounter" - in_mode), ticket_counter_type,
+ native_if_possible)],
ForeignCode = "MR_prune_tickets_to(TicketCounter);",
trail_generate_foreign_proc("prune_tickets_to", [impure_goal],
[], Info ^ module_info, Context, Args, ForeignCode,
Index: compiler/clause_to_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/clause_to_proc.m,v
retrieving revision 1.60
diff -u -b -r1.60 clause_to_proc.m
--- compiler/clause_to_proc.m 28 Nov 2005 04:11:38 -0000 1.60
+++ compiler/clause_to_proc.m 22 Feb 2006 08:03:55 -0000
@@ -263,10 +263,12 @@
:- func set_arg_names(foreign_arg, prog_varset) = prog_varset.
-set_arg_names(foreign_arg(Arg, MaybeNameMode, _), Vars0) = Vars :-
+set_arg_names(Arg, Vars0) = Vars :-
+ Var = foreign_arg_var(Arg),
+ MaybeNameMode = foreign_arg_maybe_name_mode(Arg),
(
MaybeNameMode = yes(Name - _),
- varset__name_var(Vars0, Arg, Name, Vars)
+ varset__name_var(Vars0, Var, Name, Vars)
;
MaybeNameMode = no,
Vars = Vars0
@@ -283,7 +285,7 @@
select_matching_clauses([], _, []).
select_matching_clauses([Clause | Clauses], ProcId, MatchingClauses) :-
Clause = clause(ProcIds, _, _, _),
- % an empty list here means that the clause applies to all procs
+ % An empty list here means that the clause applies to all procs.
( ProcIds = [] ->
MatchingClauses = [Clause | MatchingClauses1]
; list__member(ProcId, ProcIds) ->
Index: compiler/closure_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/closure_analysis.m,v
retrieving revision 1.4
diff -u -b -r1.4 closure_analysis.m
--- compiler/closure_analysis.m 28 Oct 2005 02:09:59 -0000 1.4
+++ compiler/closure_analysis.m 22 Feb 2006 08:43:53 -0000
@@ -371,7 +371,7 @@
Goal0 = GoalExpr - GoalInfo,
GoalExpr = foreign_proc(_, _, _, Args, _ExtraArgs, _),
ForeignHOArgs = (pred(Arg::in, Out::out) is semidet :-
- Arg = foreign_arg(Var, NameMode, Type),
+ Arg = foreign_arg(Var, NameMode, Type, _BoxPolicy),
%
% A 'no' here means that the foreign argument is unused.
%
Index: compiler/complexity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/complexity.m,v
retrieving revision 1.9
diff -u -b -r1.9 complexity.m
--- compiler/complexity.m 28 Nov 2005 04:11:39 -0000 1.9
+++ compiler/complexity.m 22 Feb 2006 08:44:27 -0000
@@ -283,9 +283,9 @@
SlotGoals),
IsActiveOutputArg = foreign_arg(IsActiveVar,
- yes(IsActiveVarName - out_mode), is_active_type),
+ yes(IsActiveVarName - out_mode), is_active_type, native_if_possible),
SlotInputArg = foreign_arg(SlotVar,
- yes(SlotVarName - in_mode), int_type),
+ yes(SlotVarName - in_mode), int_type, native_if_possible),
ProcNumStr = int_to_string(ProcNum),
@@ -400,7 +400,7 @@
ProcVarName, SlotVarName, PredId, !ProcInfo, !ModuleInfo,
PrefixGoals, ForeignArgs, FillCodeStr),
SlotVarArg = foreign_arg(SlotVar,
- yes(SlotVarName - out_mode), int_type),
+ yes(SlotVarName - out_mode), int_type, native_if_possible),
PredName = "complexity_call_proc",
DeclCodeStr = "\tMR_ComplexityProc *" ++ ProcVarName ++ ";\n",
PredCodeStr = "\tMR_" ++ PredName ++ "(" ++
@@ -448,9 +448,9 @@
ArgName = "arg" ++ int_to_string(VarSeqNum),
TypeInfoArgName = "input_typeinfo" ++ int_to_string(VarSeqNum),
ForeignArg = foreign_arg(ArgVar,
- yes(ArgName - in_mode), VarType),
+ yes(ArgName - in_mode), VarType, native_if_possible),
ForeignTypeInfoArg = foreign_arg(TypeInfoVar,
- yes(TypeInfoArgName - in_mode), TypeInfoType),
+ yes(TypeInfoArgName - in_mode), TypeInfoType, native_if_possible),
ForeignArgs = [ForeignTypeInfoArg, ForeignArg],
CodeStr = "\t" ++ MacroName ++ "(" ++
ProcVarName ++ ", " ++
Index: compiler/equiv_type_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/equiv_type_hlds.m,v
retrieving revision 1.25
diff -u -b -r1.25 equiv_type_hlds.m
--- compiler/equiv_type_hlds.m 23 Nov 2005 05:11:39 -0000 1.25
+++ compiler/equiv_type_hlds.m 22 Feb 2006 08:44:46 -0000
@@ -903,9 +903,9 @@
equiv_type_info::in, equiv_type_info::out) is det.
replace_in_foreign_arg(EqvMap, Arg0, Arg, Changed, !VarSet, !Info) :-
- Arg0 = foreign_arg(Var, NameMode, Type0),
+ Arg0 = foreign_arg(Var, NameMode, Type0, BoxPolicy),
replace_in_type(EqvMap, Type0, Type, Changed, !VarSet, !Info),
- ( Changed = yes, Arg = foreign_arg(Var, NameMode, Type)
+ ( Changed = yes, Arg = foreign_arg(Var, NameMode, Type, BoxPolicy)
; Changed = no, Arg = Arg0
).
Index: compiler/exprn_aux.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/exprn_aux.m,v
retrieving revision 1.65
diff -u -b -r1.65 exprn_aux.m
--- compiler/exprn_aux.m 17 Nov 2005 15:57:10 -0000 1.65
+++ compiler/exprn_aux.m 22 Feb 2006 08:29:58 -0000
@@ -506,20 +506,20 @@
substitute_lval_in_pragma_c_input(OldLval, NewLval, Out0, Out,
!N) :-
Out0 = pragma_c_input(Name, VarType, IsDummy, OrigType, Rval0,
- MaybeForeign),
+ MaybeForeign, BoxPolicy),
substitute_lval_in_rval_count(OldLval, NewLval, Rval0, Rval, !N),
Out = pragma_c_input(Name, VarType, IsDummy, OrigType, Rval,
- MaybeForeign).
+ MaybeForeign, BoxPolicy).
:- pred substitute_lval_in_pragma_c_output(lval::in, lval::in,
pragma_c_output::in, pragma_c_output::out, int::in, int::out) is det.
substitute_lval_in_pragma_c_output(OldLval, NewLval, Out0, Out, !N) :-
Out0 = pragma_c_output(Lval0, VarType, IsDummy, OrigType, Name,
- MaybeForeign),
+ MaybeForeign, BoxPolicy),
substitute_lval_in_lval_count(OldLval, NewLval, Lval0, Lval, !N),
Out = pragma_c_output(Lval, VarType, IsDummy, OrigType, Name,
- MaybeForeign).
+ MaybeForeign, BoxPolicy).
:- pred substitute_lval_in_rval_count(lval::in, lval::in,
rval::in, rval::out, int::in, int::out) is det.
Index: compiler/fact_table.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/fact_table.m,v
retrieving revision 1.70
diff -u -b -r1.70 fact_table.m
--- compiler/fact_table.m 27 Jan 2006 05:52:04 -0000 1.70
+++ compiler/fact_table.m 22 Feb 2006 07:34:37 -0000
@@ -2441,7 +2441,8 @@
:- pred pragma_vars_to_names_string(list(pragma_var)::in, string::out) is det.
pragma_vars_to_names_string([], "").
-pragma_vars_to_names_string([pragma_var(_, Name, _) | PVars], NamesString) :-
+pragma_vars_to_names_string([pragma_var(_, Name, _, _) | PVars],
+ NamesString) :-
pragma_vars_to_names_string(PVars, NamesString0),
string__append_list([Name, ", ", NamesString0], NamesString).
@@ -2460,8 +2461,8 @@
string::in, string::out) is det.
generate_cc_multi_code_2([], _, _, !ProcCode).
-generate_cc_multi_code_2([pragma_var(_, VarName, _) | PragmaVars], StructName,
- ArgNum, !ProcCode) :-
+generate_cc_multi_code_2([pragma_var(_, VarName, _, _) | PragmaVars],
+ StructName, ArgNum, !ProcCode) :-
string__format("\t\t%s = %s[0][0].V_%d;\n", [s(VarName), s(StructName),
i(ArgNum)], NewProcCode),
string__append(NewProcCode, !ProcCode),
@@ -2573,7 +2574,7 @@
unexpected(this_file, "generate_hash_code").
generate_hash_code([_ | _], [], _, _, _, _, _, _, _) :-
unexpected(this_file, "generate_hash_code").
-generate_hash_code([pragma_var(_, Name, Mode) | PragmaVars], [Type | Types],
+generate_hash_code([pragma_var(_, Name, Mode, _) | PragmaVars], [Type | Types],
ModuleInfo, LabelName, LabelNum, PredName, ArgNum,
FactTableSize, C_Code) :-
NextArgNum = ArgNum + 1,
@@ -2771,7 +2772,7 @@
generate_fact_lookup_code(_, [], [_ | _], _, _, _, _) :-
unexpected(this_file, "generate_fact_lookup_code: too many types").
generate_fact_lookup_code(PredName,
- [pragma_var(_, VarName, Mode) | PragmaVars],
+ [pragma_var(_, VarName, Mode, _) | PragmaVars],
[Type | Types], ModuleInfo, ArgNum, FactTableSize, C_Code) :-
NextArgNum = ArgNum + 1,
( mode_is_fully_output(ModuleInfo, Mode) ->
@@ -2956,7 +2957,7 @@
generate_argument_vars_code(PragmaVars, Types, ModuleInfo, DeclCode, InputCode,
OutputCode, SaveRegsCode, GetRegsCode, NumInputArgs) :-
- list__map((pred(X::in, Y::out) is det :- X = pragma_var(_, _, Y)),
+ list__map((pred(X::in, Y::out) is det :- X = pragma_var(_, _, Y, _)),
PragmaVars, Modes),
make_arg_infos(Types, Modes, model_non, ModuleInfo, ArgInfos),
generate_argument_vars_code_2(PragmaVars, ArgInfos, Types, ModuleInfo,
@@ -2980,7 +2981,7 @@
SaveRegsCode = "",
GetRegsCode = ""
;
- PragmaVars0 = [pragma_var(_, VarName, _) | PragmaVars],
+ PragmaVars0 = [pragma_var(_, VarName, _, _) | PragmaVars],
ArgInfos0 = [arg_info(Loc, ArgMode) | ArgInfos],
Types0 = [Type | Types]
->
@@ -3077,7 +3078,7 @@
generate_test_condition_code(FactTableName, [PragmaVar | PragmaVars],
[Type | Types], ModuleInfo, ArgNum, !.IsFirstInputArg,
FactTableSize, CondCode) :-
- PragmaVar = pragma_var(_, Name, Mode),
+ PragmaVar = pragma_var(_, Name, Mode, _),
( mode_is_fully_input(ModuleInfo, Mode) ->
( Type = builtin(string) ->
Template =
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.54
diff -u -b -r1.54 foreign.m
--- compiler/foreign.m 17 Nov 2005 15:57:12 -0000 1.54
+++ compiler/foreign.m 22 Feb 2006 07:32:55 -0000
@@ -401,7 +401,7 @@
(
PredOrFunc = function,
pred_args_to_func_args(!Args, RetArg),
- RetArg = pragma_var(_, RetArgName, RetMode) - RetType,
+ RetArg = pragma_var(_, RetArgName, RetMode, _) - RetType,
mode_to_arg_mode(!.ModuleInfo, RetMode, RetType, RetArgMode),
RetArgMode = top_out,
\+ type_util__is_dummy_argument_type(!.ModuleInfo, RetType)
@@ -449,7 +449,7 @@
:- pred include_import_arg(module_info::in, pair(pragma_var, mer_type)::in)
is semidet.
-include_import_arg(ModuleInfo, pragma_var(_Var, _Name, Mode) - Type) :-
+include_import_arg(ModuleInfo, pragma_var(_Var, _Name, Mode, _Box) - Type) :-
mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode),
ArgMode \= top_unused,
\+ type_util__is_dummy_argument_type(ModuleInfo, Type).
@@ -470,7 +470,7 @@
ArgNum = ArgNum0 + 1,
string__int_to_string(ArgNum, ArgNumString),
string__append("Arg", ArgNumString, ArgName),
- PragmaVar = pragma_var(Var, ArgName, Mode),
+ PragmaVar = pragma_var(Var, ArgName, Mode, native_if_possible),
create_pragma_vars(Vars, Modes, ArgNum, PragmaVars).
create_pragma_vars([_ | _], [], _, _) :-
unexpected(this_file, "create_pragma_vars: length mis-match").
@@ -487,7 +487,7 @@
create_pragma_import_c_code([], _ModuleInfo, !C_Code).
create_pragma_import_c_code([PragmaVar | PragmaVars], ModuleInfo, !C_Code) :-
- PragmaVar = pragma_var(_Var, ArgName, Mode),
+ PragmaVar = pragma_var(_Var, ArgName, Mode, _BoxPolicy),
% Construct the C code fragment for passing this argument, and append it
% to !.C_Code. Note that C handles output arguments by passing the
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.123
diff -u -b -r1.123 goal_util.m
--- compiler/goal_util.m 21 Feb 2006 12:20:25 -0000 1.123
+++ compiler/goal_util.m 22 Feb 2006 08:04:34 -0000
@@ -610,8 +610,10 @@
:- pred rename_arg(bool::in, prog_var_renaming::in,
foreign_arg::in, foreign_arg::out) is det.
-rename_arg(Must, Subn, foreign_arg(Var0, B, C), foreign_arg(Var, B, C)) :-
- rename_var(Must, Subn, Var0, Var).
+rename_arg(Must, Subn, Arg0, Arg) :-
+ Arg0 = foreign_arg(Var0, B, C, D),
+ rename_var(Must, Subn, Var0, Var),
+ Arg = foreign_arg(Var, B, C, D).
%-----------------------------------------------------------------------------%
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.256
diff -u -b -r1.256 handle_options.m
--- compiler/handle_options.m 22 Feb 2006 08:05:06 -0000 1.256
+++ compiler/handle_options.m 23 Feb 2006 03:49:23 -0000
@@ -943,6 +943,9 @@
true
),
+ option_implies(highlevel_code, mutable_always_boxed, bool(no),
+ !Globals),
+
option_implies(target_debug, strip, bool(no), !Globals),
% Inlining happens before the deep profiling transformation, so if
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.147
diff -u -b -r1.147 hlds_goal.m
--- compiler/hlds_goal.m 6 Dec 2005 06:26:06 -0000 1.147
+++ compiler/hlds_goal.m 22 Feb 2006 08:13:14 -0000
@@ -346,17 +346,19 @@
---> foreign_arg(
arg_var :: prog_var,
arg_name_mode :: maybe(pair(string, mer_mode)),
- arg_type :: mer_type
+ arg_type :: mer_type,
+ arg_box_policy :: box_policy
).
:- func foreign_arg_var(foreign_arg) = prog_var.
:- func foreign_arg_maybe_name_mode(foreign_arg) =
maybe(pair(string, mer_mode)).
:- func foreign_arg_type(foreign_arg) = mer_type.
+:- func foreign_arg_box(foreign_arg) = box_policy.
:- pred make_foreign_args(list(prog_var)::in,
- list(maybe(pair(string, mer_mode)))::in, list(mer_type)::in,
- list(foreign_arg)::out) is det.
+ list(pair(maybe(pair(string, mer_mode)), box_policy))::in,
+ list(mer_type)::in, list(foreign_arg)::out) is det.
%-----------------------------------------------------------------------------%
%
@@ -1417,19 +1419,21 @@
foreign_arg_var(Arg) = Arg ^ arg_var.
foreign_arg_maybe_name_mode(Arg) = Arg ^ arg_name_mode.
foreign_arg_type(Arg) = Arg ^ arg_type.
+foreign_arg_box(Arg) = Arg ^ arg_box_policy.
-make_foreign_args(Vars, NamesModes, Types, Args) :-
+make_foreign_args(Vars, NamesModesBoxes, Types, Args) :-
(
Vars = [Var | VarsTail],
- NamesModes = [NameMode | NamesModesTail],
+ NamesModesBoxes = [NameModeBox | NamesModesBoxesTail],
Types = [Type | TypesTail]
->
- make_foreign_args(VarsTail, NamesModesTail, TypesTail, ArgsTail),
- Arg = foreign_arg(Var, NameMode, Type),
+ make_foreign_args(VarsTail, NamesModesBoxesTail, TypesTail, ArgsTail),
+ NameModeBox = NameMode - Box,
+ Arg = foreign_arg(Var, NameMode, Type, Box),
Args = [Arg | ArgsTail]
;
Vars = [],
- NamesModes = [],
+ NamesModesBoxes = [],
Types = []
->
Args = []
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.379
diff -u -b -r1.379 hlds_out.m
--- compiler/hlds_out.m 22 Feb 2006 08:05:07 -0000 1.379
+++ compiler/hlds_out.m 23 Feb 2006 03:49:23 -0000
@@ -1974,7 +1974,7 @@
write_foreign_args([], _, _, _, !IO).
write_foreign_args([Arg | Args], VarSet, TVarSet, AppendVarNums, !IO) :-
- Arg = foreign_arg(Var, MaybeNameMode, Type),
+ Arg = foreign_arg(Var, MaybeNameMode, Type, BoxPolicy),
mercury_output_var(Var, VarSet, AppendVarNums, !IO),
(
MaybeNameMode = yes(Name - Mode),
@@ -1989,6 +1989,12 @@
io__write_string(")", !IO)
;
MaybeNameMode = no
+ ),
+ (
+ BoxPolicy = native_if_possible
+ ;
+ BoxPolicy = always_boxed,
+ io__write_string("$alwaysboxed", !IO)
),
io__write_string("@", !IO),
mercury_output_type(TVarSet, AppendVarNums, Type, !IO),
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.189
diff -u -b -r1.189 intermod.m
--- compiler/intermod.m 28 Nov 2005 04:11:43 -0000 1.189
+++ compiler/intermod.m 22 Feb 2006 08:44:59 -0000
@@ -1801,26 +1801,30 @@
get_pragma_foreign_code_vars(Args, Modes, !VarSet, PragmaVars) :-
(
Args = [Arg | ArgsTail],
- Modes = [Mode | ModesTail]
- ->
- Arg = foreign_arg(Var, MaybeNameAndMode, _),
+ Modes = [Mode | ModesTail],
+ Arg = foreign_arg(Var, MaybeNameAndMode, _, _),
(
MaybeNameAndMode = no,
Name = "_"
;
MaybeNameAndMode = yes(Name - _Mode2)
),
- PragmaVar = pragma_var(Var, Name, Mode),
+ PragmaVar = pragma_var(Var, Name, Mode, native_if_possible),
varset__name_var(!.VarSet, Var, Name, !:VarSet),
get_pragma_foreign_code_vars(ArgsTail, ModesTail, !VarSet,
PragmaVarsTail),
PragmaVars = [PragmaVar | PragmaVarsTail]
;
Args = [],
- Modes = []
- ->
+ Modes = [],
PragmaVars = []
;
+ Args = [],
+ Modes = [_ | _],
+ unexpected(this_file, "get_pragma_foreign_code_vars")
+ ;
+ Args = [_ | _],
+ Modes = [],
unexpected(this_file, "get_pragma_foreign_code_vars")
).
Index: compiler/livemap.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/livemap.m,v
retrieving revision 1.71
diff -u -b -r1.71 livemap.m
--- compiler/livemap.m 28 Nov 2005 04:11:44 -0000 1.71
+++ compiler/livemap.m 22 Feb 2006 08:30:04 -0000
@@ -337,7 +337,7 @@
livemap__build_livemap_pragma_inputs([], !Livevals).
livemap__build_livemap_pragma_inputs([Input | Inputs], !Livevals) :-
- Input = pragma_c_input(_, _, _, _, Rval, _),
+ Input = pragma_c_input(_, _, _, _, Rval, _, _),
( Rval = lval(Lval) ->
livemap__insert_proper_liveval(Lval, !Livevals)
;
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.324
diff -u -b -r1.324 llds.m
--- compiler/llds.m 28 Nov 2005 04:11:44 -0000 1.324
+++ compiler/llds.m 22 Feb 2006 08:10:44 -0000
@@ -577,7 +577,9 @@
% If in_original_type is a foreign type, info about
% that foreign type.
- in_maybe_foreign_type :: maybe(pragma_c_foreign_type)
+ in_maybe_foreign_type :: maybe(pragma_c_foreign_type),
+
+ in_box_policy :: box_policy
).
% A pragma_c_output represents the code that stores one of
@@ -603,7 +605,9 @@
% If in_original_type is a foreign type, info about
% that foreign type.
- out_maybe_foreign_type :: maybe(pragma_c_foreign_type)
+ out_maybe_foreign_type :: maybe(pragma_c_foreign_type),
+
+ out_box_policy :: box_policy
).
:- type pragma_c_foreign_type
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.268
diff -u -b -r1.268 llds_out.m
--- compiler/llds_out.m 28 Nov 2005 04:11:44 -0000 1.268
+++ compiler/llds_out.m 22 Feb 2006 10:12:36 -0000
@@ -2265,7 +2265,8 @@
output_pragma_input_rval_decls([], !DeclSet, !IO).
output_pragma_input_rval_decls([Input | Inputs], !DeclSet, !IO) :-
- Input = pragma_c_input(_VarName, _VarType, _IsDummy, _OrigType, Rval, _),
+ Input = pragma_c_input(_VarName, _VarType, _IsDummy, _OrigType, Rval,
+ _, _),
output_rval_decls(Rval, "\t", "\t", 0, _N, !DeclSet, !IO),
output_pragma_input_rval_decls(Inputs, !DeclSet, !IO).
@@ -2277,7 +2278,7 @@
output_pragma_inputs([], !IO).
output_pragma_inputs([Input | Inputs], !IO) :-
Input = pragma_c_input(_VarName, _VarType, IsDummy, _OrigType, _Rval,
- _MaybeForeignTypeInfo),
+ _MaybeForeignTypeInfo, _BoxPolicy),
(
IsDummy = yes
;
@@ -2293,9 +2294,16 @@
output_pragma_input(Input, !IO) :-
Input = pragma_c_input(VarName, _VarType, _IsDummy, OrigType, Rval,
- MaybeForeignTypeInfo),
+ MaybeForeignTypeInfo, BoxPolicy),
io__write_string("\t", !IO),
(
+ BoxPolicy = always_boxed,
+ io__write_string(VarName, !IO),
+ io__write_string(" = ", !IO),
+ output_rval_as_type(Rval, word, !IO)
+ ;
+ BoxPolicy = native_if_possible,
+ (
MaybeForeignTypeInfo = yes(ForeignTypeInfo),
ForeignTypeInfo = pragma_c_foreign_type(ForeignType, Assertions),
% For foreign types for which c_type_is_word_sized_int_or_ptr
@@ -2335,6 +2343,7 @@
;
output_rval_as_type(Rval, word, !IO)
)
+ )
),
io__write_string(";\n", !IO).
@@ -2345,7 +2354,7 @@
output_pragma_output_lval_decls([], !DeclSet, !IO).
output_pragma_output_lval_decls([O | Outputs], !DeclSet, !IO) :-
- O = pragma_c_output(Lval, _VarType, _IsDummy, _OrigType, _VarName, _),
+ O = pragma_c_output(Lval, _VarType, _IsDummy, _OrigType, _VarName, _, _),
output_lval_decls(Lval, "\t", "\t", 0, _N, !DeclSet, !IO),
output_pragma_output_lval_decls(Outputs, !DeclSet, !IO).
@@ -2358,7 +2367,7 @@
output_pragma_outputs([], !IO).
output_pragma_outputs([Output | Outputs], !IO) :-
Output = pragma_c_output(_Lval, _VarType, IsDummy, _OrigType, _VarName,
- _MaybeForeignType),
+ _MaybeForeignType, _BoxPolicy),
(
IsDummy = yes
;
@@ -2374,9 +2383,16 @@
output_pragma_output(Output, !IO) :-
Output = pragma_c_output(Lval, _VarType, _IsDummy, OrigType, VarName,
- MaybeForeignType),
+ MaybeForeignType, BoxPolicy),
io__write_string("\t", !IO),
(
+ BoxPolicy = always_boxed,
+ output_lval_as_word(Lval, !IO),
+ io__write_string(" = ", !IO),
+ io__write_string(VarName, !IO)
+ ;
+ BoxPolicy = native_if_possible,
+ (
MaybeForeignType = yes(ForeignTypeInfo),
ForeignTypeInfo = pragma_c_foreign_type(ForeignType, Assertions),
( list__member(can_pass_as_mercury_type, Assertions) ->
@@ -2410,6 +2426,7 @@
io__write_string(")", !IO)
;
io__write_string(VarName, !IO)
+ )
)
),
io__write_string(";\n", !IO).
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.25
diff -u -b -r1.25 make_hlds_passes.m
--- compiler/make_hlds_passes.m 22 Feb 2006 08:05:09 -0000 1.25
+++ compiler/make_hlds_passes.m 23 Feb 2006 03:49:24 -0000
@@ -97,6 +97,8 @@
:- implementation.
+:- import_module backend_libs.
+:- import_module backend_libs.foreign.
:- import_module check_hlds.clause_to_proc.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_out.
@@ -276,10 +278,10 @@
module_info::in, module_info::out, io::di, io::uo) is det.
add_item_list_decls_pass_2([], _, !ModuleInfo, !IO).
-add_item_list_decls_pass_2([Item - Context | Items], Status0, !ModuleInfo,
+add_item_list_decls_pass_2([Item - Context | Items], !.Status, !ModuleInfo,
!IO) :-
- add_item_decl_pass_2(Item, Context, Status0, Status1, !ModuleInfo, !IO),
- add_item_list_decls_pass_2(Items, Status1, !ModuleInfo, !IO).
+ add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO),
+ add_item_list_decls_pass_2(Items, !.Status, !ModuleInfo, !IO).
% pass 3:
% Add the clauses one by one to the module.
@@ -454,7 +456,7 @@
add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
% We add the initialise decl and the foreign_decl on the second pass and
% the foreign_proc clauses on the third pass.
- Item = mutable(Name, Type, _InitValue, Inst, Attrs),
+ Item = mutable(Name, Type, _InitValue, Inst, MutAttrs),
!.Status = item_status(ImportStatus, _),
( status_defined_in_this_module(ImportStatus, yes) ->
module_info_get_name(!.ModuleInfo, ModuleName),
@@ -473,7 +475,7 @@
%
% If requested, create the pure access predicates as well.
%
- CreatePureInterface = mutable_var_attach_to_io_state(Attrs),
+ CreatePureInterface = mutable_var_attach_to_io_state(MutAttrs),
(
CreatePureInterface = yes,
PureGetPredDecl = prog_mutable.pure_get_pred_decl(ModuleName,
@@ -497,7 +499,6 @@
true
).
-
:- pred add_solver_type_mutable_items_pass_1(list(item)::in, prog_context::in,
item_status::in, item_status::out, module_info::in, module_info::out,
io::di, io::uo) is det.
@@ -543,7 +544,7 @@
PredOrFunc, SymName, TypesAndModes, _WithType, _WithInst,
_MaybeDet, _Cond, _Purity, _ClassContext),
%
- % add default modes for function declarations, if necessary
+ % Add default modes for function declarations, if necessary.
%
(
PredOrFunc = predicate
@@ -637,7 +638,7 @@
true
).
add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
- Item = mutable(Name, _Type, _InitTerm, _Inst, Attrs),
+ Item = mutable(Name, _Type, _InitTerm, _Inst, MutAttrs),
!.Status = item_status(ImportStatus, _),
( ImportStatus = exported ->
error_is_exported(Context, "`mutable' declaration", !IO),
@@ -651,33 +652,39 @@
% duplicating the definition of the global variable in any submodules.
%
( status_defined_in_this_module(ImportStatus, yes) ->
- mutable_var_maybe_foreign_names(Attrs) = MaybeForeignNames,
+ globals.io_get_target(CompilationTarget, !IO),
+ %
+ % XXX We don't currently support the foreign_name attribute
+ % for languages other than C.
+ %
+ ( CompilationTarget = c ->
+ mutable_var_maybe_foreign_names(MutAttrs) = MaybeForeignNames,
+ module_info_get_name(!.ModuleInfo, ModuleName),
(
- MaybeForeignNames = no,
- TargetMutableName = mutable_c_var_name(ModuleName, Name)
+ MaybeForeignNames = no
;
MaybeForeignNames = yes(ForeignNames),
%
- % Report any errors with the foreign_name attributes during
- % this pass.
+ % Report any errors with the foreign_name attributes
+ % during this pass.
%
ReportErrors = yes,
get_global_name_from_foreign_names(ReportErrors, Context,
- ModuleName, Name, ForeignNames, TargetMutableName, !IO)
- ),
- %
- % XXX We don't currently support languages other than C.
- %
- module_info_get_name(!.ModuleInfo, ModuleName),
- ForeignDecl = get_global_foreign_decl(TargetMutableName),
- add_item_decl_pass_2(ForeignDecl, Context, !Status, !ModuleInfo, !IO),
- ForeignCode = get_global_foreign_defn(TargetMutableName),
- add_item_decl_pass_2(ForeignCode, Context, !Status, !ModuleInfo, !IO)
+ ModuleName, Name, ForeignNames, _TargetMutableName, !IO)
+ )
+ ;
+ NYIError = [
+ words("Error: foreign_name mutable attribute not yet"),
+ words("implemented for the"),
+ fixed(compilation_target_string(CompilationTarget)),
+ words("backend.")
+ ],
+ write_error_pieces(Context, 0, NYIError, !IO)
+ )
;
true
).
-
:- pred add_solver_type_mutable_items_pass_2(list(item)::in, prog_context::in,
item_status::in, item_status::out, module_info::in, module_info::out,
io::di, io::uo) is det.
@@ -700,14 +707,7 @@
get_global_name_from_foreign_names(ReportErrors, Context, ModuleName,
MercuryMutableName, ForeignNames, TargetMutableName, !IO) :-
- globals.io_get_target(CompilationTarget, !IO),
- %
- % XXX We don't currently support the foreign_name attribute for languages
- % other than C.
- %
- ( CompilationTarget = c ->
- solutions(get_matching_foreign_name(ForeignNames, c),
- TargetMutableNames),
+ solutions(get_matching_foreign_name(ForeignNames, c), TargetMutableNames),
(
TargetMutableNames = [],
TargetMutableName = mutable_c_var_name(ModuleName,
@@ -718,35 +718,20 @@
% in the target language here.
;
TargetMutableNames = [_, _ | _],
+ (
+ ReportErrors = yes,
+ globals.io_get_target(CompilationTarget, !IO),
MultipleNamesError = [
words("Error: multiple foreign_name attributes specified"),
words("for the"),
fixed(compilation_target_string(CompilationTarget)),
words("backend.")
],
- write_error_pieces(Context, 0, MultipleNamesError, !IO),
- TargetMutableName = mutable_c_var_name(ModuleName,
- MercuryMutableName)
- )
- ;
- (
- ReportErrors = yes,
- NYIError = [
- words("Error: foreign_name mutable attribute not yet"),
- words("implemented for the"),
- fixed(compilation_target_string(CompilationTarget)),
- words("backend.")
- ],
- write_error_pieces(Context, 0, NYIError, !IO)
+ write_error_pieces(Context, 0, MultipleNamesError, !IO)
;
ReportErrors = no
),
- %
- % This is just a dummy value - we only get here if an error
- % has occured.
- %
- TargetMutableName = mutable_c_var_name(ModuleName,
- MercuryMutableName)
+ TargetMutableName = mutable_c_var_name(ModuleName, MercuryMutableName)
).
:- pred get_matching_foreign_name(list(foreign_name)::in,
@@ -1162,7 +1147,7 @@
module_info_incr_errors(!ModuleInfo)
).
add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- Item = mutable(Name, _Type, InitTerm, Inst, MutAttrs),
+ Item = mutable(Name, Type, InitTerm, Inst, MutAttrs),
( status_defined_in_this_module(!.Status, yes) ->
module_info_get_name(!.ModuleInfo, ModuleName),
varset.new_named_var(varset.init, "X", X, ProgVarSet0),
@@ -1174,6 +1159,40 @@
;
Attrs = Attrs1
),
+
+ mutable_var_maybe_foreign_names(MutAttrs) = MaybeForeignNames,
+ (
+ MaybeForeignNames = no,
+ TargetMutableName = mutable_c_var_name(ModuleName, Name)
+ ;
+ MaybeForeignNames = yes(ForeignNames),
+ ReportErrors = no, % We've already reported them during pass 2.
+ get_global_name_from_foreign_names(ReportErrors, Context,
+ ModuleName, Name, ForeignNames, TargetMutableName, !IO)
+ ),
+
+ globals.io_get_target(CompilationTarget, !IO),
+ %
+ % We add the foreign code declaration and definition here rather than
+ % in pass 2 because the target-language-specific type name depends on
+ % whether there are any foreign_type declarations for Type.
+ %
+ % XXX We don't currently support the foreign_name attribute
+ % for languages other than C.
+ %
+ ( CompilationTarget = c ->
+ get_mutable_global_foreign_decl_defn(!.ModuleInfo, Type,
+ TargetMutableName, ForeignDecl, ForeignDefn),
+ ItemStatus0 = item_status(local, may_be_unqualified),
+ add_item_decl_pass_2(ForeignDecl, Context, ItemStatus0, _,
+ !ModuleInfo, !IO),
+ add_item_decl_pass_2(ForeignDefn, Context, ItemStatus0, _,
+ !ModuleInfo, !IO)
+ ;
+ % The error message was printed in pass 2.
+ true
+ ),
+
%
% Add the `:- initialise' declaration and clause for the
% initialise predicate.
@@ -1187,21 +1206,20 @@
[InitTerm], purity_impure) - Context),
add_item_clause(InitClause, !Status, Context, !ModuleInfo, !QualInfo,
!IO),
- mutable_var_maybe_foreign_names(MutAttrs) = MaybeForeignNames,
+ globals.io_lookup_bool_option(mutable_always_boxed, AlwaysBoxed, !IO),
(
- MaybeForeignNames = no,
- TargetMutableName = mutable_c_var_name(ModuleName, Name)
+ AlwaysBoxed = yes,
+ BoxPolicy = always_boxed
;
- MaybeForeignNames = yes(ForeignNames),
- ReportErrors = no, % We've already reported them during pass 2.
- get_global_name_from_foreign_names(ReportErrors, Context,
- ModuleName, Name, ForeignNames, TargetMutableName, !IO)
+ AlwaysBoxed = no,
+ BoxPolicy = native_if_possible
),
set_purity(purity_semipure, Attrs, GetAttrs),
NonPureGetClause = pragma(compiler(mutable_decl),
foreign_proc(GetAttrs,
mutable_get_pred_sym_name(ModuleName, Name), predicate,
- [pragma_var(X, "X", out_mode(Inst))], ProgVarSet0, InstVarset,
+ [pragma_var(X, "X", out_mode(Inst), BoxPolicy)],
+ ProgVarSet0, InstVarset,
ordinary("X = " ++ TargetMutableName ++ ";", yes(Context)))),
add_item_clause(NonPureGetClause, !Status, Context, !ModuleInfo,
!QualInfo, !IO),
@@ -1232,9 +1250,11 @@
TrailCode = ""
)
),
- NonPureSetClause = pragma(compiler(mutable_decl), foreign_proc(Attrs,
+ NonPureSetClause = pragma(compiler(mutable_decl),
+ foreign_proc(Attrs,
mutable_set_pred_sym_name(ModuleName, Name), predicate,
- [pragma_var(X, "X", in_mode(Inst))], ProgVarSet0, InstVarset,
+ [pragma_var(X, "X", in_mode(Inst), BoxPolicy)],
+ ProgVarSet0, InstVarset,
ordinary(TrailCode ++ TargetMutableName ++ " = X;",
yes(Context)))),
add_item_clause(NonPureSetClause, !Status, Context, !ModuleInfo,
@@ -1256,9 +1276,9 @@
foreign_proc(PureIntAttrs,
mutable_set_pred_sym_name(ModuleName, Name), predicate,
[
- pragma_var(X, "X", in_mode(Inst)),
- pragma_var(IO0, "IO0", di_mode),
- pragma_var(IO, "IO", uo_mode)
+ pragma_var(X, "X", in_mode(Inst), BoxPolicy),
+ pragma_var(IO0, "IO0", di_mode, native_if_possible),
+ pragma_var(IO, "IO", uo_mode, native_if_possible)
], ProgVarSet, InstVarset,
ordinary(TargetMutableName ++ " = X; IO = IO0;",
yes(Context)
@@ -1271,13 +1291,11 @@
foreign_proc(PureIntAttrs,
mutable_get_pred_sym_name(ModuleName, Name), predicate,
[
- pragma_var(X, "X", out_mode(Inst)),
- pragma_var(IO0, "IO0", di_mode),
- pragma_var(IO, "IO", uo_mode)
+ pragma_var(X, "X", out_mode(Inst), BoxPolicy),
+ pragma_var(IO0, "IO0", di_mode, native_if_possible),
+ pragma_var(IO, "IO", uo_mode, native_if_possible)
], ProgVarSet, InstVarset,
- ordinary(
- "X = " ++ TargetMutableName ++ ";" ++
- "IO = IO0;",
+ ordinary("X = " ++ TargetMutableName ++ "; IO = IO0;",
yes(Context)
)
)
@@ -1291,6 +1309,34 @@
true
).
+ % Create the foreign_decl for the mutable. The bool should be true if
+ % mutables are always boxed.
+ %
+:- pred get_mutable_global_foreign_decl_defn(module_info::in, mer_type::in,
+ string::in, item::out, item::out) is det.
+
+get_mutable_global_foreign_decl_defn(ModuleInfo, Type, TargetMutableName,
+ Decl, Defn) :-
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, mutable_always_boxed, AlwaysBoxed),
+ globals.get_target(Globals, Backend),
+ ( Backend = c ->
+ TypeName = global_foreign_type_name(AlwaysBoxed, c, ModuleInfo, Type),
+ Decl = pragma(compiler(mutable_decl),
+ foreign_decl(c, foreign_decl_is_exported,
+ "extern " ++ TypeName ++ " " ++ TargetMutableName ++ ";")),
+ Defn = pragma(compiler(mutable_decl),
+ foreign_code(c, TypeName ++ " " ++ TargetMutableName ++ ";"))
+ ;
+ sorry(this_file, "we don't yet support mutables for non-C backends")
+ ).
+
+:- func global_foreign_type_name(bool, foreign_language, module_info, mer_type)
+ = string.
+
+global_foreign_type_name(yes, _, _, _) = "MR_Word".
+global_foreign_type_name(no, Lang, ModuleInfo, Type) =
+ to_type_string(Lang, ModuleInfo, Type).
:- pred add_solver_type_mutable_items_clauses(list(item)::in,
import_status::in, import_status::out, prog_context::in,
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.280
diff -u -b -r1.280 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 22 Feb 2006 08:05:11 -0000 1.280
+++ compiler/mercury_to_mercury.m 23 Feb 2006 03:49:25 -0000
@@ -3088,7 +3088,7 @@
% The predicate or function arguments in a `:- pragma import'
% declaration are not named.
ImportModes = list__map(
- (func(pragma_var(_, _, ImportMode)) = ImportMode), Vars0),
+ (func(pragma_var(_, _, ImportMode, _)) = ImportMode), Vars0),
mercury_format_pragma_import(PredName, PredOrFunc, ImportModes,
Attributes, C_Function, !U)
@@ -3196,7 +3196,7 @@
mercury_format_pragma_foreign_code_vars_2([], _, _, !U).
mercury_format_pragma_foreign_code_vars_2([Var | Vars], ProgVarset,
InstVarset, !U) :-
- Var = pragma_var(_Var, VarName, Mode),
+ Var = pragma_var(_Var, VarName, Mode, _BoxPolicy),
add_string(VarName, !U),
add_string(" :: ", !U),
mercury_format_mode(Mode, simple_inst_info(InstVarset), !U),
Index: compiler/middle_rec.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/middle_rec.m,v
retrieving revision 1.111
diff -u -b -r1.111 middle_rec.m
--- compiler/middle_rec.m 17 Nov 2005 15:57:22 -0000 1.111
+++ compiler/middle_rec.m 22 Feb 2006 08:36:14 -0000
@@ -595,7 +595,7 @@
insert_pragma_c_input_registers([], !Used).
insert_pragma_c_input_registers([Input | Inputs], !Used) :-
- Input = pragma_c_input(_, _, _, _, Rval, _),
+ Input = pragma_c_input(_, _, _, _, Rval, _, _),
middle_rec__find_used_registers_rval(Rval, !Used),
insert_pragma_c_input_registers(Inputs, !Used).
@@ -604,7 +604,7 @@
insert_pragma_c_output_registers([], !Used).
insert_pragma_c_output_registers([Output | Outputs], !Used) :-
- Output = pragma_c_output(Lval, _, _, _, _, _),
+ Output = pragma_c_output(Lval, _, _, _, _, _, _),
middle_rec__find_used_registers_lval(Lval, !Used),
insert_pragma_c_output_registers(Outputs, !Used).
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.61
diff -u -b -r1.61 ml_call_gen.m
--- compiler/ml_call_gen.m 17 Nov 2005 15:57:23 -0000 1.61
+++ compiler/ml_call_gen.m 22 Feb 2006 09:26:01 -0000
@@ -77,7 +77,7 @@
% holding a value of the source type, produce an rval that converts
% the source rval to the destination type.
%
-:- pred ml_gen_box_or_unbox_rval(mer_type::in, mer_type::in,
+:- pred ml_gen_box_or_unbox_rval(mer_type::in, mer_type::in, box_policy::in,
mlds_rval::in, mlds_rval::out, ml_gen_info::in, ml_gen_info::out) is det.
% ml_gen_box_or_unbox_lval(CallerType, CalleeType, VarLval, VarName,
@@ -99,9 +99,9 @@
% from the ArgNum-th entry in the `type_params' local.
% (If ForClosureWrapper = no, then ArgNum is unused.)
%
-:- pred ml_gen_box_or_unbox_lval(mer_type::in, mer_type::in, mlds_lval::in,
- var_name::in, prog_context::in, bool::in, int::in, mlds_lval::out,
- mlds__defns::out, statements::out, statements::out,
+:- pred ml_gen_box_or_unbox_lval(mer_type::in, mer_type::in, box_policy::in,
+ mlds_lval::in, var_name::in, prog_context::in, bool::in, int::in,
+ mlds_lval::out, mlds__defns::out, statements::out, statements::out,
ml_gen_info::in, ml_gen_info::out) is det.
% Generate the appropriate MLDS type for a continuation function
@@ -315,7 +315,7 @@
( is_dummy_argument_type(ModuleInfo, DestType) ->
Statements = []
;
- ml_gen_box_or_unbox_rval(SrcType, DestType,
+ ml_gen_box_or_unbox_rval(SrcType, DestType, native_if_possible,
lval(SrcLval), CastRval, !Info),
Assign = ml_gen_assign(DestLval, CastRval, Context),
Statements = [Assign]
@@ -665,8 +665,8 @@
;
VarRval = lval(VarLval)
),
- ml_gen_box_or_unbox_rval(CallerType, CalleeType, VarRval, ArgRval,
- !Info),
+ ml_gen_box_or_unbox_rval(CallerType, CalleeType,
+ native_if_possible, VarRval, ArgRval, !Info),
InputRvals = [ArgRval | InputRvals1],
OutputLvals = OutputLvals1,
OutputTypes = OutputTypes1,
@@ -674,8 +674,9 @@
ConvOutputStatements = ConvOutputStatements1
;
% It's an output argument.
- ml_gen_box_or_unbox_lval(CallerType, CalleeType, VarLval, VarName,
- Context, ForClosureWrapper, ArgNum, ArgLval, ThisArgConvDecls,
+ ml_gen_box_or_unbox_lval(CallerType, CalleeType,
+ native_if_possible, VarLval, VarName, Context,
+ ForClosureWrapper, ArgNum, ArgLval, ThisArgConvDecls,
_ThisArgConvInput, ThisArgConvOutput, !Info),
ConvDecls = ThisArgConvDecls ++ ConvDecls1,
ConvOutputStatements = ThisArgConvOutput ++ ConvOutputStatements1,
@@ -721,9 +722,14 @@
ml_gen_mem_addr(Lval) =
(if Lval = mem_ref(Rval, _) then Rval else mem_addr(Lval)).
-ml_gen_box_or_unbox_rval(SourceType, DestType, VarRval, ArgRval, !Info) :-
+ml_gen_box_or_unbox_rval(SourceType, DestType, BoxPolicy, VarRval, ArgRval,
+ !Info) :-
% Convert VarRval, of type SourceType, to ArgRval, of type DestType.
(
+ BoxPolicy = always_boxed
+ ->
+ ArgRval = VarRval
+ ;
% If converting from polymorphic type to concrete type, then unbox.
SourceType = variable(_, _),
DestType \= variable(_, _)
@@ -785,14 +791,14 @@
ArgRval = VarRval
).
-ml_gen_box_or_unbox_lval(CallerType, CalleeType, VarLval, VarName, Context,
- ForClosureWrapper, ArgNum, ArgLval, ConvDecls,
+ml_gen_box_or_unbox_lval(CallerType, CalleeType, BoxPolicy, VarLval, VarName,
+ Context, ForClosureWrapper, ArgNum, ArgLval, ConvDecls,
ConvInputStatements, ConvOutputStatements, !Info) :-
% First see if we can just convert the lval as an rval;
% if no boxing/unboxing is required, then ml_box_or_unbox_rval
% will return its argument unchanged, and so we're done.
- ml_gen_box_or_unbox_rval(CalleeType, CallerType, lval(VarLval),
- BoxedRval, !Info),
+ ml_gen_box_or_unbox_rval(CalleeType, CallerType, BoxPolicy,
+ lval(VarLval), BoxedRval, !Info),
( BoxedRval = lval(VarLval) ->
ArgLval = VarLval,
ConvDecls = [],
@@ -856,17 +862,17 @@
% to/from the output argument whose address we were passed.
% Assign to the freshly generated arg variable.
- ml_gen_box_or_unbox_rval(CallerType, CalleeType,
+ ml_gen_box_or_unbox_rval(CallerType, CalleeType, BoxPolicy,
lval(VarLval), ConvertedVarRval, !Info),
- AssignInputStatement = ml_gen_assign(ArgLval,
- ConvertedVarRval, Context),
+ AssignInputStatement = ml_gen_assign(ArgLval, ConvertedVarRval,
+ Context),
ConvInputStatements = [AssignInputStatement],
% Assign from the freshly generated arg variable.
- ml_gen_box_or_unbox_rval(CalleeType, CallerType,
+ ml_gen_box_or_unbox_rval(CalleeType, CallerType, BoxPolicy,
lval(ArgLval), ConvertedArgRval, !Info),
- AssignOutputStatement = ml_gen_assign(VarLval,
- ConvertedArgRval, Context),
+ AssignOutputStatement = ml_gen_assign(VarLval, ConvertedArgRval,
+ Context),
ConvOutputStatements = [AssignOutputStatement]
)
).
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.168
diff -u -b -r1.168 ml_code_gen.m
--- compiler/ml_code_gen.m 11 Jan 2006 02:33:41 -0000 1.168
+++ compiler/ml_code_gen.m 22 Feb 2006 09:30:09 -0000
@@ -1399,9 +1399,9 @@
% to convert its type from HeadType to BodyType.
ml_gen_info_get_varset(!.Info, VarSet),
VarName = ml_gen_var_name(VarSet, Var),
- ml_gen_box_or_unbox_lval(HeadType, BodyType, HeadVarLval, VarName,
- Context, no, 0, BodyLval, ConvDecls, ConvInputStatements,
- ConvOutputStatements, !Info),
+ ml_gen_box_or_unbox_lval(HeadType, BodyType, native_if_possible,
+ HeadVarLval, VarName, Context, no, 0, BodyLval, ConvDecls,
+ ConvInputStatements, ConvOutputStatements, !Info),
% Ensure that for any uses of this variable in the procedure body,
% we use the BodyLval (which has type BodyType) rather than the
@@ -2384,12 +2384,18 @@
ml_gen_info::in, ml_gen_info::out) is det.
ml_gen_outline_args([], [], !Info).
-ml_gen_outline_args([foreign_arg(Var, MaybeVarMode, OrigType) | Args],
- [OutlineArg | OutlineArgs], !Info) :-
+ml_gen_outline_args([Arg | Args], [OutlineArg | OutlineArgs], !Info) :-
+ Arg = foreign_arg(Var, MaybeVarMode, OrigType, BoxPolicy),
ml_gen_outline_args(Args, OutlineArgs, !Info),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
ml_gen_var(!.Info, Var, VarLval),
- ml_gen_type(!.Info, OrigType, MldsType),
+ (
+ BoxPolicy = native_if_possible,
+ ml_gen_type(!.Info, OrigType, MldsType)
+ ;
+ BoxPolicy = always_boxed,
+ MldsType = mlds.generic_type
+ ),
(
MaybeVarMode = yes(ArgName - Mode),
\+ is_dummy_argument_type(ModuleInfo, OrigType),
@@ -2486,7 +2492,7 @@
build_arg_map([], !ArgMap).
build_arg_map([ForeignArg | ForeignArgs], !ArgMap) :-
- ForeignArg = foreign_arg(Var, _, _),
+ ForeignArg = foreign_arg(Var, _, _, _),
map__det_insert(!.ArgMap, Var, ForeignArg, !:ArgMap),
build_arg_map(ForeignArgs, !ArgMap).
@@ -2498,9 +2504,15 @@
ml_gen_pragma_il_proc_assign_output(ModuleInfo, MLDSModuleName, ArgMap,
VarSet, Context, IsByRef, Var, Statement) :-
map__lookup(ArgMap, Var, ForeignArg),
- ForeignArg = foreign_arg(_, MaybeNameMode, Type),
+ ForeignArg = foreign_arg(_, MaybeNameMode, Type, BoxPolicy),
not is_dummy_argument_type(ModuleInfo, Type),
- MLDSType = mercury_type_to_mlds_type(ModuleInfo, Type),
+ (
+ BoxPolicy = always_boxed,
+ MLDSType = mlds.generic_type
+ ;
+ BoxPolicy = native_if_possible,
+ MLDSType = mercury_type_to_mlds_type(ModuleInfo, Type)
+ ),
VarName = ml_gen_var_name(VarSet, Var),
QualVarName = qual(MLDSModuleName, module_qual, VarName),
@@ -2527,7 +2539,7 @@
ml_gen_pragma_il_proc_var_decl_defn(ModuleInfo, MLDSModuleName, ArgMap, VarSet,
MLDSContext, ByRefOutputVars, CopiedOutputVars, Var, Defn) :-
map__lookup(ArgMap, Var, ForeignArg),
- ForeignArg = foreign_arg(_, MaybeNameMode, Type),
+ ForeignArg = foreign_arg(_, MaybeNameMode, Type, BoxPolicy),
VarName = ml_gen_var_name(VarSet, Var),
(
MaybeNameMode = yes(UserVarNameString - _),
@@ -2536,6 +2548,13 @@
MaybeNameMode = no,
sorry(this_file, "no variable name for var")
),
+ (
+ BoxPolicy = always_boxed,
+ MLDSType0 = mlds.generic_type
+ ;
+ BoxPolicy = native_if_possible,
+ MLDSType0 = mercury_type_to_mlds_type(ModuleInfo, Type)
+ ),
% Dummy arguments are just mapped to integers, since they shouldn't be
% used in any way that requires them to have a real value.
@@ -2544,12 +2563,12 @@
MLDSType = mlds__native_int_type
; list__member(Var, ByRefOutputVars) ->
Initializer = no_initializer,
- MLDSType = mercury_type_to_mlds_type(ModuleInfo, Type)
+ MLDSType = MLDSType0
; list__member(Var, CopiedOutputVars) ->
Initializer = no_initializer,
- MLDSType = mercury_type_to_mlds_type(ModuleInfo, Type)
+ MLDSType = MLDSType0
;
- MLDSType = mercury_type_to_mlds_type(ModuleInfo, Type),
+ MLDSType = MLDSType0,
QualVarName = qual(MLDSModuleName, module_qual, VarName),
Initializer = init_obj(lval(var(QualVarName, MLDSType)))
),
@@ -2807,14 +2826,20 @@
:- pred ml_gen_pragma_c_decl(ml_gen_info::in, foreign_language::in,
foreign_arg::in, target_code_component::out) is det.
-ml_gen_pragma_c_decl(Info, Lang, foreign_arg(_Var, MaybeNameAndMode, Type),
- Decl) :-
+ml_gen_pragma_c_decl(Info, Lang, Arg, Decl) :-
+ Arg = foreign_arg(_Var, MaybeNameAndMode, Type, BoxPolicy),
ml_gen_info_get_module_info(Info, ModuleInfo),
(
MaybeNameAndMode = yes(ArgName - _Mode),
\+ var_is_singleton(ArgName)
->
- TypeString = foreign__to_type_string(Lang, ModuleInfo, Type),
+ (
+ BoxPolicy = always_boxed,
+ TypeString = "MR_Word"
+ ;
+ BoxPolicy = native_if_possible,
+ TypeString = foreign__to_type_string(Lang, ModuleInfo, Type)
+ ),
string__format("\t%s %s;\n", [s(TypeString), s(ArgName)], DeclString)
;
% If the variable doesn't occur in the ArgNames list,
@@ -2863,13 +2888,13 @@
ml_gen_pragma_c_input_arg(Lang, ForeignArg, AssignInput, !Info) :-
ml_gen_info_get_module_info(!.Info, ModuleInfo),
(
- ForeignArg = foreign_arg(Var, MaybeNameAndMode, OrigType),
+ ForeignArg = foreign_arg(Var, MaybeNameAndMode, OrigType, BoxPolicy),
MaybeNameAndMode = yes(ArgName - Mode),
\+ var_is_singleton(ArgName),
mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_in)
->
ml_gen_pragma_c_gen_input_arg(Lang, Var, ArgName, OrigType,
- AssignInput, !Info)
+ BoxPolicy, AssignInput, !Info)
;
% If the variable doesn't occur in the ArgNames list,
% it can't be used, so we just ignore it.
@@ -2877,11 +2902,11 @@
).
:- pred ml_gen_pragma_c_gen_input_arg(foreign_language::in, prog_var::in,
- string::in, mer_type::in, list(target_code_component)::out,
+ string::in, mer_type::in, box_policy::in, list(target_code_component)::out,
ml_gen_info::in, ml_gen_info::out) is det.
-ml_gen_pragma_c_gen_input_arg(Lang, Var, ArgName, OrigType, AssignInput,
- !Info) :-
+ml_gen_pragma_c_gen_input_arg(Lang, Var, ArgName, OrigType, BoxPolicy,
+ AssignInput, !Info) :-
ml_variable_type(!.Info, Var, VarType),
ml_gen_var(!.Info, Var, VarLval),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
@@ -2892,8 +2917,8 @@
% generated for this variable.
ArgRval = const(int_const(0))
;
- ml_gen_box_or_unbox_rval(VarType, OrigType, lval(VarLval),
- ArgRval, !Info)
+ ml_gen_box_or_unbox_rval(VarType, OrigType, BoxPolicy,
+ lval(VarLval), ArgRval, !Info)
),
% At this point we have an rval with the right type for *internal* use
% in the code generated by the Mercury compiler's MLDS back-end. We need
@@ -2985,7 +3010,7 @@
ml_gen_pragma_java_output_arg(_Lang, ForeignArg, Context, AssignOutput,
ConvDecls, ConvOutputStatements, !Info) :-
- ForeignArg = foreign_arg(Var, MaybeNameAndMode, OrigType),
+ ForeignArg = foreign_arg(Var, MaybeNameAndMode, OrigType, BoxPolicy),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
(
MaybeNameAndMode = yes(ArgName - Mode),
@@ -2997,8 +3022,8 @@
% code generated by the Mercury compiler's MLDS back-end.
ml_variable_type(!.Info, Var, VarType),
ml_gen_var(!.Info, Var, VarLval),
- ml_gen_box_or_unbox_lval(VarType, OrigType, VarLval,
- mlds__var_name(ArgName, no), Context, no, 0,
+ ml_gen_box_or_unbox_lval(VarType, OrigType, BoxPolicy,
+ VarLval, mlds__var_name(ArgName, no), Context, no, 0,
ArgLval, ConvDecls, _ConvInputStatements,
ConvOutputStatements, !Info),
% This is the MLDS type of the original argument, which we need to
@@ -3052,8 +3077,9 @@
mlds__defns::out, statements::out,
ml_gen_info::in, ml_gen_info::out) is det.
-ml_gen_pragma_c_output_arg(Lang, foreign_arg(Var, MaybeNameAndMode, OrigType),
- Context, AssignOutput, ConvDecls, ConvOutputStatements, !Info) :-
+ml_gen_pragma_c_output_arg(Lang, Arg, Context, AssignOutput, ConvDecls,
+ ConvOutputStatements, !Info) :-
+ Arg = foreign_arg(Var, MaybeNameAndMode, OrigType, BoxPolicy),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
(
MaybeNameAndMode = yes(ArgName - Mode),
@@ -3061,7 +3087,7 @@
\+ is_dummy_argument_type(ModuleInfo, OrigType),
mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_out)
->
- ml_gen_pragma_c_gen_output_arg(Lang, Var, ArgName, OrigType,
+ ml_gen_pragma_c_gen_output_arg(Lang, Var, ArgName, OrigType, BoxPolicy,
Context, AssignOutput, ConvDecls, ConvOutputStatements, !Info)
;
% If the variable doesn't occur in the ArgNames list,
@@ -3072,15 +3098,15 @@
).
:- pred ml_gen_pragma_c_gen_output_arg(foreign_language::in, prog_var::in,
- string::in, mer_type::in, prog_context::in,
+ string::in, mer_type::in, box_policy::in, prog_context::in,
list(target_code_component)::out, mlds__defns::out,
statements::out, ml_gen_info::in, ml_gen_info::out) is det.
-ml_gen_pragma_c_gen_output_arg(Lang, Var, ArgName, OrigType, Context,
- AssignOutput, ConvDecls, ConvOutputStatements, !Info) :-
+ml_gen_pragma_c_gen_output_arg(Lang, Var, ArgName, OrigType, BoxPolicy,
+ Context, AssignOutput, ConvDecls, ConvOutputStatements, !Info) :-
ml_variable_type(!.Info, Var, VarType),
ml_gen_var(!.Info, Var, VarLval),
- ml_gen_box_or_unbox_lval(VarType, OrigType, VarLval,
+ ml_gen_box_or_unbox_lval(VarType, OrigType, BoxPolicy, VarLval,
mlds__var_name(ArgName, no), Context, no, 0, ArgLval,
ConvDecls, _ConvInputStatements, ConvOutputStatements, !Info),
% At this point we have an lval with the right type for *internal* use
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.94
diff -u -b -r1.94 ml_unify_gen.m
--- compiler/ml_unify_gen.m 28 Nov 2005 04:11:47 -0000 1.94
+++ compiler/ml_unify_gen.m 22 Feb 2006 09:30:52 -0000
@@ -363,7 +363,7 @@
% to the appropriate type.
ml_gen_static_const_arg(Arg, StaticArg, ArgRval, !Info),
ml_variable_type(!.Info, Arg, ArgType),
- ml_gen_box_or_unbox_rval(ArgType, VarType,
+ ml_gen_box_or_unbox_rval(ArgType, VarType, native_if_possible,
ArgRval, Rval, !Info)
;
unexpected(this_file, "ml_code_gen: no_tag: arity != 1")
@@ -1024,8 +1024,8 @@
% Otherwise, fall back on ml_gen_box_or_unbox_rval.
% XXX This might still generate stuff which is not legal
% in a static initializer!
- ml_gen_box_or_unbox_rval(ArgType, FieldType, ArgRval,
- FieldRval, !Info),
+ ml_gen_box_or_unbox_rval(ArgType, FieldType, native_if_possible,
+ ArgRval, FieldRval, !Info),
BoxConstDefns0 = []
),
ml_gen_box_or_unbox_const_rval_list(ArgTypes1, FieldTypes1, ArgRvals1,
@@ -1236,8 +1236,8 @@
not is_dummy_argument_type(ModuleInfo, ArgType),
not is_dummy_argument_type(ModuleInfo, ConsArgType)
->
- ml_gen_box_or_unbox_rval(ArgType, BoxedArgType, lval(Lval), Rval,
- !Info)
+ ml_gen_box_or_unbox_rval(ArgType, BoxedArgType, native_if_possible,
+ lval(Lval), Rval, !Info)
;
Rval = const(null(MLDS_Type))
),
@@ -1592,8 +1592,8 @@
LeftMode = top_in,
RightMode = top_out
->
- ml_gen_box_or_unbox_rval(FieldType, ArgType, lval(FieldLval),
- FieldRval, !Info),
+ ml_gen_box_or_unbox_rval(FieldType, ArgType, native_if_possible,
+ lval(FieldLval), FieldRval, !Info),
Statement = ml_gen_assign(ArgLval, FieldRval, Context),
!:Statements = [Statement | !.Statements]
;
@@ -1601,8 +1601,8 @@
LeftMode = top_out,
RightMode = top_in
->
- ml_gen_box_or_unbox_rval(ArgType, FieldType, lval(ArgLval), ArgRval,
- !Info),
+ ml_gen_box_or_unbox_rval(ArgType, FieldType, native_if_possible,
+ lval(ArgLval), ArgRval, !Info),
Statement = ml_gen_assign(FieldLval, ArgRval, Context),
!:Statements = [Statement | !.Statements]
;
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.124
diff -u -b -r1.124 module_qual.m
--- compiler/module_qual.m 22 Feb 2006 08:05:12 -0000 1.124
+++ compiler/module_qual.m 23 Feb 2006 03:49:26 -0000
@@ -1133,8 +1133,8 @@
mq_info::in, mq_info::out, io::di, io::uo) is det.
qualify_pragma_vars([], [], !Info, !IO).
-qualify_pragma_vars([pragma_var(Var, Name, Mode0) | PragmaVars0],
- [pragma_var(Var, Name, Mode) | PragmaVars], !Info, !IO) :-
+qualify_pragma_vars([pragma_var(Var, Name, Mode0, Box) | PragmaVars0],
+ [pragma_var(Var, Name, Mode, Box) | PragmaVars], !Info, !IO) :-
qualify_mode(Mode0, Mode, !Info, !IO),
qualify_pragma_vars(PragmaVars0, PragmaVars, !Info, !IO).
Index: compiler/opt_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/opt_util.m,v
retrieving revision 1.141
diff -u -b -r1.141 opt_util.m
--- compiler/opt_util.m 28 Nov 2005 04:11:49 -0000 1.141
+++ compiler/opt_util.m 22 Feb 2006 08:36:34 -0000
@@ -1329,7 +1329,7 @@
pragma_c_inputs_get_rvals([], []).
pragma_c_inputs_get_rvals([I | Inputs], [R | Rvals]) :-
- I = pragma_c_input(_Name, _VarType, _IsDummy, _OrigType, R, _),
+ I = pragma_c_input(_Name, _VarType, _IsDummy, _OrigType, R, _, _),
pragma_c_inputs_get_rvals(Inputs, Rvals).
% Extract the lvals from the pragma_c_output.
@@ -1339,7 +1339,7 @@
pragma_c_outputs_get_lvals([], []).
pragma_c_outputs_get_lvals([O | Outputs], [L | Lvals]) :-
- O = pragma_c_output(L, _VarType, _IsDummy, _OrigType, _Name, _),
+ O = pragma_c_output(L, _VarType, _IsDummy, _OrigType, _Name, _, _),
pragma_c_outputs_get_lvals(Outputs, Lvals).
% Determine all the rvals and lvals referenced by a list of instructions.
Index: compiler/options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.499
diff -u -b -r1.499 options.m
--- compiler/options.m 22 Feb 2006 08:05:14 -0000 1.499
+++ compiler/options.m 23 Feb 2006 03:49:26 -0000
@@ -385,6 +385,8 @@
% constant, can be done by casting them both to integers and
% comparing the integers for equality.
+ ; mutable_always_boxed
+
% Options for internal use only (setting these options to non-default
% values can result in programs that do not link, or programs that dump
% core)
@@ -1087,6 +1089,7 @@
trace_stack_layout - bool(no),
body_typeinfo_liveness - bool(no),
can_compare_constants_as_ints - bool(no),
+ mutable_always_boxed - bool(yes),
special_preds - bool(yes),
type_ctor_info - bool(yes),
type_ctor_layout - bool(yes),
@@ -1806,6 +1809,7 @@
long_option("trace-stack-layout", trace_stack_layout).
long_option("body-typeinfo-liveness", body_typeinfo_liveness).
long_option("can-compare-constants-as-ints", can_compare_constants_as_ints).
+long_option("mutable-always-boxed", mutable_always_boxed).
long_option("special-preds", special_preds).
long_option("type-ctor-info", type_ctor_info).
long_option("type-ctor-layout", type_ctor_layout).
@@ -3756,6 +3760,11 @@
% This is a developer only option.
% "--can-compare-constants-as-ints",
+% "(This option is not for general use.)",
+% For documentation, see the comment in the type declaration.
+
+ % This is a developer only option.
+% "--mutable-always-boxed",
% "(This option is not for general use.)",
% For documentation, see the comment in the type declaration.
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.289
diff -u -b -r1.289 polymorphism.m
--- compiler/polymorphism.m 21 Dec 2005 23:19:55 -0000 1.289
+++ compiler/polymorphism.m 22 Feb 2006 08:23:38 -0000
@@ -1126,7 +1126,7 @@
type_info_vars(_ModuleInfo, [], InitString) = InitString.
type_info_vars(ModuleInfo, [Arg | Args], InitString) = String :-
String0 = type_info_vars(ModuleInfo, Args, InitString),
- Arg = foreign_arg(_, MaybeNameMode, _),
+ MaybeNameMode = foreign_arg_maybe_name_mode(Arg),
(
MaybeNameMode = yes(ArgName0 - Mode),
( mode_is_output(ModuleInfo, Mode) ->
@@ -1609,10 +1609,10 @@
:- pred foreign_proc_add_typeclass_info(bool::in, mer_mode::in,
pragma_foreign_code_impl::in, tvarset::in, prog_constraint::in,
- maybe(pair(string, mer_mode))::out) is det.
+ pair(maybe(pair(string, mer_mode)), box_policy)::out) is det.
foreign_proc_add_typeclass_info(CanOptAwayUnnamed, Mode, Impl, TypeVarSet,
- Constraint, MaybeArgName) :-
+ Constraint, MaybeArgName - native_if_possible) :-
Constraint = constraint(Name0, Types),
mdbcomp__prim_data__sym_name_to_string(Name0, "__", Name),
prog_type__vars_list(Types, TypeVars),
@@ -1632,10 +1632,10 @@
:- pred foreign_proc_add_typeinfo(bool::in, mer_mode::in,
pragma_foreign_code_impl::in, tvarset::in, tvar::in,
- maybe(pair(string, mer_mode))::out) is det.
+ pair(maybe(pair(string, mer_mode)), box_policy)::out) is det.
foreign_proc_add_typeinfo(CanOptAwayUnnamed, Mode, Impl, TypeVarSet, TVar,
- MaybeArgName) :-
+ MaybeArgName - native_if_possible) :-
( varset__search_name(TypeVarSet, TVar, TypeVarName) ->
string__append("TypeInfo_for_", TypeVarName, C_VarName),
% If the variable name corresponding to the type_info isn't mentioned
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.88
diff -u -b -r1.88 pragma_c_gen.m
--- compiler/pragma_c_gen.m 28 Nov 2005 04:11:51 -0000 1.88
+++ compiler/pragma_c_gen.m 22 Feb 2006 10:00:08 -0000
@@ -1045,6 +1045,7 @@
% inlining/specialization
% (the actual type may be an instance
% of this type, if this type is polymorphic).
+ box_policy,
arg_info
).
@@ -1053,7 +1054,7 @@
make_c_arg_list([], [], []).
make_c_arg_list([Arg | ArgTail], [ArgInfo | ArgInfoTail], [CArg | CArgTail]) :-
- Arg = foreign_arg(Var, MaybeNameMode, Type),
+ Arg = foreign_arg(Var, MaybeNameMode, Type, BoxPolicy),
(
MaybeNameMode = yes(Name - _),
MaybeName = yes(Name)
@@ -1061,7 +1062,7 @@
MaybeNameMode = no,
MaybeName = no
),
- CArg = c_arg(Var, MaybeName, Type, ArgInfo),
+ CArg = c_arg(Var, MaybeName, Type, BoxPolicy, ArgInfo),
make_c_arg_list(ArgTail, ArgInfoTail, CArgTail).
make_c_arg_list([], [_ | _], _) :-
unexpected(this_file, "pragma_c_gen__make_c_arg_list length mismatch").
@@ -1090,7 +1091,7 @@
make_extra_c_arg_list_seq([], _, _, []).
make_extra_c_arg_list_seq([ExtraArg | ExtraArgs], ModuleInfo, LastReg,
[CArg | CArgs]) :-
- ExtraArg = foreign_arg(Var, MaybeNameMode, OrigType),
+ ExtraArg = foreign_arg(Var, MaybeNameMode, OrigType, BoxPolicy),
(
MaybeNameMode = yes(Name - Mode),
mode_to_arg_mode(ModuleInfo, Mode, OrigType, ArgMode)
@@ -1101,7 +1102,7 @@
NextReg = LastReg + 1,
% Extra args are always input.
ArgInfo = arg_info(NextReg, ArgMode),
- CArg = c_arg(Var, yes(Name), OrigType, ArgInfo),
+ CArg = c_arg(Var, yes(Name), OrigType, BoxPolicy, ArgInfo),
make_extra_c_arg_list_seq(ExtraArgs, ModuleInfo, NextReg, CArgs).
%---------------------------------------------------------------------------%
@@ -1110,7 +1111,7 @@
get_c_arg_list_vars([], []).
get_c_arg_list_vars([Arg | Args], [Var | Vars]) :-
- Arg = c_arg(Var, _, _, _),
+ Arg = c_arg(Var, _, _, _, _),
get_c_arg_list_vars(Args, Vars).
%---------------------------------------------------------------------------%
@@ -1123,7 +1124,7 @@
pragma_select_out_args([], []).
pragma_select_out_args([Arg | Rest], Out) :-
pragma_select_out_args(Rest, OutTail),
- Arg = c_arg(_, _, _, ArgInfo),
+ Arg = c_arg(_, _, _, _, ArgInfo),
ArgInfo = arg_info(_Loc, Mode),
( Mode = top_out ->
Out = [Arg | OutTail]
@@ -1139,7 +1140,7 @@
pragma_select_in_args([], []).
pragma_select_in_args([Arg | Rest], In) :-
pragma_select_in_args(Rest, InTail),
- Arg = c_arg(_, _, _, ArgInfo),
+ Arg = c_arg(_, _, _, _, ArgInfo),
ArgInfo = arg_info(_Loc, Mode),
( Mode = top_in ->
In = [Arg | InTail]
@@ -1194,11 +1195,17 @@
make_pragma_decls([], _, _, []).
make_pragma_decls([Arg | Args], Module, CanOptAwayUnnamedArgs, Decls) :-
make_pragma_decls(Args, Module, CanOptAwayUnnamedArgs, DeclsTail),
- Arg = c_arg(Var, MaybeArgName, OrigType, _ArgInfo),
+ Arg = c_arg(Var, MaybeArgName, OrigType, BoxPolicy, _ArgInfo),
MaybeName = var_should_be_passed(CanOptAwayUnnamedArgs, Var, MaybeArgName),
(
MaybeName = yes(Name),
- OrigTypeString = foreign__to_type_string(c, Module, OrigType),
+ (
+ BoxPolicy = native_if_possible,
+ OrigTypeString = foreign__to_type_string(c, Module, OrigType)
+ ;
+ BoxPolicy = always_boxed,
+ OrigTypeString = "MR_Word"
+ ),
Decl = pragma_c_arg_decl(OrigType, OrigTypeString, Name),
Decls = [Decl | DeclsTail]
;
@@ -1213,7 +1220,7 @@
find_dead_input_vars([], _, !DeadVars).
find_dead_input_vars([Arg | Args], PostDeaths, !DeadVars) :-
- Arg = c_arg(Var, _MaybeName, _Type, _ArgInfo),
+ Arg = c_arg(Var, _MaybeName, _Type, _BoxPolicy, _ArgInfo),
( set__member(Var, PostDeaths) ->
set__insert(!.DeadVars, Var, !:DeadVars)
;
@@ -1233,7 +1240,7 @@
get_pragma_input_vars([], [], _, empty, !CI).
get_pragma_input_vars([Arg | Args], Inputs, CanOptAwayUnnamedArgs, Code,
!CI) :-
- Arg = c_arg(Var, MaybeArgName, OrigType, _ArgInfo),
+ Arg = c_arg(Var, MaybeArgName, OrigType, BoxPolicy, _ArgInfo),
MaybeName = var_should_be_passed(CanOptAwayUnnamedArgs, Var, MaybeArgName),
(
MaybeName = yes(Name),
@@ -1247,7 +1254,7 @@
IsDummy = no
),
Input = pragma_c_input(Name, VarType, IsDummy, OrigType, Rval,
- MaybeForeign),
+ MaybeForeign, BoxPolicy),
get_pragma_input_vars(Args, Inputs1, CanOptAwayUnnamedArgs, RestCode,
!CI),
Inputs = [Input | Inputs1],
@@ -1294,7 +1301,7 @@
pragma_acquire_regs([], [], !CI).
pragma_acquire_regs([Arg | Args], [Reg | Regs], !CI) :-
- Arg = c_arg(Var, _, _, _),
+ Arg = c_arg(Var, _, _, _, _),
code_info__acquire_reg_for_var(Var, Reg, !CI),
pragma_acquire_regs(Args, Regs, !CI).
@@ -1313,7 +1320,7 @@
CanOptAwayUnnamedArgs, Outputs, !CI) :-
place_pragma_output_args_in_regs(Args, Regs, CanOptAwayUnnamedArgs,
OutputsTail, !CI),
- Arg = c_arg(Var, MaybeArgName, OrigType, _ArgInfo),
+ Arg = c_arg(Var, MaybeArgName, OrigType, BoxPolicy, _ArgInfo),
code_info__release_reg(Reg, !CI),
( code_info__variable_is_forward_live(!.CI, Var) ->
code_info__set_var_location(Var, Reg, !CI),
@@ -1330,7 +1337,7 @@
IsDummy = no
),
PragmaCOutput = pragma_c_output(Reg, VarType, IsDummy, OrigType,
- Name, MaybeForeign),
+ Name, MaybeForeign, BoxPolicy),
Outputs = [PragmaCOutput | OutputsTail]
;
MaybeName = no,
@@ -1355,7 +1362,7 @@
input_descs_from_arg_info(_, [], _, []).
input_descs_from_arg_info(CI, [Arg | Args], CanOptAwayUnnamedArgs, Inputs) :-
input_descs_from_arg_info(CI, Args, CanOptAwayUnnamedArgs, InputsTail),
- Arg = c_arg(Var, MaybeArgName, OrigType, ArgInfo),
+ Arg = c_arg(Var, MaybeArgName, OrigType, BoxPolicy, ArgInfo),
MaybeName = var_should_be_passed(CanOptAwayUnnamedArgs, Var, MaybeArgName),
(
MaybeName = yes(Name),
@@ -1370,7 +1377,7 @@
IsDummy = no
),
Input = pragma_c_input(Name, VarType, IsDummy, OrigType, lval(Reg),
- MaybeForeign),
+ MaybeForeign, BoxPolicy),
Inputs = [Input | InputsTail]
;
MaybeName = no,
@@ -1389,7 +1396,7 @@
output_descs_from_arg_info(_, [], _, []).
output_descs_from_arg_info(CI, [Arg | Args], CanOptAwayUnnamedArgs, Outputs) :-
output_descs_from_arg_info(CI, Args, CanOptAwayUnnamedArgs, OutputsTail),
- Arg = c_arg(Var, MaybeArgName, OrigType, ArgInfo),
+ Arg = c_arg(Var, MaybeArgName, OrigType, BoxPolicy, ArgInfo),
MaybeName = var_should_be_passed(CanOptAwayUnnamedArgs, Var, MaybeArgName),
(
MaybeName = yes(Name),
@@ -1404,7 +1411,7 @@
IsDummy = no
),
Output = pragma_c_output(Reg, VarType, IsDummy, OrigType, Name,
- MaybeForeign),
+ MaybeForeign, BoxPolicy),
Outputs = [Output | OutputsTail]
;
MaybeName = no,
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.152
diff -u -b -r1.152 prog_data.m
--- compiler/prog_data.m 22 Feb 2006 08:05:15 -0000 1.152
+++ compiler/prog_data.m 23 Feb 2006 03:49:27 -0000
@@ -697,10 +697,14 @@
; will_not_modify_trail.
:- type pragma_var
- ---> pragma_var(prog_var, string, mer_mode).
+ ---> pragma_var(prog_var, string, mer_mode, box_policy).
% variable, name, mode
% We explicitly store the name because we need the real
% name in code_gen.
+
+:- type box_policy
+ ---> native_if_possible
+ ; always_boxed.
% This type specifies the termination property of a procedure
% defined using pragma c_code or pragma foreign_proc.
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.97
diff -u -b -r1.97 prog_io_pragma.m
--- compiler/prog_io_pragma.m 22 Feb 2006 08:05:15 -0000 1.97
+++ compiler/prog_io_pragma.m 23 Feb 2006 03:49:27 -0000
@@ -1716,9 +1716,10 @@
( convert_mode(allow_constrained_inst_var, ModeTerm, Mode0) ->
constrain_inst_vars_in_mode(Mode0, Mode),
term__coerce_var(Var, ProgVar),
- P = (pragma_var(ProgVar, VarName, Mode)),
+ PragmaVar = pragma_var(ProgVar, VarName, Mode,
+ native_if_possible),
parse_pragma_c_code_varlist(VarSet, Vars, PragmaVars0, Error),
- PragmaVars = [P|PragmaVars0]
+ PragmaVars = [PragmaVar | PragmaVars0]
;
PragmaVars = [],
Error = yes("unknown mode in pragma c_code")
Index: compiler/prog_item.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_item.m,v
retrieving revision 1.3
diff -u -b -r1.3 prog_item.m
Index: compiler/prog_mutable.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_mutable.m,v
retrieving revision 1.6
diff -u -b -r1.6 prog_mutable.m
--- compiler/prog_mutable.m 23 Nov 2005 04:44:07 -0000 1.6
+++ compiler/prog_mutable.m 22 Feb 2006 13:58:43 -0000
@@ -19,6 +19,7 @@
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_item.
+
:- import_module string.
%-----------------------------------------------------------------------------%
@@ -48,14 +49,6 @@
%
:- func init_pred_decl(module_name, string) = item.
- % Create the foreign_decl for the mutable.
- %
-:- func get_global_foreign_decl(string) = item.
-
- % Create the foreign_code that defines the mutable.
- %
-:- func get_global_foreign_defn(string) = item.
-
:- func mutable_get_pred_sym_name(sym_name, string) = sym_name.
:- func mutable_set_pred_sym_name(sym_name, string) = sym_name.
@@ -69,9 +62,11 @@
:- implementation.
-:- import_module libs.globals.
:- import_module parse_tree.prog_foreign.
:- import_module parse_tree.prog_mode.
+:- import_module parse_tree.prog_type.
+:- import_module libs.compiler_util.
+
:- import_module list.
:- import_module std_util.
:- import_module varset.
@@ -126,13 +121,6 @@
no /* with_type */, no /* with_inst */, yes(det),
true /* condition */, purity_pure, Constraints).
- % Return the type io.state.
- % XXX Perhaps this should be in prog_type?
- %
-:- func io_state_type = mer_type.
-
-io_state_type = defined(qualified(unqualified("io"), "state"), [], star).
-
init_pred_decl(ModuleName, Name) = InitPredDecl :-
VarSet = varset__init,
InstVarSet = varset__init,
@@ -145,17 +133,6 @@
%-----------------------------------------------------------------------------%
-get_global_foreign_decl(TargetMutableName) =
- pragma(compiler(mutable_decl),
- foreign_decl(c, foreign_decl_is_exported,
- "extern MR_Word " ++ TargetMutableName ++ ";")).
-
-get_global_foreign_defn(TargetMutableName) =
- pragma(compiler(mutable_decl),
- foreign_code(c, "MR_Word " ++ TargetMutableName ++ ";")).
-
-%-----------------------------------------------------------------------------%
-
mutable_get_pred_sym_name(ModuleName, Name) =
qualified(ModuleName, "get_" ++ Name).
@@ -169,6 +146,12 @@
RawCVarName = "mutable_variable_" ++ Name,
QualifiedCVarName = qualified(ModuleName, RawCVarName),
MangledCVarName = sym_name_mangle(QualifiedCVarName).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "prog_mutable.m".
%-----------------------------------------------------------------------------%
:- end_module prog_mutable.
Index: compiler/prog_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_type.m,v
retrieving revision 1.15
diff -u -b -r1.15 prog_type.m
--- compiler/prog_type.m 28 Nov 2005 04:11:52 -0000 1.15
+++ compiler/prog_type.m 22 Feb 2006 09:56:46 -0000
@@ -279,6 +279,7 @@
:- func sample_typeclass_info_type = mer_type.
:- func comparison_result_type = mer_type.
:- func aditi_state_type = mer_type.
+:- func io_state_type = mer_type.
% Construct the types of type_infos and type_ctor_infos.
%
@@ -745,7 +746,8 @@
type_is_io_state(Type) :-
type_to_ctor_and_args(Type, TypeCtor, []),
- TypeCtor = qualified(unqualified("io"), "state") - 0.
+ mercury_std_lib_module_name("io", ModuleName),
+ TypeCtor = qualified(ModuleName, "state") - 0.
type_is_aditi_state(Type) :-
type_to_ctor_and_args(Type, TypeCtor, []),
@@ -852,6 +854,10 @@
aditi_state_type = defined(Name, [], star) :-
aditi_public_builtin_module(BuiltinModule),
Name = qualified(BuiltinModule, "state").
+
+io_state_type = defined(Name, [], star) :-
+ mercury_std_lib_module_name("io", Module),
+ Name = qualified(Module, "state").
%-----------------------------------------------------------------------------%
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.98
diff -u -b -r1.98 table_gen.m
--- compiler/table_gen.m 28 Nov 2005 04:11:55 -0000 1.98
+++ compiler/table_gen.m 22 Feb 2006 08:48:15 -0000
@@ -667,7 +667,8 @@
;
TablingViaExtraArgs = yes,
TableTipArg = foreign_arg(TableTipVar,
- yes(cur_table_node_name - in_mode), trie_node_type),
+ yes(cur_table_node_name - in_mode), trie_node_type,
+ native_if_possible),
MarkInactiveCode = "\tMR_" ++ MarkInactivePred ++
"(" ++ cur_table_node_name ++ ");\n",
MarkInactiveFailCode = "\tMR_" ++ MarkInactiveFailPred ++
@@ -952,7 +953,8 @@
(
TablingViaExtraArgs = yes,
TableTipArg = foreign_arg(TableTipVar,
- yes(cur_table_node_name - in_mode), trie_node_type),
+ yes(cur_table_node_name - in_mode), trie_node_type,
+ native_if_possible),
MarkAsFailedCode = "MR_" ++ MarkAsFailedPred ++
"(" ++ cur_table_node_name ++ ");",
table_generate_foreign_proc(MarkAsFailedPred, failure,
@@ -1030,7 +1032,8 @@
RecordVarName = memo_non_record_name,
RecordArg = foreign_arg(RecordVar,
- yes(RecordVarName - in_mode), memo_non_record_type),
+ yes(RecordVarName - in_mode), memo_non_record_type,
+ native_if_possible),
MarkIncompletePred = "table_memo_mark_as_incomplete",
MarkActivePred = "table_memo_mark_as_active_and_fail",
MarkCompletePred = "table_memo_mark_as_complete_and_fail",
@@ -1598,11 +1601,12 @@
PredTableVarName = pred_table_name,
PredTableArg = foreign_arg(PredTableVar,
- yes(PredTableVarName - in_mode), trie_node_type),
+ yes(PredTableVarName - in_mode), trie_node_type, native_if_possible),
GeneratorPredArg = foreign_arg(GeneratorPredVar,
- yes(generator_pred_name - in_mode), GeneratorPredType),
+ yes(generator_pred_name - in_mode), GeneratorPredType,
+ native_if_possible),
ConsumerArg = foreign_arg(ConsumerVar,
- yes(ConsumerVarName - out_mode), consumer_type),
+ yes(ConsumerVarName - out_mode), consumer_type, native_if_possible),
LookupDeclCodeStr =
"\tMR_TrieNode " ++ cur_table_node_name ++ ";\n" ++
@@ -1657,7 +1661,8 @@
AnswerBlockVar, ModuleInfo, Context, !VarTypes, !VarSet, _RestoreGoals,
RestoreInstMapDeltaSrc, RestoreArgs, RestoreCodeStr),
AnswerBlockArg = foreign_arg(AnswerBlockVar,
- yes(answer_block_name - in_mode), answer_block_type),
+ yes(answer_block_name - in_mode), answer_block_type,
+ native_if_possible),
RestoreAllPredName = "table_mmos_restore_answers",
table_generate_foreign_proc(RestoreAllPredName, det, tabling_c_attributes,
[AnswerBlockArg], RestoreArgs, "", "", RestoreCodeStr,
@@ -1688,7 +1693,7 @@
generate_save_input_vars_code([InputArg - Mode | InputArgModes], ModuleInfo,
Pos, [PickupArg | PickupArgs], SaveVarCode ++ SaveVarCodes,
PickupVarCode ++ PickupVarCodes) :-
- InputArg = foreign_arg(InputVar, MaybeArgNameMode, Type),
+ InputArg = foreign_arg(InputVar, MaybeArgNameMode, Type, _),
(
MaybeArgNameMode = yes(InputVarName - _InMode)
;
@@ -1697,7 +1702,8 @@
),
mode_get_insts(ModuleInfo, Mode, InitInst, _FinalInst),
PickupMode = (free -> InitInst),
- PickupArg = foreign_arg(InputVar, yes(InputVarName - PickupMode), Type),
+ PickupArg = foreign_arg(InputVar, yes(InputVarName - PickupMode), Type,
+ native_if_possible),
SaveVarCode = "\t\tMR_mmos_save_input_arg(" ++
int_to_string(Pos) ++ ", " ++ InputVarName ++ ");\n",
PickupVarCode = "\t\tMR_mmos_pickup_input_arg(" ++
@@ -1729,7 +1735,7 @@
PickupGeneratorCode = "\t\t" ++ generator_name ++
" = MR_mmos_new_generator;\n",
PickupGeneratorArg = foreign_arg(GeneratorVar,
- yes(generator_name - out_mode), generator_type),
+ yes(generator_name - out_mode), generator_type, native_if_possible),
table_generate_foreign_proc("table_mmos_pickup_inputs", det,
tabling_c_attributes, [PickupGeneratorArg], PickupForeignArgs,
"", PickupGeneratorCode, PickupVarCode, semipure_code,
@@ -1955,11 +1961,13 @@
TableTipVarName = table_tip_node_name,
StatusVarName = status_name,
PredTableArg = foreign_arg(PredTableVar,
- yes(PredTableVarName - in_mode), trie_node_type),
+ yes(PredTableVarName - in_mode), trie_node_type,
+ native_if_possible),
TableTipArg = foreign_arg(TableTipVar,
- yes(TableTipVarName - out_mode), trie_node_type),
+ yes(TableTipVarName - out_mode), trie_node_type,
+ native_if_possible),
StatusArg = foreign_arg(StatusVar,
- yes(StatusVarName - out_mode), StatusType),
+ yes(StatusVarName - out_mode), StatusType, native_if_possible),
MainPredCodeStr = "\tMR_" ++ SetupPred ++ "(" ++
cur_table_node_name ++ ", " ++ StatusVarName ++ ");\n",
(
@@ -2035,11 +2043,13 @@
RecordVarName = memo_non_record_name,
StatusVarName = status_name,
PredTableArg = foreign_arg(PredTableVar,
- yes(PredTableVarName - in_mode), trie_node_type),
+ yes(PredTableVarName - in_mode), trie_node_type, native_if_possible),
RecordArg = foreign_arg(RecordVar,
- yes(RecordVarName - out_mode), memo_non_record_type),
+ yes(RecordVarName - out_mode), memo_non_record_type,
+ native_if_possible),
StatusArg = foreign_arg(StatusVar,
- yes(StatusVarName - out_mode), memo_non_status_type),
+ yes(StatusVarName - out_mode), memo_non_status_type,
+ native_if_possible),
Args = [PredTableArg, RecordArg, StatusArg],
LookupDeclCodeStr =
"\tMR_TrieNode " ++ cur_table_node_name ++ ";\n" ++
@@ -2090,11 +2100,12 @@
SubgoalVarName = subgoal_name,
StatusVarName = status_name,
PredTableArg = foreign_arg(PredTableVar,
- yes(PredTableVarName - in_mode), trie_node_type),
+ yes(PredTableVarName - in_mode), trie_node_type,
+ native_if_possible),
SubgoalArg = foreign_arg(SubgoalVar,
- yes(SubgoalVarName - out_mode), subgoal_type),
+ yes(SubgoalVarName - out_mode), subgoal_type, native_if_possible),
StatusArg = foreign_arg(StatusVar,
- yes(StatusVarName - out_mode), mm_status_type),
+ yes(StatusVarName - out_mode), mm_status_type, native_if_possible),
Args = [PredTableArg, SubgoalArg, StatusArg],
LookupDeclCodeStr =
"\tMR_TrieNode " ++ cur_table_node_name ++ ";\n" ++
@@ -2230,7 +2241,8 @@
NextTableVar),
BindNextTableVar = ground_vars([NextTableVar]),
ArgName = arg_name(VarSeqNum),
- ForeignArg = foreign_arg(ArgVar, yes(ArgName - in_mode), Type),
+ ForeignArg = foreign_arg(ArgVar, yes(ArgName - in_mode), Type,
+ native_if_possible),
( TypeCat = type_cat_enum ->
( type_to_ctor_and_args(Type, TypeCtor, _) ->
module_info_get_type_table(ModuleInfo, TypeDefnTable),
@@ -2315,7 +2327,8 @@
TypeInfoArgName = "input_typeinfo" ++ int_to_string(VarSeqNum),
map__lookup(!.VarTypes, TypeInfoVar, TypeInfoType),
ForeignTypeInfoArg = foreign_arg(TypeInfoVar,
- yes(TypeInfoArgName - in_mode), TypeInfoType),
+ yes(TypeInfoArgName - in_mode), TypeInfoType,
+ native_if_possible),
ExtraArgs = [ForeignTypeInfoArg, ForeignArg],
CodeStr0 = "\tMR_" ++ LookupPredName ++ "(" ++
cur_table_node_name ++ ", " ++ TypeInfoArgName ++ ", " ++
@@ -2362,7 +2375,8 @@
(
TablingViaExtraArgs = yes,
TableArg = foreign_arg(TableTipVar,
- yes(cur_table_node_name - in_mode), trie_node_type),
+ yes(cur_table_node_name - in_mode), trie_node_type,
+ native_if_possible),
MarkAsSucceededCode = "MR_" ++ MarkAsSucceededPred ++
"(" ++ cur_table_node_name ++ ");",
table_generate_foreign_proc(MarkAsSucceededPred, det,
@@ -2393,9 +2407,9 @@
RecordName = memo_non_record_name,
AnswerTableName = "AnswerTableVar",
RecordArg = foreign_arg(RecordVar,
- yes(RecordName - in_mode), memo_non_record_type),
+ yes(RecordName - in_mode), memo_non_record_type, native_if_possible),
AnswerTableArg = foreign_arg(AnswerTableVar,
- yes(AnswerTableName - in_mode), trie_node_type),
+ yes(AnswerTableName - in_mode), trie_node_type, native_if_possible),
GetPredName = "table_memo_non_get_answer_table",
GetPredCode = "\tMR_" ++ GetPredName ++ "(" ++
RecordName ++ ", " ++ AnswerTableName ++ ");\n",
@@ -2480,7 +2494,7 @@
TablingViaExtraArgs = yes,
SubgoalName = subgoal_name,
Args = [foreign_arg(SubgoalVar, yes(SubgoalName - in_mode),
- subgoal_type)],
+ subgoal_type, native_if_possible)],
SuccName = "succeeded",
LookupDeclCodeStr =
"\tMR_TrieNode " ++ cur_table_node_name ++ ";\n" ++
@@ -2534,7 +2548,7 @@
(
TablingViaExtraArgs = yes,
TableArg = foreign_arg(BaseVar, yes(BaseVarName - in_mode),
- BaseVarType),
+ BaseVarType, native_if_possible),
Args = [TableArg],
SaveDeclCodeStr = "\tMR_AnswerBlock " ++ answer_block_name ++ ";\n",
CreateCodeStr = "\tMR_" ++ CreatePredName ++ "(" ++
@@ -2577,7 +2591,7 @@
!VarTypes, !VarSet, AnswerTableVar),
GeneratorName = generator_name,
GeneratorArg = foreign_arg(GeneratorVar, yes(GeneratorName - in_mode),
- generator_type),
+ generator_type, native_if_possible),
generate_table_lookup_goals(NumberedOutputVars,
"AnswerTableNode", Context, AnswerTableVar, _AnswerTableTipVar,
!VarTypes, !VarSet, !TableInfo, _LookupAnswerGoals, _Steps,
@@ -2658,7 +2672,8 @@
Args, PrefixGoals, CodeStr) :-
ModuleInfo = !.TableInfo ^ table_module_info,
Name = arg_name(Offset),
- ForeignArg = foreign_arg(Var, yes(Name - in_mode), Type),
+ ForeignArg = foreign_arg(Var, yes(Name - in_mode), Type,
+ native_if_possible),
( type_is_io_state(Type) ->
SavePredName = "table_save_io_state_answer",
generate_call(SavePredName, det, [TableVar, OffsetVar, Var],
@@ -2673,13 +2688,13 @@
% If we used ForeignArg instead of GenericForeignArg, then
% Var would be unboxed when assigned to Name, which we don't want.
GenericForeignArg = foreign_arg(Var, yes(Name - in_mode),
- dummy_type_var),
+ dummy_type_var, native_if_possible),
make_type_info_var(Type, Context, !VarTypes, !VarSet,
!TableInfo, TypeInfoVar, ExtraGoals),
TypeInfoName = "save_arg_typeinfo" ++ int_to_string(Offset),
map__lookup(!.VarTypes, TypeInfoVar, TypeInfoType),
TypeInfoForeignArg = foreign_arg(TypeInfoVar,
- yes(TypeInfoName - in_mode), TypeInfoType),
+ yes(TypeInfoName - in_mode), TypeInfoType, native_if_possible),
SavePredName = "table_save_any_answer",
generate_call(SavePredName, det,
[TypeInfoVar, TableVar, OffsetVar, Var],
@@ -2728,7 +2743,7 @@
TablingViaExtraArgs = yes,
BaseVarName = base_name,
Arg = foreign_arg(TipVar, yes(BaseVarName - in_mode),
- trie_node_type),
+ trie_node_type, native_if_possible),
Args = [Arg],
DeclCodeStr = "\tMR_AnswerBlock " ++ answer_block_name ++ ";\n",
ShortcutPredName = GetPredName ++ "_shortcut",
@@ -2785,7 +2800,7 @@
_RestoreGoals, RestoreInstMapDeltaSrc, RestoreArgs, RestoreCodeStr),
OutputVars = list__map(project_var, NumberedOutputVars),
Arg = foreign_arg(AnswerBlockVar, yes(answer_block_name - in_mode),
- answer_block_type),
+ answer_block_type, native_if_possible),
Args = [Arg],
ShortcutPredName = "table_memo_non_return_all_shortcut",
ShortcutStr = "\tMR_" ++ ShortcutPredName ++ "(" ++
@@ -2864,7 +2879,8 @@
(
TablingViaExtraArgs = yes,
Arg = foreign_arg(AnswerBlockVar,
- yes(answer_block_name - in_mode), answer_block_type),
+ yes(answer_block_name - in_mode), answer_block_type,
+ native_if_possible),
Args = [Arg],
ShortcutPredName = "table_mm_return_all_shortcut",
ShortcutStr = "\tMR_" ++ ShortcutPredName ++ "(" ++
@@ -2935,7 +2951,8 @@
;
unexpected(this_file, "gen_restore_call_for_type: no inst")
),
- Arg = foreign_arg(Var, yes(Name - (free -> Inst)), ArgType),
+ Arg = foreign_arg(Var, yes(Name - (free -> Inst)), ArgType,
+ native_if_possible),
CodeStr = "\tMR_" ++ RestorePredName ++ "(" ++ answer_block_name ++ ", "
++ int_to_string(Offset) ++ ", " ++ Name ++ ");\n",
generate_call(RestorePredName, det, [TableVar, OffsetVar, Var],
Index: compiler/unused_args.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.120
diff -u -b -r1.120 unused_args.m
--- compiler/unused_args.m 22 Feb 2006 00:32:14 -0000 1.120
+++ compiler/unused_args.m 22 Feb 2006 08:58:25 -0000
@@ -664,7 +664,7 @@
% in fixup_goal_expr: any variable considered unused here should be
% renamed apart in fixup_goal_expr.
ArgIsUsed = (pred(Arg::in, Var::out) is semidet :-
- Arg = foreign_arg(Var, MaybeNameAndMode, _),
+ Arg = foreign_arg(Var, MaybeNameAndMode, _, _),
MaybeNameAndMode = yes(_)
),
list__filter_map(ArgIsUsed, Args ++ ExtraArgs, UsedVars),
@@ -1525,7 +1525,7 @@
fixup_info::in, fixup_info::out, bool::in, bool::out) is det.
rename_apart_unused_foreign_arg(Arg0, Arg, !Subst, !Info, !Changed) :-
- Arg0 = foreign_arg(OldVar, MaybeName, OrigType),
+ Arg0 = foreign_arg(OldVar, MaybeName, OrigType, BoxPolicy),
(
MaybeName = yes(_),
Arg = Arg0
@@ -1546,7 +1546,7 @@
% It is possible for an unnamed input argument to occur more than once
% in the list of foreign_args.
svmap__set(OldVar, NewVar, !Subst),
- Arg = foreign_arg(NewVar, MaybeName, OrigType),
+ Arg = foreign_arg(NewVar, MaybeName, OrigType, BoxPolicy),
!:Changed = yes
).
cvs diff: Diffing compiler/notes
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.112
diff -u -b -r1.112 compiler_design.html
--- compiler/notes/compiler_design.html 2 Feb 2006 00:38:30 -0000 1.112
+++ compiler/notes/compiler_design.html 22 Feb 2006 06:24:53 -0000
@@ -275,13 +275,19 @@
<p>
The modules prog_out.m and mercury_to_mercury.m contain predicates
- for printing the parse tree. prog_util.m contains some utility
- predicates for manipulating the parse tree, prog_mode contains utility
- predicates for manipulating insts and modes, prog_type contains utility
- predicates for manipulating types, prog_type_subst contains predicates
- for performing substitutions on types, prog_foreign contains utility
- predicates for manipulating foreign code, prog_mutable contains utility
- predicates for manipulating mutable variables,
+ for printing the parse tree.
+ prog_util.m contains some utility predicates
+ for manipulating the parse tree,
+ prog_mode contains utility predicates
+ for manipulating insts and modes,
+ prog_type contains utility predicates
+ for manipulating types,
+ prog_type_subst contains predicates
+ for performing substitutions on types,
+ prog_foreign contains utility predicates
+ for manipulating foreign code,
+ prog_mutable contains utility predicates
+ for manipulating mutable variables,
while error_util.m contains predicates
for printing nicely formatting error messages.
cvs diff: Diffing debian
cvs diff: Diffing debian/patches
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/gator
cvs diff: Diffing extras/gator/generations
cvs diff: Diffing extras/gator/generations/1
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/solver_types
cvs diff: Diffing extras/solver_types/library
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/windows_installer_generator
cvs diff: Diffing extras/windows_installer_generator/sample
cvs diff: Diffing extras/windows_installer_generator/sample/images
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing slice
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.277
diff -u -b -r1.277 Mmakefile
--- tests/hard_coded/Mmakefile 4 Jan 2006 07:14:35 -0000 1.277
+++ tests/hard_coded/Mmakefile 22 Feb 2006 09:35:45 -0000
@@ -291,10 +291,12 @@
# Fact tables currently work only in the C grades.
# The foreign_type_assertion test is currently meaningful only in C grades.
+# Mutables work properly only in C grades.
ifeq "$(filter il% java%,$(GRADE))" ""
C_ONLY_PROGS= \
factt \
factt_sort_test \
+ float_gv \
foreign_type_assertion
else
C_ONLY_PROGS=
Index: tests/hard_coded/float_gv.exp
===================================================================
RCS file: tests/hard_coded/float_gv.exp
diff -N tests/hard_coded/float_gv.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/float_gv.exp 22 Feb 2006 10:20:17 -0000
@@ -0,0 +1,12 @@
+1.20000000000000
+1.20000000000000
+2.30000000000000
+2.30000000000000
+"abc"
+"abc"
+"def"
+"def"
+c(1, 2)
+c(1, 2)
+c(2, 3)
+c(2, 3)
Index: tests/hard_coded/float_gv.m
===================================================================
RCS file: tests/hard_coded/float_gv.m
diff -N tests/hard_coded/float_gv.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/float_gv.m 22 Feb 2006 10:20:02 -0000
@@ -0,0 +1,151 @@
+% vim: ft=mercury sw=4 ts=4 expandtab
+%
+% This regression test is an expanded version of the program files by Greg Duck
+% in a bug report on Feb 22 2006.
+
+:- module float_gv.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di,io::uo) is det.
+
+:- implementation.
+
+:- import_module float.
+
+:- type c ---> c(int, int).
+
+:- type coord.
+:- pragma foreign_type(c, coord, "coord *").
+
+:- pragma foreign_decl(c, "
+typedef struct {
+ int x, y;
+} coord;
+").
+
+:- func new_coord(int, int) = coord.
+
+:- func x(coord) = int.
+:- func y(coord) = int.
+
+:- pragma foreign_proc(c,
+ new_coord(X::in, Y::in) = (C::out),
+ [will_not_call_mercury, promise_pure],
+"
+ C = MR_GC_NEW(coord);
+ C->x = X;
+ C->y = Y;
+").
+
+:- pragma foreign_proc(c,
+ x(C::in) = (X::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = C->x;
+").
+
+:- pragma foreign_proc(c,
+ y(C::in) = (Y::out),
+ [will_not_call_mercury, promise_pure],
+"
+ Y = C->y;
+").
+
+:- mutable(gv1,float,0.0,ground,[untrailed]).
+:- mutable(gv2,float,2.3,ground,[untrailed]).
+:- mutable(gv3,string,"",ground,[untrailed]).
+:- mutable(gv4,string,"def",ground,[untrailed]).
+:- mutable(gv5,coord,new_coord(0, 0),ground,[untrailed]).
+:- mutable(gv6,coord,new_coord(2, 3),ground,[untrailed]).
+
+:- pragma promise_pure(main/2).
+main(!IO) :-
+ % Check whether we get back the same value as we set.
+ GV1Init = 1.2,
+ write(GV1Init,!IO),
+ nl(!IO),
+ impure set_gv1(GV1Init),
+ semipure get_gv1(GV1Final),
+ write(GV1Final,!IO),
+ nl(!IO),
+ ( GV1Init = GV1Final ->
+ true
+ ;
+ write_string("GV1 NOT SAME!\n",!IO)
+ ),
+
+ % Check whether we get back the same value as the initialization.
+ GV2Init = 2.3,
+ write(GV2Init,!IO),
+ nl(!IO),
+ semipure get_gv2(GV2Final),
+ write(GV2Final,!IO),
+ nl(!IO),
+ ( GV2Init = GV2Final ->
+ true
+ ;
+ write_string("GV2 NOT SAME!\n",!IO)
+ ),
+
+ % Check whether we get back the same value as we set.
+ GV3Init = "abc",
+ write(GV3Init,!IO),
+ nl(!IO),
+ impure set_gv3(GV3Init),
+ semipure get_gv3(GV3Final),
+ write(GV3Final,!IO),
+ nl(!IO),
+ ( GV3Init = GV3Final ->
+ true
+ ;
+ write_string("GV3 NOT SAME!\n",!IO)
+ ),
+
+ % Check whether we get back the same value as the initialization.
+ GV4Init = "def",
+ write(GV4Init,!IO),
+ nl(!IO),
+ semipure get_gv4(GV4Final),
+ write(GV4Final,!IO),
+ nl(!IO),
+ ( GV4Init = GV4Final ->
+ true
+ ;
+ write_string("GV4 NOT SAME!\n",!IO)
+ ),
+
+ % Check whether we get back the same value as we set.
+ GV5Init = new_coord(1, 2),
+ write(c(x(GV5Init), y(GV5Init)),!IO),
+ nl(!IO),
+ impure set_gv5(GV5Init),
+ semipure get_gv5(GV5Final),
+ write(c(x(GV5Final), y(GV5Final)),!IO),
+ nl(!IO),
+ (
+ x(GV5Init) = x(GV5Final),
+ y(GV5Init) = y(GV5Final)
+ ->
+ true
+ ;
+ write_string("GV5 NOT SAME!\n",!IO)
+ ),
+
+ % Check whether we get back the same value as the initialization.
+ GV6Init = new_coord(2, 3),
+ write(c(x(GV6Init), y(GV6Init)),!IO),
+ nl(!IO),
+ semipure get_gv6(GV6Final),
+ write(c(x(GV6Final), y(GV6Final)),!IO),
+ nl(!IO),
+ (
+ x(GV6Init) = x(GV6Final),
+ y(GV6Init) = y(GV6Final)
+ ->
+ true
+ ;
+ write_string("GV6 NOT SAME!\n",!IO)
+ ).
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
Index: tests/invalid/bad_mutable.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/bad_mutable.err_exp,v
retrieving revision 1.4
diff -u -b -r1.4 bad_mutable.err_exp
--- tests/invalid/bad_mutable.err_exp 30 Sep 2005 05:44:31 -0000 1.4
+++ tests/invalid/bad_mutable.err_exp 22 Feb 2006 11:30:27 -0000
@@ -9,5 +9,3 @@
bad_mutable.m:005: Error: `mutable' declaration in module interface.
bad_mutable.m:023: Error: multiple foreign_name attributes specified for the C
bad_mutable.m:023: backend.
-bad_mutable.m:023: Error: multiple foreign_name attributes specified for the C
-bad_mutable.m:023: backend.
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/trailing
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
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