[m-rev.] for review: fix a problem with mutables for non-MR_Word types
Zoltan Somogyi
zs at cs.mu.OZ.AU
Fri Feb 24 12:38:50 AEDT 2006
On 23-Feb-2006, Julien Fischer <juliensf at cs.mu.OZ.AU> wrote:
> Have you checked that this works correctly when the clauses for the
> access predicates are exported in the .opt files? If so, then that's
> fine.
It didn't, but I have fixed that. The updated log message and diff follow.
Zoltan.
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.
Add a foreign_proc attribute that asks for every arg to be kept boxed.
We can attach this to the mutable implementation foreign_procs we write
out to .opt files. This attribute is deliberately undocumented since
users should never use it.
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/prog_io_pragma.m:
Parse the new foreign_proc annotation.
compiler/simplify.m:
If a foreign_proc has the always_boxed annotation, attach this info
to each of its args. We do this here because simplify is guaranteed
to be executed before all the code that may inspect these arguments.
Since nothing ever deletes an always_boxed annotation of a foreign_proc
arg, the code that attaches the annotation is idempotent, so the fact
that the compiler executes simplify twice is not a problem.
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/hard_coded/sub-modules/non_word_mutable.{m,exp}:
tests/hard_coded/sub-modules/non_word_mutable.child.m:
A version of the float_gv test case in which the compiler-generated
get and set foreign_procs should end up in .opt files.
tests/hard_coded/sub-modules/Mmakefile:
tests/hard_coded/sub-modules/Mercury_options:
Enable the new test case, and make it execute with intermodule
optimization.
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.23
diff -u -b -r1.23 add_pragma.m
--- compiler/add_pragma.m 23 Feb 2006 09:36:47 -0000 1.23
+++ compiler/add_pragma.m 23 Feb 2006 09:37:48 -0000
@@ -1486,7 +1486,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)
@@ -1820,7 +1821,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).
%-----------------------------------------------------------------------------%
@@ -1831,7 +1832,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).
%---------------------------------------------------------------------------%
@@ -1839,12 +1840,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) :-
@@ -1976,7 +1978,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.124
diff -u -b -r1.124 goal_util.m
--- compiler/goal_util.m 23 Feb 2006 09:36:51 -0000 1.124
+++ compiler/goal_util.m 23 Feb 2006 09:37:48 -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.148
diff -u -b -r1.148 hlds_goal.m
--- compiler/hlds_goal.m 23 Feb 2006 09:36:52 -0000 1.148
+++ compiler/hlds_goal.m 23 Feb 2006 09:37:48 -0000
@@ -344,17 +344,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.
%-----------------------------------------------------------------------------%
%
@@ -1399,19 +1401,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.380
diff -u -b -r1.380 hlds_out.m
--- compiler/hlds_out.m 23 Feb 2006 09:36:52 -0000 1.380
+++ compiler/hlds_out.m 23 Feb 2006 09:37:49 -0000
@@ -1907,7 +1907,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),
@@ -1922,6 +1922,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/hlds_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.189
diff -u -b -r1.189 hlds_pred.m
--- compiler/hlds_pred.m 23 Feb 2006 09:36:53 -0000 1.189
+++ compiler/hlds_pred.m 23 Feb 2006 09:37:49 -0000
@@ -394,8 +394,8 @@
% Merge the information in rtti_varmaps A and B to produce C. Where
% information conflicts, use the information in B rather than A.
%
-:- pred rtti_varmaps_overlay(rtti_varmaps::in, rtti_varmaps::in,
- rtti_varmaps::out) is det.
+:- pred rtti_varmaps_overlay(rtti_varmaps::in,
+ rtti_varmaps::in, rtti_varmaps::out) is det.
%-----------------------------------------------------------------------------%
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.190
diff -u -b -r1.190 intermod.m
--- compiler/intermod.m 23 Feb 2006 09:36:53 -0000 1.190
+++ compiler/intermod.m 23 Feb 2006 09:37:49 -0000
@@ -1788,26 +1788,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.269
diff -u -b -r1.269 llds_out.m
--- compiler/llds_out.m 23 Feb 2006 09:36:54 -0000 1.269
+++ compiler/llds_out.m 23 Feb 2006 09:37:49 -0000
@@ -2253,7 +2253,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).
@@ -2265,7 +2266,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
;
@@ -2281,9 +2282,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
@@ -2323,6 +2331,7 @@
;
output_rval_as_type(Rval, word, !IO)
)
+ )
),
io__write_string(";\n", !IO).
@@ -2333,7 +2342,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).
@@ -2346,7 +2355,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
;
@@ -2362,9 +2371,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) ->
@@ -2398,6 +2414,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.26
diff -u -b -r1.26 make_hlds_passes.m
--- compiler/make_hlds_passes.m 23 Feb 2006 09:36:56 -0000 1.26
+++ compiler/make_hlds_passes.m 23 Feb 2006 22:07:37 -0000
@@ -44,6 +44,10 @@
module_info::out, qual_info::out, bool::out, bool::out, io::di, io::uo)
is det.
+/* ### In `add_item_clause(in, in, out, in, in, out, in, out, */
+/* ### di, uo)': */
+/* ### error: determinism declaration not satisfied. */
+/* ### Declared `det', inferred `semidet'. */
:- pred add_item_clause(item::in, import_status::in, import_status::out,
prog_context::in, module_info::in, module_info::out,
qual_info::in, qual_info::out, io::di, io::uo) is det.
@@ -97,6 +101,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 +282,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 +460,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 +479,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 +503,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 +548,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 +642,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 +656,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 +711,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 +722,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,18 +1151,62 @@
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),
InstVarset = varset.init,
Attrs0 = default_attributes(c),
- set_may_call_mercury(will_not_call_mercury, Attrs0, Attrs1),
+ globals.io_lookup_bool_option(mutable_always_boxed, AlwaysBoxed, !IO),
+ (
+ AlwaysBoxed = yes,
+ BoxPolicy = always_boxed
+ ;
+ AlwaysBoxed = no,
+ BoxPolicy = native_if_possible
+ ),
+ set_box_policy(BoxPolicy, Attrs0, Attrs1),
+
+ set_may_call_mercury(will_not_call_mercury, Attrs1, Attrs2),
( mutable_var_thread_safe(MutAttrs) = thread_safe ->
- set_thread_safe(thread_safe, Attrs1, Attrs)
+ set_thread_safe(thread_safe, Attrs2, Attrs)
+ ;
+ Attrs = Attrs2
+ ),
+
+ 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)
;
- Attrs = Attrs1
+ % The error message was printed in pass 2.
+ true
),
+
%
% Add the `:- initialise' declaration and clause for the
% initialise predicate.
@@ -1187,21 +1220,12 @@
[InitTerm], purity_impure) - Context),
add_item_clause(InitClause, !Status, Context, !ModuleInfo, !QualInfo,
!IO),
- 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)
- ),
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 +1256,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,
@@ -1248,7 +1274,7 @@
% another pair of foreign_procs.
( mutable_var_attach_to_io_state(MutAttrs) = yes ->
- set_tabled_for_io(tabled_for_io, Attrs0, PureIntAttrs0),
+ set_tabled_for_io(tabled_for_io, Attrs1, PureIntAttrs0),
set_purity(purity_pure, PureIntAttrs0, PureIntAttrs),
varset.new_named_var(ProgVarSet0, "IO0", IO0, ProgVarSet1),
varset.new_named_var(ProgVarSet1, "IO", IO, ProgVarSet),
@@ -1256,9 +1282,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 +1297,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 +1315,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.281
diff -u -b -r1.281 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 23 Feb 2006 09:36:57 -0000 1.281
+++ compiler/mercury_to_mercury.m 23 Feb 2006 21:59:32 -0000
@@ -3054,7 +3054,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)
@@ -3162,7 +3162,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),
@@ -3488,12 +3488,10 @@
%-----------------------------------------------------------------------------%
:- pred mercury_format_pragma_foreign_attributes(
- pragma_foreign_proc_attributes::in,
- U::di, U::uo) is det <= output(U).
+ pragma_foreign_proc_attributes::in, U::di, U::uo) is det <= output(U).
mercury_format_pragma_foreign_attributes(Attributes, !U) :-
- % This is one case where it is a bad idea to use field
- % accessors.
+ % This is one case where it is a bad idea to use field accessors.
add_string("[", !U),
add_list(attributes_to_strings(Attributes), ", ", add_string, !U),
add_string("]", !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.62
diff -u -b -r1.62 ml_call_gen.m
--- compiler/ml_call_gen.m 23 Feb 2006 09:36:57 -0000 1.62
+++ compiler/ml_call_gen.m 23 Feb 2006 09:37:50 -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
@@ -310,7 +310,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]
@@ -660,8 +660,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,
@@ -669,8 +669,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,
@@ -716,9 +717,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(_, _)
@@ -780,14 +786,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 = [],
@@ -851,17 +857,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.169
diff -u -b -r1.169 ml_code_gen.m
--- compiler/ml_code_gen.m 23 Feb 2006 09:36:58 -0000 1.169
+++ compiler/ml_code_gen.m 23 Feb 2006 09:37:50 -0000
@@ -1397,9 +1397,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
@@ -2382,12 +2382,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),
@@ -2484,7 +2490,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).
@@ -2496,9 +2502,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),
@@ -2525,7 +2537,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 - _),
@@ -2534,6 +2546,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.
@@ -2542,12 +2561,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)))
),
@@ -2805,14 +2824,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,
@@ -2861,13 +2886,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.
@@ -2875,11 +2900,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),
@@ -2890,8 +2915,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
@@ -2983,7 +3008,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),
@@ -2995,8 +3020,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
@@ -3050,8 +3075,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),
@@ -3059,7 +3085,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,
@@ -3070,15 +3096,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.95
diff -u -b -r1.95 ml_unify_gen.m
--- compiler/ml_unify_gen.m 23 Feb 2006 09:36:58 -0000 1.95
+++ compiler/ml_unify_gen.m 23 Feb 2006 09:37:51 -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.125
diff -u -b -r1.125 module_qual.m
--- compiler/module_qual.m 23 Feb 2006 09:37:00 -0000 1.125
+++ compiler/module_qual.m 23 Feb 2006 09:37:51 -0000
@@ -1123,8 +1123,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.290
diff -u -b -r1.290 polymorphism.m
--- compiler/polymorphism.m 23 Feb 2006 09:37:01 -0000 1.290
+++ compiler/polymorphism.m 23 Feb 2006 09:37:51 -0000
@@ -1115,7 +1115,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) ->
@@ -1598,10 +1598,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),
@@ -1621,10 +1621,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.153
diff -u -b -r1.153 prog_data.m
--- compiler/prog_data.m 23 Feb 2006 09:37:02 -0000 1.153
+++ compiler/prog_data.m 23 Feb 2006 10:03:00 -0000
@@ -620,6 +620,7 @@
may_throw_exception.
:- func ordinary_despite_detism(pragma_foreign_proc_attributes) = bool.
:- func may_modify_trail(pragma_foreign_proc_attributes) = may_modify_trail.
+:- func box_policy(pragma_foreign_proc_attributes) = box_policy.
:- func extra_attributes(pragma_foreign_proc_attributes)
= pragma_foreign_proc_extra_attributes.
@@ -663,6 +664,10 @@
pragma_foreign_proc_attributes::in,
pragma_foreign_proc_attributes::out) is det.
+:- pred set_box_policy(box_policy::in,
+ pragma_foreign_proc_attributes::in,
+ pragma_foreign_proc_attributes::out) is det.
+
:- pred add_extra_attribute(pragma_foreign_proc_extra_attribute::in,
pragma_foreign_proc_attributes::in,
pragma_foreign_proc_attributes::out) is det.
@@ -697,11 +702,15 @@
; 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.
%
@@ -1385,6 +1394,7 @@
legacy_purity_behaviour :: bool,
ordinary_despite_detism :: bool,
may_modify_trail :: may_modify_trail,
+ box_policy :: box_policy,
extra_attributes ::
list(pragma_foreign_proc_extra_attribute)
).
@@ -1392,7 +1402,8 @@
default_attributes(Language) =
attributes(Language, may_call_mercury, not_thread_safe,
not_tabled_for_io, purity_impure, depends_on_mercury_calls,
- default_exception_behaviour, no, no, may_modify_trail, []).
+ default_exception_behaviour, no, no, may_modify_trail,
+ native_if_possible, []).
set_may_call_mercury(MayCallMercury, Attrs0, Attrs) :-
Attrs = Attrs0 ^ may_call_mercury := MayCallMercury.
@@ -1414,6 +1425,8 @@
Attrs = Attrs0 ^ ordinary_despite_detism := OrdinaryDespiteDetism.
set_may_modify_trail(MayModifyTrail, Attrs0, Attrs) :-
Attrs = Attrs0 ^ may_modify_trail := MayModifyTrail.
+set_box_policy(BoxPolicyStr, Attrs0, Attrs) :-
+ Attrs = Attrs0 ^ box_policy := BoxPolicyStr.
attributes_to_strings(Attrs) = StringList :-
% We ignore Lang because it isn't an attribute that you can put
@@ -1421,7 +1434,7 @@
% is at the start of the pragma.
Attrs = attributes(_Lang, MayCallMercury, ThreadSafe, TabledForIO,
Purity, Terminates, Exceptions, _LegacyBehaviour,
- OrdinaryDespiteDetism, MayModifyTrail, ExtraAttributes),
+ OrdinaryDespiteDetism, MayModifyTrail, BoxPolicy, ExtraAttributes),
(
MayCallMercury = may_call_mercury,
MayCallMercuryStr = "may_call_mercury"
@@ -1493,10 +1506,17 @@
MayModifyTrail = will_not_modify_trail,
MayModifyTrailStrList = ["will_not_modify_trail"]
),
+ (
+ BoxPolicy = native_if_possible,
+ BoxPolicyStr = []
+ ;
+ BoxPolicy = always_boxed,
+ BoxPolicyStr = ["always_boxed"]
+ ),
StringList = [MayCallMercuryStr, ThreadSafeStr, TabledForIOStr |
PurityStrList] ++ TerminatesStrList ++ ExceptionsStrList ++
OrdinaryDespiteDetismStrList ++ MayModifyTrailStrList ++
- list__map(extra_attribute_to_string, ExtraAttributes).
+ BoxPolicyStr ++ list__map(extra_attribute_to_string, ExtraAttributes).
add_extra_attribute(NewAttribute, Attributes0,
Attributes0 ^ extra_attributes :=
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.98
diff -u -b -r1.98 prog_io_pragma.m
--- compiler/prog_io_pragma.m 23 Feb 2006 09:37:02 -0000 1.98
+++ compiler/prog_io_pragma.m 23 Feb 2006 16:04:22 -0000
@@ -1294,7 +1294,8 @@
; terminates(terminates)
; will_not_throw_exception
; ordinary_despite_detism
- ; may_modify_trail(may_modify_trail).
+ ; may_modify_trail(may_modify_trail)
+ ; box_policy(box_policy).
:- pred parse_pragma_foreign_proc_attributes_term(foreign_language::in,
string::in, term::in, maybe1(pragma_foreign_proc_attributes)::out)
@@ -1332,7 +1333,8 @@
terminates(depends_on_mercury_calls) - terminates(terminates),
terminates(depends_on_mercury_calls) - terminates(does_not_terminate),
may_modify_trail(may_modify_trail) -
- may_modify_trail(will_not_modify_trail)
+ may_modify_trail(will_not_modify_trail),
+ box_policy(native_if_possible) - box_policy(always_boxed)
],
(
parse_pragma_foreign_proc_attributes_term0(Term, AttrList)
@@ -1381,6 +1383,8 @@
set_ordinary_despite_detism(yes, !Attrs).
process_attribute(may_modify_trail(TrailMod), !Attrs) :-
set_may_modify_trail(TrailMod, !Attrs).
+process_attribute(box_policy(BoxPolicy), !Attrs) :-
+ set_box_policy(BoxPolicy, !Attrs).
% Aliasing is currently ignored in the main branch compiler.
%
@@ -1453,6 +1457,8 @@
Flag = ordinary_despite_detism
; parse_may_modify_trail(Term, TrailMod) ->
Flag = may_modify_trail(TrailMod)
+ ; parse_box_policy(Term, BoxPolicy) ->
+ Flag = box_policy(BoxPolicy)
;
fail
).
@@ -1484,6 +1490,13 @@
parse_may_modify_trail(term.functor(term.atom("will_not_modify_trail"), [], _),
will_not_modify_trail).
+:- pred parse_box_policy(term::in, box_policy::out) is semidet.
+
+parse_box_policy(term.functor(term.atom("native_if_possible"), [], _),
+ native_if_possible).
+parse_box_policy(term.functor(term.atom("always_boxed"), [], _),
+ always_boxed).
+
:- pred parse_tabled_for_io(term::in, tabled_for_io::out) is semidet.
parse_tabled_for_io(term__functor(term__atom(Str), [], _), TabledForIo) :-
@@ -1607,9 +1620,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.4
diff -u -b -r1.4 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.16
diff -u -b -r1.16 prog_type.m
--- compiler/prog_type.m 23 Feb 2006 09:37:03 -0000 1.16
+++ compiler/prog_type.m 23 Feb 2006 09:37:52 -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.
%
@@ -734,7 +735,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, []),
@@ -841,6 +843,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/simplify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.166
diff -u -b -r1.166 simplify.m
--- compiler/simplify.m 23 Feb 2006 09:37:09 -0000 1.166
+++ compiler/simplify.m 23 Feb 2006 10:08:03 -0000
@@ -1185,23 +1185,39 @@
).
simplify_goal_2(Goal0, Goal, GoalInfo, GoalInfo, !Info, !IO) :-
- Goal0 = foreign_proc(_, PredId, ProcId, Args, ExtraArgs, _),
+ Goal0 = foreign_proc(Attributes, PredId, ProcId, Args0, ExtraArgs0, Impl),
+ BoxPolicy = box_policy(Attributes),
+ (
+ BoxPolicy = native_if_possible,
+ Args = Args0,
+ ExtraArgs = ExtraArgs0,
+ Goal1 = Goal0
+ ;
+ BoxPolicy = always_boxed,
+ Args = list.map(make_arg_always_boxed, Args0),
+ ExtraArgs = list.map(make_arg_always_boxed, ExtraArgs0),
+ Goal1 = foreign_proc(Attributes, PredId, ProcId, Args, ExtraArgs, Impl)
+ ),
(
simplify_do_calls(!.Info),
goal_info_is_pure(GoalInfo),
ExtraArgs = []
->
ArgVars = list__map(foreign_arg_var, Args),
- common__optimise_call(PredId, ProcId, ArgVars, GoalInfo, Goal0, Goal,
+ common__optimise_call(PredId, ProcId, ArgVars, GoalInfo, Goal1, Goal,
!Info)
;
- Goal = Goal0
+ Goal = Goal1
).
simplify_goal_2(shorthand(_), _, _, _, _, _, _, _) :-
% These should have been expanded out by now.
unexpected(this_file, "goal_2: unexpected shorthand").
+:- func make_arg_always_boxed(foreign_arg) = foreign_arg.
+
+make_arg_always_boxed(Arg) = Arg ^ arg_box_policy := always_boxed.
+
%-----------------------------------------------------------------------------%
:- pred inequality_goal(prog_var::in, prog_var::in, prog_var::in, string::in,
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.99
diff -u -b -r1.99 table_gen.m
--- compiler/table_gen.m 23 Feb 2006 09:37:09 -0000 1.99
+++ compiler/table_gen.m 23 Feb 2006 09:37:53 -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,
@@ -1942,11 +1948,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",
(
@@ -2022,11 +2030,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" ++
@@ -2077,11 +2087,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" ++
@@ -2217,7 +2228,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),
@@ -2302,7 +2314,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 ++ ", " ++
@@ -2349,7 +2362,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,
@@ -2380,9 +2394,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",
@@ -2467,7 +2481,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" ++
@@ -2521,7 +2535,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 ++ "(" ++
@@ -2564,7 +2578,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,
@@ -2645,7 +2659,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],
@@ -2660,13 +2675,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],
@@ -2715,7 +2730,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",
@@ -2772,7 +2787,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 ++ "(" ++
@@ -2851,7 +2866,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 ++ "(" ++
@@ -2922,7 +2938,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.121
diff -u -b -r1.121 unused_args.m
--- compiler/unused_args.m 23 Feb 2006 09:37:11 -0000 1.121
+++ compiler/unused_args.m 23 Feb 2006 09:37:53 -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),
@@ -1524,7 +1524,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
@@ -1545,7 +1545,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.113
diff -u -b -r1.113 compiler_design.html
--- compiler/notes/compiler_design.html 23 Feb 2006 09:37:20 -0000 1.113
+++ compiler/notes/compiler_design.html 23 Feb 2006 09:37:54 -0000
@@ -267,13 +267,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
Index: tests/hard_coded/sub-modules/Mercury.options
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/sub-modules/Mercury.options,v
retrieving revision 1.1
diff -u -b -r1.1 Mercury.options
--- tests/hard_coded/sub-modules/Mercury.options 17 Aug 2002 13:52:16 -0000 1.1
+++ tests/hard_coded/sub-modules/Mercury.options 23 Feb 2006 21:09:13 -0000
@@ -1,4 +1,4 @@
MCFLAGS-nested_intermod = --intermodule-optimization
MCFLAGS-nested_intermod_main = --intermodule-optimization
-
+MCFLAGS-non_word_mutable = --intermodule-optimization
Index: tests/hard_coded/sub-modules/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/sub-modules/Mmakefile,v
retrieving revision 1.13
diff -u -b -r1.13 Mmakefile
--- tests/hard_coded/sub-modules/Mmakefile 29 Sep 2005 06:33:16 -0000 1.13
+++ tests/hard_coded/sub-modules/Mmakefile 23 Feb 2006 16:32:12 -0000
@@ -17,19 +17,20 @@
SUB_MODULE_PROGS= \
accessibility \
accessibility2 \
+ class \
deeply_nested \
- use_submodule \
- parent \
- parent2 \
+ finalise_parent \
+ initialise_parent \
+ mutable_parent \
nested \
nested2 \
nested3 \
- class \
nested_intermod_main \
- initialise_parent \
+ non_word_mutable \
+ parent \
+ parent2 \
ts \
- mutable_parent \
- finalise_parent
+ use_submodule
# We currently don't do any testing in grade java on this directory.
ifneq "$(findstring java,$(GRADE))" ""
Index: tests/hard_coded/sub-modules/non_word_mutable.child.m
===================================================================
RCS file: tests/hard_coded/sub-modules/non_word_mutable.child.m
diff -N tests/hard_coded/sub-modules/non_word_mutable.child.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/sub-modules/non_word_mutable.child.m 23 Feb 2006 21:08:55 -0000
@@ -0,0 +1,56 @@
+% 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 non_word_mutable.child.
+
+:- interface.
+
+:- impure pred exported_set_gv1(float::in) is det.
+:- semipure pred exported_get_gv1(float::out) is det.
+:- impure pred exported_set_gv2(float::in) is det.
+:- semipure pred exported_get_gv2(float::out) is det.
+:- impure pred exported_set_gv3(string::in) is det.
+:- semipure pred exported_get_gv3(string::out) is det.
+:- impure pred exported_set_gv4(string::in) is det.
+:- semipure pred exported_get_gv4(string::out) is det.
+:- impure pred exported_set_gv5(coord::in) is det.
+:- semipure pred exported_get_gv5(coord::out) is det.
+:- impure pred exported_set_gv6(coord::in) is det.
+:- semipure pred exported_get_gv6(coord::out) is det.
+
+:- implementation.
+
+:- 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 inline(exported_set_gv1/1).
+:- pragma inline(exported_get_gv1/1).
+:- pragma inline(exported_set_gv2/1).
+:- pragma inline(exported_get_gv2/1).
+:- pragma inline(exported_set_gv3/1).
+:- pragma inline(exported_get_gv3/1).
+:- pragma inline(exported_set_gv4/1).
+:- pragma inline(exported_get_gv4/1).
+:- pragma inline(exported_set_gv5/1).
+:- pragma inline(exported_get_gv5/1).
+:- pragma inline(exported_set_gv6/1).
+:- pragma inline(exported_get_gv6/1).
+
+exported_set_gv1(X) :- impure set_gv1(X).
+exported_get_gv1(X) :- semipure get_gv1(X).
+exported_set_gv2(X) :- impure set_gv2(X).
+exported_get_gv2(X) :- semipure get_gv2(X).
+exported_set_gv3(X) :- impure set_gv3(X).
+exported_get_gv3(X) :- semipure get_gv3(X).
+exported_set_gv4(X) :- impure set_gv4(X).
+exported_get_gv4(X) :- semipure get_gv4(X).
+exported_set_gv5(X) :- impure set_gv5(X).
+exported_get_gv5(X) :- semipure get_gv5(X).
+exported_set_gv6(X) :- impure set_gv6(X).
+exported_get_gv6(X) :- semipure get_gv6(X).
Index: tests/hard_coded/sub-modules/non_word_mutable.exp
===================================================================
RCS file: tests/hard_coded/sub-modules/non_word_mutable.exp
diff -N tests/hard_coded/sub-modules/non_word_mutable.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/sub-modules/non_word_mutable.exp 23 Feb 2006 16:32:35 -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/sub-modules/non_word_mutable.m
===================================================================
RCS file: tests/hard_coded/sub-modules/non_word_mutable.m
diff -N tests/hard_coded/sub-modules/non_word_mutable.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/sub-modules/non_word_mutable.m 23 Feb 2006 16:26:04 -0000
@@ -0,0 +1,147 @@
+% 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 non_word_mutable.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di,io::uo) is det.
+
+:- implementation.
+
+:- include_module non_word_mutable.child.
+
+:- import_module non_word_mutable.child.
+:- 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.
+
+:- 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;
+").
+
+:- func x(coord) = int.
+:- func y(coord) = int.
+
+:- 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;
+").
+
+:- 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 exported_set_gv1(GV1Init),
+ semipure exported_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 exported_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 exported_set_gv3(GV3Init),
+ semipure exported_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 exported_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 exported_set_gv5(GV5Init),
+ semipure exported_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 exported_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/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