for review: nondet pragma C codes (part 2 of 2)
Zoltan Somogyi
zs at cs.mu.oz.au
Fri Jan 9 13:56:30 AEDT 1998
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.70
diff -u -u -r1.70 mercury_compile.m
--- mercury_compile.m 1998/01/06 23:50:54 1.70
+++ mercury_compile.m 1998/01/08 03:02:37
@@ -515,8 +515,6 @@
)
).
-
-
:- pred mercury_compile__maybe_write_optfile(bool::in, module_info::in,
module_info::out, io__state::di, io__state::uo) is det.
@@ -567,7 +565,6 @@
{ HLDS = HLDS0 }
).
-
:- pred mercury_compile__output_trans_opt_file(module_info,
io__state, io__state).
:- mode mercury_compile__output_trans_opt_file(in, di, uo) is det.
@@ -583,7 +580,6 @@
trans_opt__write_optfile(HLDS28).
-
:- pred mercury_compile__frontend_pass_2(module_info, module_info,
bool, io__state, io__state).
% :- mode mercury_compile__frontend_pass_2(di, uo, out, di, uo) is det.
@@ -977,7 +973,6 @@
{ ModuleInfo = ModuleInfo5 }
).
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -1167,7 +1162,7 @@
process_all_nonimported_procs(
update_proc_error(simplify__proc(Simplify)),
HLDS0, HLDS),
- maybe_write_string(Verbose, "% done\n"),
+ maybe_write_string(Verbose, "% done.\n"),
maybe_report_stats(Stats).
%-----------------------------------------------------------------------------%
@@ -1469,7 +1464,6 @@
{ generate_arg_info(HLDS0, Args, HLDS) },
maybe_write_string(Verbose, " done.\n"),
maybe_report_stats(Stats).
-
:- pred mercury_compile__maybe_saved_vars(module_info, bool, bool,
module_info, io__state, io__state).
Index: compiler/mercury_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_c.m,v
retrieving revision 1.31
diff -u -u -r1.31 mercury_to_c.m
--- mercury_to_c.m 1997/12/22 09:55:58 1.31
+++ mercury_to_c.m 1998/01/04 11:17:31
@@ -674,13 +674,17 @@
c_gen_goal_2(unify(_A, _B, _, Unification, _), Indent, CGenInfo0, CGenInfo) -->
c_gen_unification(Unification, Indent, CGenInfo0, CGenInfo).
-c_gen_goal_2(pragma_c_code(C_Code, _, _, _, _, ArgNames, _, _), _, _, _) -->
+c_gen_goal_2(pragma_c_code(_, _, _, _, ArgNames, _, PragmaCode), _, _, _) -->
{ sorry(4) },
{ get_pragma_c_var_names(ArgNames, Names) },
io__write_string("$pragma(c_code, ["),
c_gen_string_list(Names),
io__write_string("], """),
- io__write_string(C_Code),
+ ( { PragmaCode = ordinary(C_Code, _) } ->
+ io__write_string(C_Code)
+ ;
+ { error("cannot translate nondet pragma code to C") }
+ ),
io__write_string(""" )").
:- pred c_gen_string_list(list(string), io__state, io__state).
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.124
diff -u -u -r1.124 mercury_to_mercury.m
--- mercury_to_mercury.m 1997/12/22 09:56:00 1.124
+++ mercury_to_mercury.m 1998/01/06 07:49:35
@@ -59,9 +59,8 @@
:- mode mercury_output_pragma_decl(in, in, in, in, di, uo) is det.
:- pred mercury_output_pragma_c_code(may_call_mercury, sym_name, pred_or_func,
- list(pragma_var), maybe(pair(list(string))),
- varset, string, io__state, io__state).
-:- mode mercury_output_pragma_c_code(in, in, in, in, in, in, in, di, uo) is det.
+ list(pragma_var), varset, pragma_code, io__state, io__state).
+:- mode mercury_output_pragma_c_code(in, in, in, in, in, in, di, uo) is det.
:- pred mercury_output_pragma_unused_args(pred_or_func, sym_name,
int, proc_id, list(int), io__state, io__state) is det.
@@ -286,14 +285,9 @@
mercury_output_pragma_c_body_code(Code)
;
{ Pragma = c_code(MayCallMercury, Pred, PredOrFunc, Vars,
- VarSet, C_CodeString) },
+ VarSet, PragmaCode) },
mercury_output_pragma_c_code(MayCallMercury, Pred, PredOrFunc,
- Vars, no, VarSet, C_CodeString)
- ;
- { Pragma = c_code(MayCallMercury, Pred, PredOrFunc, Vars,
- SavedVars, LabelNames, VarSet, C_CodeString) },
- mercury_output_pragma_c_code(MayCallMercury, Pred, PredOrFunc,
- Vars, yes(SavedVars - LabelNames), VarSet, C_CodeString)
+ Vars, VarSet, PragmaCode)
;
{ Pragma = export(Pred, PredOrFunc, ModeList, C_Function) },
mercury_output_pragma_export(Pred, PredOrFunc, ModeList,
@@ -1813,7 +1807,7 @@
% Output the given pragma c_code declaration
mercury_output_pragma_c_code(MayCallMercury, PredName, PredOrFunc, Vars0,
- MaybeExtraInfo, VarSet, C_CodeString) -->
+ VarSet, PragmaCode) -->
io__write_string(":- pragma c_code("),
mercury_output_sym_name(PredName),
{
@@ -1848,15 +1842,33 @@
io__write_string(", will_not_call_mercury, ")
),
(
- { MaybeExtraInfo = no }
+ { PragmaCode = ordinary(C_Code, _) },
+ term_io__quote_string(C_Code)
;
- { MaybeExtraInfo = yes(SavedVars - LabelNames) },
- mercury_output_c_ident_list(SavedVars),
- io__write_string(", "),
- mercury_output_c_ident_list(LabelNames),
- io__write_string(", ")
+ { PragmaCode = nondet(Fields, _, First, _,
+ Later, _, Treat, Shared, _) },
+ io__write_string("local_vars("),
+ term_io__quote_string(Fields),
+ io__write_string("), "),
+ io__write_string("first_code("),
+ term_io__quote_string(First),
+ io__write_string("), "),
+ io__write_string("retry_code("),
+ term_io__quote_string(Later),
+ io__write_string("), "),
+ (
+ { Treat = share },
+ io__write_string("shared_code(")
+ ;
+ { Treat = duplicate },
+ io__write_string("duplicated_code(")
+ ;
+ { Treat = automatic },
+ io__write_string("common_code(")
+ ),
+ term_io__quote_string(Shared),
+ io__write_string(")")
),
- term_io__quote_string(C_CodeString),
io__write_string(").\n").
:- pred mercury_output_c_ident_list(list(string), io__state, io__state).
Index: compiler/middle_rec.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/middle_rec.m,v
retrieving revision 1.67
diff -u -u -r1.67 middle_rec.m
--- middle_rec.m 1997/12/05 15:47:36 1.67
+++ middle_rec.m 1998/01/06 08:19:30
@@ -387,7 +387,7 @@
middle_rec__find_used_registers_lval(Lval, Used0, Used1),
middle_rec__find_used_registers_rval(Rval, Used1, Used).
middle_rec__find_used_registers_instr(call(_, _, _, _), Used, Used).
-middle_rec__find_used_registers_instr(mkframe(_, _, _), Used, Used).
+middle_rec__find_used_registers_instr(mkframe(_, _, _, _), Used, Used).
middle_rec__find_used_registers_instr(modframe(_), Used, Used).
middle_rec__find_used_registers_instr(label(_), Used, Used).
middle_rec__find_used_registers_instr(goto(_), Used, Used).
@@ -414,10 +414,29 @@
middle_rec__find_used_registers_rval(Rval, Used0, Used).
middle_rec__find_used_registers_instr(incr_sp(_, _), Used, Used).
middle_rec__find_used_registers_instr(decr_sp(_), Used, Used).
-middle_rec__find_used_registers_instr(pragma_c(_, Ins, _, Outs, _),
+middle_rec__find_used_registers_instr(pragma_c(_, Components, _, _),
Used0, Used) :-
- insert_pragma_c_input_registers(Ins, Used0, Used1),
- insert_pragma_c_output_registers(Outs, Used1, Used).
+ middle_rec__find_used_registers_components(Components, Used0, Used).
+
+:- pred middle_rec__find_used_registers_components(list(pragma_c_component),
+ set(int), set(int)).
+:- mode middle_rec__find_used_registers_components(in, di, uo) is det.
+
+middle_rec__find_used_registers_components([], Used, Used).
+middle_rec__find_used_registers_components([Comp | Comps], Used0, Used) :-
+ middle_rec__find_used_registers_component(Comp, Used0, Used1),
+ middle_rec__find_used_registers_components(Comps, Used1, Used).
+
+:- pred middle_rec__find_used_registers_component(pragma_c_component,
+ set(int), set(int)).
+:- mode middle_rec__find_used_registers_component(in, di, uo) is det.
+
+middle_rec__find_used_registers_component(pragma_c_inputs(In), Used0, Used) :-
+ insert_pragma_c_input_registers(In, Used0, Used).
+middle_rec__find_used_registers_component(pragma_c_outputs(Out), Used0, Used) :-
+ insert_pragma_c_output_registers(Out, Used0, Used).
+middle_rec__find_used_registers_component(pragma_c_user_code(_, _), Used, Used).
+middle_rec__find_used_registers_component(pragma_c_raw_code(_), Used, Used).
:- pred middle_rec__find_used_registers_lvals(list(lval), set(int), set(int)).
:- mode middle_rec__find_used_registers_lvals(in, di, uo) is det.
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.103
diff -u -u -r1.103 mode_util.m
--- mode_util.m 1998/01/05 07:26:16 1.103
+++ mode_util.m 1998/01/08 03:02:38
@@ -1154,8 +1154,8 @@
recompute_instmap_delta_unify(Uni, UniMode0, UniMode,
GoalInfo, InstMap, InstMapDelta).
-recompute_instmap_delta_2(_, pragma_c_code(A, B, PredId, ProcId, Args, F, G,
- H), _, pragma_c_code(A, B, PredId, ProcId, Args, F, G, H),
+recompute_instmap_delta_2(_, pragma_c_code(A, PredId, ProcId, Args, E, F,
+ G), _, pragma_c_code(A, PredId, ProcId, Args, E, F, G),
InstMap, InstMapDelta) -->
recompute_instmap_delta_call(PredId, ProcId,
Args, InstMap, InstMapDelta).
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.213
diff -u -u -r1.213 modes.m
--- modes.m 1998/01/05 07:26:19 1.213
+++ modes.m 1998/01/08 03:02:39
@@ -973,8 +973,8 @@
% to modecheck a pragma_c_code, we just modecheck the proc for
% which it is the goal.
-modecheck_goal_expr(pragma_c_code(IsRecursive, C_Code, PredId, _ProcId0, Args0,
- ArgNameMap, OrigArgTypes, ExtraPragmaInfo), GoalInfo, Goal) -->
+modecheck_goal_expr(pragma_c_code(IsRecursive, PredId, _ProcId0, Args0,
+ ArgNameMap, OrigArgTypes, PragmaCode), GoalInfo, Goal) -->
mode_checkpoint(enter, "pragma_c_code"),
mode_info_set_call_context(call(PredId)),
@@ -985,10 +985,10 @@
ProcId, Args, ExtraGoals),
=(ModeInfo),
- { Pragma = pragma_c_code(IsRecursive, C_Code, PredId, ProcId, Args0,
- ArgNameMap, OrigArgTypes, ExtraPragmaInfo) },
+ { Pragma = pragma_c_code(IsRecursive, PredId, ProcId, Args0,
+ ArgNameMap, OrigArgTypes, PragmaCode) },
{ handle_extra_goals(Pragma, ExtraGoals, GoalInfo, Args0, Args,
- InstMap0, ModeInfo, Goal) },
+ InstMap0, ModeInfo, Goal) },
mode_info_unset_call_context,
mode_checkpoint(exit, "pragma_c_code").
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.27
diff -u -u -r1.27 module_qual.m
--- module_qual.m 1997/12/22 09:56:07 1.27
+++ module_qual.m 1998/01/02 04:50:02
@@ -635,13 +635,8 @@
qualify_pragma(c_header_code(Code), c_header_code(Code), Info, Info) --> [].
qualify_pragma(c_code(Code), c_code(Code), Info, Info) --> [].
qualify_pragma(c_code(Rec, SymName, PredOrFunc, PragmaVars0, Varset, CCode),
- c_code(Rec, SymName, PredOrFunc, PragmaVars, Varset, CCode),
+ c_code(Rec, SymName, PredOrFunc, PragmaVars, Varset, CCode),
Info0, Info) -->
- qualify_pragma_vars(PragmaVars0, PragmaVars, Info0, Info).
-qualify_pragma(c_code(Rec, SymName, PredOrFunc, PragmaVars0,
- SavedVars, LabelCount, Varset, CCode),
- c_code(Rec, SymName, PredOrFunc, PragmaVars,
- SavedVars, LabelCount, Varset, CCode), Info0, Info) -->
qualify_pragma_vars(PragmaVars0, PragmaVars, Info0, Info).
qualify_pragma(memo(A, B), memo(A, B), Info, Info) --> [].
qualify_pragma(inline(A, B), inline(A, B), Info, Info) --> [].
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.47
diff -u -u -r1.47 modules.m
--- modules.m 1998/01/06 23:50:58 1.47
+++ modules.m 1998/01/08 03:06:27
@@ -821,7 +821,7 @@
io__write_list(OrdStream, DepsOrdering, "\n\n",
write_module_scc(OrdStream)),
io__close_output(OrdStream),
- maybe_write_string(Verbose, "% done\n")
+ maybe_write_string(Verbose, "% done.\n")
;
{ string__append_list(["can't open file `",
OrdFileName, "' for output."], OrdMessage) },
@@ -965,7 +965,7 @@
( { DepResult = ok(DepStream) } ->
generate_dep_file(Module, DepsMap, DepStream),
io__close_output(DepStream),
- maybe_write_string(Verbose, "% done\n")
+ maybe_write_string(Verbose, "% done.\n")
;
{ string__append_list(["can't open file `", DepFileName,
"' for output."], DepMessage) },
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_debug.m,v
retrieving revision 1.77
diff -u -u -r1.77 opt_debug.m
--- opt_debug.m 1997/12/22 06:58:31 1.77
+++ opt_debug.m 1998/01/06 08:16:49
@@ -296,7 +296,7 @@
opt_debug__dump_code_addr(Proc, P_str),
opt_debug__dump_code_addr(Ret, R_str),
string__append_list(["call(", P_str, ", ", R_str, ")"], Str).
-opt_debug__dump_vninstr(vn_mkframe(_, _, _), "mkframe").
+opt_debug__dump_vninstr(vn_mkframe(_, _, _, _), "mkframe").
opt_debug__dump_vninstr(vn_label(Label), Str) :-
opt_debug__dump_label(Label, L_str),
string__append_list(["label(", L_str, ")"], Str).
@@ -828,11 +828,17 @@
opt_debug__dump_code_addr(Proc, P_str),
opt_debug__dump_code_addr(Ret, R_str),
string__append_list(["call(", P_str, ", ", R_str, ", ...)"], Str).
-opt_debug__dump_instr(mkframe(Name, Size, Redoip), Str) :-
+opt_debug__dump_instr(mkframe(Name, Size, MaybePragma, Redoip), Str) :-
string__int_to_string(Size, S_str),
+ ( MaybePragma = yes(pragma_struct(StructName, StructFields, _)) ->
+ string__append_list(["yes(", StructName, ", ",
+ StructFields, ")"], P_str)
+ ;
+ P_str = "no"
+ ),
opt_debug__dump_code_addr(Redoip, R_str),
- string__append_list(["mkframe(", Name, ", ", S_str, ", ", R_str, ")"],
- Str).
+ string__append_list(["mkframe(", Name, ", ", S_str, ", ",
+ P_str, ", ", R_str, ")"], Str).
opt_debug__dump_instr(modframe(Redoip), Str) :-
opt_debug__dump_code_addr(Redoip, R_str),
string__append_list(["modframe(", R_str, ")"], Str).
@@ -890,8 +896,26 @@
string__int_to_string(Size, S_str),
string__append_list(["decr_sp(", S_str, ")"], Str).
% XXX should probably give more info than this
-opt_debug__dump_instr(pragma_c(_, _, Code, _, _), Str) :-
- string__append_list(["pragma_c(", Code, ")"], Str).
+opt_debug__dump_instr(pragma_c(_, Comps, _, _), Str) :-
+ opt_debug__dump_components(Comps, C_str),
+ string__append_list(["pragma_c(", C_str, ")"], Str).
+
+:- pred opt_debug__dump_components(list(pragma_c_component), string).
+:- mode opt_debug__dump_components(in, out) is det.
+
+opt_debug__dump_components([], "").
+opt_debug__dump_components([Comp | Comps], Str) :-
+ opt_debug__dump_component(Comp, Str1),
+ opt_debug__dump_components(Comps, Str2),
+ string__append(Str1, Str2, Str).
+
+:- pred opt_debug__dump_component(pragma_c_component, string).
+:- mode opt_debug__dump_component(in, out) is det.
+
+opt_debug__dump_component(pragma_c_inputs(_), "").
+opt_debug__dump_component(pragma_c_outputs(_), "").
+opt_debug__dump_component(pragma_c_user_code(_, Code), Code).
+opt_debug__dump_component(pragma_c_raw_code(Code), Code).
opt_debug__dump_fullinstr(Uinstr - Comment, Str) :-
opt_debug__dump_instr(Uinstr, U_str),
Index: compiler/opt_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_util.m,v
retrieving revision 1.86
diff -u -u -r1.86 opt_util.m
--- opt_util.m 1997/12/19 03:07:48 1.86
+++ opt_util.m 1998/01/06 08:23:49
@@ -414,7 +414,7 @@
list__reverse(RevSkip, Skip),
Rest = Instrs
;
- Uinstr = mkframe(_, _, _)
+ Uinstr = mkframe(_, _, _, _)
->
fail
;
@@ -789,7 +789,7 @@
Uinstr0 = call(_, _, _, _),
Need = no
;
- Uinstr0 = mkframe(_, _, _),
+ Uinstr0 = mkframe(_, _, _, _),
Need = no
;
Uinstr0 = modframe(_),
@@ -889,7 +889,7 @@
Uinstr0 = decr_sp(_),
Need = no
;
- Uinstr0 = pragma_c(_, _, _, _, _),
+ Uinstr0 = pragma_c(_, _, _, _),
Need = no
).
@@ -972,7 +972,7 @@
opt_util__can_instr_branch_away(block(_, _, _), yes).
opt_util__can_instr_branch_away(assign(_, _), no).
opt_util__can_instr_branch_away(call(_, _, _, _), yes).
-opt_util__can_instr_branch_away(mkframe(_, _, _), no).
+opt_util__can_instr_branch_away(mkframe(_, _, _, _), no).
opt_util__can_instr_branch_away(modframe(_), no).
opt_util__can_instr_branch_away(label(_), no).
opt_util__can_instr_branch_away(goto(_), yes).
@@ -989,7 +989,15 @@
opt_util__can_instr_branch_away(discard_tickets_to(_), no).
opt_util__can_instr_branch_away(incr_sp(_, _), no).
opt_util__can_instr_branch_away(decr_sp(_), no).
-opt_util__can_instr_branch_away(pragma_c(_, _, _, _, _), no).
+opt_util__can_instr_branch_away(pragma_c(_, Components, _, _), BranchAway) :-
+ (
+ list__member(Component, Components),
+ Component = pragma_c_raw_code(_)
+ ->
+ BranchAway = yes
+ ;
+ BranchAway = no
+ ).
opt_util__can_instr_fall_through(comment(_), yes).
opt_util__can_instr_fall_through(livevals(_), yes).
@@ -997,7 +1005,7 @@
opt_util__can_block_fall_through(Instrs, FallThrough).
opt_util__can_instr_fall_through(assign(_, _), yes).
opt_util__can_instr_fall_through(call(_, _, _, _), no).
-opt_util__can_instr_fall_through(mkframe(_, _, _), yes).
+opt_util__can_instr_fall_through(mkframe(_, _, _, _), yes).
opt_util__can_instr_fall_through(modframe(_), yes).
opt_util__can_instr_fall_through(label(_), yes).
opt_util__can_instr_fall_through(goto(_), no).
@@ -1014,7 +1022,7 @@
opt_util__can_instr_fall_through(discard_tickets_to(_), yes).
opt_util__can_instr_fall_through(incr_sp(_, _), yes).
opt_util__can_instr_fall_through(decr_sp(_), yes).
-opt_util__can_instr_fall_through(pragma_c(_, _, _, _, _), yes).
+opt_util__can_instr_fall_through(pragma_c(_, _, _, _), yes).
% Check whether an instruction sequence can possibly fall through
% to the next instruction without using its label.
@@ -1038,7 +1046,7 @@
opt_util__can_use_livevals(block(_, _, _), no).
opt_util__can_use_livevals(assign(_, _), no).
opt_util__can_use_livevals(call(_, _, _, _), yes).
-opt_util__can_use_livevals(mkframe(_, _, _), no).
+opt_util__can_use_livevals(mkframe(_, _, _, _), no).
opt_util__can_use_livevals(modframe(_), no).
opt_util__can_use_livevals(label(_), no).
opt_util__can_use_livevals(goto(_), yes).
@@ -1055,7 +1063,7 @@
opt_util__can_use_livevals(discard_tickets_to(_), no).
opt_util__can_use_livevals(incr_sp(_, _), no).
opt_util__can_use_livevals(decr_sp(_), no).
-opt_util__can_use_livevals(pragma_c(_, _, _, _, _), no).
+opt_util__can_use_livevals(pragma_c(_, _, _, _), no).
% determine all the labels and code_addresses that are referenced by Instr
@@ -1096,7 +1104,7 @@
opt_util__instr_list_labels(Instrs, Labels, CodeAddrs).
opt_util__instr_labels_2(assign(_,_), [], []).
opt_util__instr_labels_2(call(Target, Ret, _, _), [], [Target, Ret]).
-opt_util__instr_labels_2(mkframe(_, _, Addr), [], [Addr]).
+opt_util__instr_labels_2(mkframe(_, _, _, Addr), [], [Addr]).
opt_util__instr_labels_2(modframe(Addr), [], [Addr]).
opt_util__instr_labels_2(label(_), [], []).
opt_util__instr_labels_2(goto(Addr), [], [Addr]).
@@ -1113,7 +1121,12 @@
opt_util__instr_labels_2(discard_tickets_to(_), [], []).
opt_util__instr_labels_2(incr_sp(_, _), [], []).
opt_util__instr_labels_2(decr_sp(_), [], []).
-opt_util__instr_labels_2(pragma_c(_, _, _, _, _), [], []).
+opt_util__instr_labels_2(pragma_c(_, _, _, MaybeLabel), Labels, []) :-
+ ( MaybeLabel = yes(Label) ->
+ Labels = [Label]
+ ;
+ Labels = []
+ ).
:- pred opt_util__instr_rvals_and_lvals(instr, list(rval), list(lval)).
:- mode opt_util__instr_rvals_and_lvals(in, out, out) is det.
@@ -1126,7 +1139,7 @@
opt_util__instr_list_rvals_and_lvals(Instrs, Labels, CodeAddrs).
opt_util__instr_rvals_and_lvals(assign(Lval,Rval), [Rval], [Lval]).
opt_util__instr_rvals_and_lvals(call(_, _, _, _), [], []).
-opt_util__instr_rvals_and_lvals(mkframe(_, _, _), [], []).
+opt_util__instr_rvals_and_lvals(mkframe(_, _, _, _), [], []).
opt_util__instr_rvals_and_lvals(modframe(_), [], []).
opt_util__instr_rvals_and_lvals(label(_), [], []).
opt_util__instr_rvals_and_lvals(goto(_), [], []).
@@ -1143,9 +1156,38 @@
opt_util__instr_rvals_and_lvals(discard_tickets_to(Rval), [Rval], []).
opt_util__instr_rvals_and_lvals(incr_sp(_, _), [], []).
opt_util__instr_rvals_and_lvals(decr_sp(_), [], []).
-opt_util__instr_rvals_and_lvals(pragma_c(_, In, _, Out, _), Rvals, Lvals) :-
- pragma_c_inputs_get_rvals(In, Rvals),
- pragma_c_outputs_get_lvals(Out, Lvals).
+opt_util__instr_rvals_and_lvals(pragma_c(_, Components, _, _), Rvals, Lvals) :-
+ pragma_c_components_get_rvals_and_lvals(Components, Rvals, Lvals).
+
+ % extract the rvals and lvals from the pragma_c_components
+:- pred pragma_c_components_get_rvals_and_lvals(list(pragma_c_component),
+ list(rval), list(lval)).
+:- mode pragma_c_components_get_rvals_and_lvals(in, out, out) is det.
+
+pragma_c_components_get_rvals_and_lvals([], [], []).
+pragma_c_components_get_rvals_and_lvals([Comp | Comps], Rvals, Lvals) :-
+ pragma_c_components_get_rvals_and_lvals(Comps, Rvals1, Lvals1),
+ pragma_c_component_get_rvals_and_lvals(Comp,
+ Rvals1, Rvals, Lvals1, Lvals).
+
+ % extract the rvals and lvals from the pragma_c_component
+ % and add them to the list.
+:- pred pragma_c_component_get_rvals_and_lvals(pragma_c_component,
+ list(rval), list(rval), list(lval), list(lval)).
+:- mode pragma_c_component_get_rvals_and_lvals(in, in, out, in, out) is det.
+
+pragma_c_component_get_rvals_and_lvals(pragma_c_inputs(Inputs),
+ Rvals0, Rvals, Lvals, Lvals) :-
+ pragma_c_inputs_get_rvals(Inputs, Rvals1),
+ list__append(Rvals1, Rvals0, Rvals).
+pragma_c_component_get_rvals_and_lvals(pragma_c_outputs(Outputs),
+ Rvals, Rvals, Lvals0, Lvals) :-
+ pragma_c_outputs_get_lvals(Outputs, Lvals1),
+ list__append(Lvals1, Lvals0, Lvals).
+pragma_c_component_get_rvals_and_lvals(pragma_c_user_code(_, _),
+ Rvals, Rvals, Lvals, Lvals).
+pragma_c_component_get_rvals_and_lvals(pragma_c_raw_code(_),
+ Rvals, Rvals, Lvals, Lvals).
% extract the rvals from the pragma_c_input
:- pred pragma_c_inputs_get_rvals(list(pragma_c_input), list(rval)).
@@ -1216,7 +1258,7 @@
opt_util__count_temps_lval(Lval, R0, R1, F0, F1),
opt_util__count_temps_rval(Rval, R1, R, F1, F).
opt_util__count_temps_instr(call(_, _, _, _), R, R, F, F).
-opt_util__count_temps_instr(mkframe(_, _, _), R, R, F, F).
+opt_util__count_temps_instr(mkframe(_, _, _, _), R, R, F, F).
opt_util__count_temps_instr(modframe(_), R, R, F, F).
opt_util__count_temps_instr(label(_), R, R, F, F).
opt_util__count_temps_instr(goto(_), R, R, F, F).
@@ -1243,7 +1285,7 @@
opt_util__count_temps_rval(Rval, R0, R, F0, F).
opt_util__count_temps_instr(incr_sp(_, _), R, R, F, F).
opt_util__count_temps_instr(decr_sp(_), R, R, F, F).
-opt_util__count_temps_instr(pragma_c(_, _, _, _, _), R, R, F, F).
+opt_util__count_temps_instr(pragma_c(_, _, _, _), R, R, F, F).
:- pred opt_util__count_temps_lval(lval, int, int, int, int).
:- mode opt_util__count_temps_lval(in, in, out, in, out) is det.
@@ -1350,6 +1392,8 @@
opt_util__touches_nondet_ctrl_lval(Lval, Touch)
; Uinstr = restore_hp(Rval) ->
opt_util__touches_nondet_ctrl_rval(Rval, Touch)
+ ; Uinstr = pragma_c(_, Components, _, _) ->
+ opt_util__touches_nondet_ctrl_components(Components, Touch)
;
Touch = yes
).
@@ -1404,6 +1448,24 @@
opt_util__touches_nondet_ctrl_mem_ref(framevar_ref(_), no).
opt_util__touches_nondet_ctrl_mem_ref(heap_ref(Rval, _, _), Touch) :-
opt_util__touches_nondet_ctrl_rval(Rval, Touch).
+
+:- pred opt_util__touches_nondet_ctrl_components(list(pragma_c_component),
+ bool).
+:- mode opt_util__touches_nondet_ctrl_components(in, out) is det.
+
+opt_util__touches_nondet_ctrl_components([], no).
+opt_util__touches_nondet_ctrl_components([C | Cs], Touch) :-
+ opt_util__touches_nondet_ctrl_component(C, Touch1),
+ opt_util__touches_nondet_ctrl_components(Cs, Touch2),
+ bool__or(Touch1, Touch2, Touch).
+
+:- pred opt_util__touches_nondet_ctrl_component(pragma_c_component, bool).
+:- mode opt_util__touches_nondet_ctrl_component(in, out) is det.
+
+opt_util__touches_nondet_ctrl_component(pragma_c_inputs(_), no).
+opt_util__touches_nondet_ctrl_component(pragma_c_outputs(_), no).
+opt_util__touches_nondet_ctrl_component(pragma_c_raw_code(_), no).
+opt_util__touches_nondet_ctrl_component(pragma_c_user_code(_, _), yes).
%-----------------------------------------------------------------------------%
Index: compiler/peephole.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/peephole.m,v
retrieving revision 1.70
diff -u -u -r1.70 peephole.m
--- peephole.m 1997/12/22 06:58:35 1.70
+++ peephole.m 1998/01/01 06:18:34
@@ -140,13 +140,15 @@
% These two patterns are mutually exclusive because if_val is not
% straigh-line code.
-peephole__match(mkframe(Name, Slots, Redoip1), Comment, Instrs0, Instrs) :-
+peephole__match(mkframe(Name, Slots, Pragma, Redoip1), Comment,
+ Instrs0, Instrs) :-
(
opt_util__next_modframe(Instrs0, [], Redoip2, Skipped, Rest),
opt_util__touches_nondet_ctrl(Skipped, no)
->
list__append(Skipped, Rest, Instrs1),
- Instrs = [mkframe(Name, Slots, Redoip2) - Comment | Instrs1]
+ Instrs = [mkframe(Name, Slots, Pragma, Redoip2) - Comment
+ | Instrs1]
;
opt_util__skip_comments_livevals(Instrs0, Instrs1),
Instrs1 = [Instr1 | Instrs2],
@@ -157,7 +159,7 @@
->
Instrs = [
if_val(Test, do_redo) - Comment2,
- mkframe(Name, Slots, do_fail) - Comment
+ mkframe(Name, Slots, Pragma, do_fail) - Comment
| Instrs2
]
;
@@ -168,14 +170,16 @@
->
Instrs = [
if_val(Test, do_redo) - Comment2,
- mkframe(Name, Slots, Redoip1) - Comment
+ mkframe(Name, Slots, Pragma, Redoip1)
+ - Comment
| Instrs2
]
;
Target = do_redo
->
Instrs = [
- mkframe(Name, Slots, Redoip1) - Comment,
+ mkframe(Name, Slots, Pragma, Redoip1)
+ - Comment,
if_val(Test, Redoip1) - Comment2
| Instrs2
]
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.121
diff -u -u -r1.121 polymorphism.m
--- polymorphism.m 1998/01/02 00:10:44 1.121
+++ polymorphism.m 1998/01/02 06:52:11
@@ -749,8 +749,8 @@
polymorphism__process_goal(B0, B),
polymorphism__process_goal(C0, C).
-polymorphism__process_goal_expr(pragma_c_code(IsRecursive, C_Code, PredId,
- ProcId, ArgVars0, ArgNames0, OrigArgTypes0, ExtraInfo),
+polymorphism__process_goal_expr(pragma_c_code(IsRecursive, PredId, ProcId,
+ ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode),
GoalInfo, Goal) -->
polymorphism__process_call(PredId, ProcId, ArgVars0,
ArgVars, ExtraVars, ExtraGoals),
@@ -772,7 +772,7 @@
{ term__vars_list(PredArgTypes, PredTypeVars0) },
{ list__remove_dups(PredTypeVars0, PredTypeVars) },
{ polymorphism__c_code_add_typeinfos(ExtraVars, PredTypeVars,
- PredTypeVarSet, ArgNames0, ArgNames) },
+ PredTypeVarSet, ArgInfo0, ArgInfo) },
%
% insert type_info types for all the inserted type_info vars
@@ -787,13 +787,13 @@
%
% plug it all back together
%
- { Call = pragma_c_code(IsRecursive, C_Code, PredId, ProcId, ArgVars,
- ArgNames, OrigArgTypes, ExtraInfo) - CallGoalInfo },
+ { Call = pragma_c_code(IsRecursive, PredId, ProcId, ArgVars,
+ ArgInfo, OrigArgTypes, PragmaCode) - CallGoalInfo },
{ list__append(ExtraGoals, [Call], GoalList) },
{ conj_list_to_goal(GoalList, GoalInfo, Goal) }.
-:- pred polymorphism__c_code_add_typeinfos(list(var), list(tvar),
- tvarset, list(maybe(string)), list(maybe(string))).
+:- pred polymorphism__c_code_add_typeinfos(list(var), list(tvar), tvarset,
+ list(maybe(pair(string, mode))), list(maybe(pair(string, mode)))).
:- mode polymorphism__c_code_add_typeinfos(in, in, in, in, out) is det.
polymorphism__c_code_add_typeinfos([], [], _, ArgNames, ArgNames).
@@ -803,7 +803,9 @@
ArgNames0, ArgNames1),
( varset__search_name(TypeVarSet, TVar, TypeVarName) ->
string__append("TypeInfo_for_", TypeVarName, C_VarName),
- ArgNames = [yes(C_VarName) | ArgNames1]
+ Input = user_defined_mode(qualified("mercury_builtin", "in"),
+ []),
+ ArgNames = [yes(C_VarName - Input) | ArgNames1]
;
ArgNames = [no | ArgNames1]
).
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.10
diff -u -u -r1.10 pragma_c_gen.m
--- pragma_c_gen.m 1997/07/27 15:01:23 1.10
+++ pragma_c_gen.m 1998/01/08 03:33:46
@@ -1,5 +1,5 @@
%---------------------------------------------------------------------------%
-% Copyright (C) 1996-1997 The University of Melbourne.
+% Copyright (C) 1996-1998 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
@@ -15,7 +15,7 @@
% The code that does this is reasonably simple.
%
% The scheme for model_non pragma_c_codes is substantially different,
-% so we handle them seperately.
+% so we handle them separately.
:- module pragma_c_gen.
@@ -25,27 +25,26 @@
:- import_module llds, code_info.
:- import_module list, std_util, term.
-:- pred pragma_c_gen__generate_pragma_c_code(code_model::in, string::in,
+:- pred pragma_c_gen__generate_pragma_c_code(code_model::in,
may_call_mercury::in, pred_id::in, proc_id::in, list(var)::in,
- list(maybe(string))::in, list(type)::in, hlds_goal_info::in,
- code_tree::out, code_info::in, code_info::out) is det.
+ list(maybe(pair(string, mode)))::in, list(type)::in,
+ hlds_goal_info::in, pragma_code::in, code_tree::out,
+ code_info::in, code_info::out) is det.
-:- pred pragma_c_gen__generate_backtrack_pragma_c_code(code_model::in,
- string::in, may_call_mercury::in, pred_id::in, proc_id::in,
- list(var)::in, list(maybe(string))::in, list(type)::in,
- list(pair(var, string))::in, list(string)::in, hlds_goal_info::in,
- code_tree::out, code_info::in, code_info::out) is erroneous.
+:- pred pragma_c_gen__struct_name(string::in, string::in, int::in, proc_id::in,
+ string::out) is det.
%---------------------------------------------------------------------------%
:- implementation.
-:- import_module hlds_module, hlds_pred, call_gen, tree.
-:- import_module string, assoc_list, set, map, require.
+:- import_module hlds_module, hlds_pred, call_gen, llds_out, trace, tree.
+:- import_module options, globals.
+:- import_module bool, string, int, assoc_list, set, map, require.
-% The code we generate for a model_det or model_semi pragma_c_code
+% The code we generate for an ordinary (model_det or model_semi) pragma_c_code
% must be able to fit into the middle of a procedure, since such
-% pragma_c_codes can be inlined. It is of the following form:
+% pragma_c_codes can be inlined. This code is of the following form:
%
% <save live variables onto the stack> /* see note (1) below */
% {
@@ -65,6 +64,179 @@
% <code to fail>
% label:
%
+% The code we generate for nondet pragma_c_code assumes that this code is
+% the only thing between the procedure prolog and epilog; such pragma_c_codes
+% therefore cannot be inlined. The code of the procedure is of one of the
+% following two forms:
+%
+% form 1:
+% <proc entry label and comments>
+% <mkframe including space for the save struct>
+% <#define MR_ORDINARY_SLOTS>
+% <--- boundary between prolog and code generated here --->
+% <set redoip to point to &&xxx_i1>
+% <code for entry to a disjunction and first disjunct>
+% {
+% <declaration of one local variable for each input and output arg>
+% <declaration of one local variable to point to save struct>
+% <assignment of input values from registers to local variables>
+% <assignment to save struct pointer>
+% save_registers(); /* see notes (1) and (2) below */
+% #define SUCCEED() goto callsuccesslabel
+% #define SUCCEED_LAST() goto calllastsuccesslabel
+% #define FAIL() fail()
+% { <the user-written call c code> }
+% { <the user-written shared c code> }
+% callsuccesslabel:
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed()
+% calllastsuccesslabel: /* see note (4) below) */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed_discard()
+% #undef SUCCEED
+% #undef SUCCEED_LAST
+% #undef FAIL
+% }
+% Define_label(xxx_i1)
+% <code for entry to a later disjunct>
+% {
+% <declaration of one local variable for each output arg>
+% <declaration of one local variable to point to save struct>
+% <assignment to save struct pointer>
+% save_registers(); /* see notes (1) and (2) below */
+% #define SUCCEED() goto retrysuccesslabel
+% #define SUCCEED_LAST() goto retrylastsuccesslabel
+% #define FAIL() fail()
+% { <the user-written retry c code> }
+% { <the user-written shared c code> }
+% retrysuccesslabel:
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed()
+% retrylastsuccesslabel: /* see note (4) below) */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed_discard()
+% #undef SUCCEED
+% #undef SUCCEED_LAST
+% #undef FAIL
+% }
+% <--- boundary between code generated here and epilog --->
+% <#undef MR_ORDINARY_SLOTS>
+%
+% form 2:
+% <proc entry label and comments>
+% <mkframe including space for the save struct>
+% <#define MR_ORDINARY_SLOTS>
+% <--- boundary between prolog and code generated here --->
+% <set redoip to point to &&xxx_i1>
+% <code for entry to a disjunction and first disjunct>
+% {
+% <declaration of one local variable for each input and output arg>
+% <declaration of one local variable to point to save struct>
+% <assignment of input values from registers to local variables>
+% <assignment to save struct pointer>
+% save_registers(); /* see notes (1) and (2) below */
+% #define SUCCEED() goto callsuccesslabel
+% #define SUCCEED_LAST() goto calllastsuccesslabel
+% #define FAIL() fail()
+% { <the user-written call c code> }
+% GOTO_LABEL(xxx_i2)
+% callsuccesslabel: /* see note (4) below */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed()
+% calllastsuccesslabel: /* see note (4) below */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed_discard()
+% #undef SUCCEED
+% #undef SUCCEED_LAST
+% #undef FAIL
+% }
+% Define_label(xxx_i1)
+% <code for entry to a later disjunct>
+% {
+% <declaration of one local variable for each output arg>
+% <declaration of one local variable to point to save struct>
+% <assignment to save struct pointer>
+% save_registers(); /* see notes (1) and (2) below */
+% #define SUCCEED() goto retrysuccesslabel
+% #define SUCCEED_LAST() goto retrylastsuccesslabel
+% #define FAIL() fail()
+% { <the user-written retry c code> }
+% GOTO_LABEL(xxx_i2)
+% retrysuccesslabel: /* see note (4) below */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed()
+% retrylastsuccesslabel: /* see note (4) below */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed_discard()
+% #undef SUCCEED
+% #undef SUCCEED_LAST
+% #undef FAIL
+% }
+% Define_label(xxx_i2)
+% {
+% <declaration of one local variable for each output arg>
+% <declaration of one local variable to point to save struct>
+% <assignment to save struct pointer>
+% #define SUCCEED() goto sharedsuccesslabel
+% #define SUCCEED_LAST() goto sharedlastsuccesslabel
+% #define FAIL() fail()
+% { <the user-written shared c code> }
+% sharedsuccesslabel:
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed()
+% sharedlastsuccesslabel: /* see note (4) below */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed_discard()
+% #undef SUCCEED
+% #undef SUCCEED_LAST
+% #undef FAIL
+% }
+% <--- boundary between code generated here and epilog --->
+% <#undef MR_ORDINARY_SLOTS>
+%
+% The first form is more time efficient, since it does not include the jumps
+% from the call code and retry code to the shared code and the following
+% initialization of the save struct pointer in the shared code block,
+% while the second form can lead to smaller code since it does not include
+% the shared C code (which can be quite big) twice.
+%
+% Programmers may indicate which form they wish the compiler to use;
+% if they don't, the compiler will choose form 1 if the shared code fragment
+% is "short", and form 2 if it is "long".
+%
+% The procedure prolog creates a nondet stack frame that includes space for
+% a struct that is saved across calls. Since the position of this struct in
+% the nondet stack frame is not known until the procedure prolog is created,
+% which is *after* the call to pragma_c_gen__generate_pragma_c_code, the
+% prolog will #define MR_ORDINARY_SLOTS as the number of ordinary slots
+% in the nondet frame. From the size of the fixed portion of the nondet stack
+% frame, from MR_ORDINARY_SLOTS and from the size of the save struct itself,
+% one can calculate the address of the save struct itself. The epilog will
+% #undef MR_ORDINARY_SLOTS. It need not do anything else, since all the normal
+% epilog stuff has been done in the code above.
+%
+% Unlike with ordinary pragma C codes, with nondet C codes there are never
+% any live variables to save at the start, except for the input variables,
+% and saving these is a job for the included C code. Also unlike ordinary
+% pragma C codes, nondet C codes are never followed by any other code,
+% so the exprn_info component of the code generator state need not be
+% kept up to date.
+%
+% Depending on the value of options such as generate_trace, use_trail, and
+% reclaim_heap_on_nondet_failure, we may need to include some code before
+% the call and retry labels. The generation of this code should follow
+% the same rules as the generation of similar code in nondet disjunctions.
+%
% Notes:
%
% (1) These parts are only emitted if the C code may call Mercury.
@@ -83,22 +255,59 @@
% through C back to Mercury. In that case, we need to
% keep the value of `hp' that was set by the recursive
% invocation of Mercury. The Mercury calling convention
-% guarantees that the values of `sp', `curfr', and `maxfr'
-% will be preserved, so if we're using conservative gc,
-% there is nothing that needs restoring.
-
-pragma_c_gen__generate_pragma_c_code(CodeModel, C_Code, MayCallMercury,
- PredId, ProcId, ArgVars, Names, OrigArgTypes, _GoalInfo,
- Code) -->
+% guarantees that when calling det or demi code, the values
+% of `sp', `curfr', and `maxfr' will be preserved, so if we're
+% using conservative gc, there is nothing that needs restoring.
+%
+% When calling nondet code, maxfr may be changed. This is why
+% we must call restore_registers() from the code we generate for
+% nondet pragma C codes even if we are not using conservative gc.
+%
+% (4) These labels and the code following them can be optimized away
+% by the C compiler if the macro that branches to them is not invoked
+% in the preceding body of included C code. We cannot optimize them
+% away ourselves, since these macros can be invoked from other macros,
+% and thus we do not have a sure test of whether the code fragments
+% invoke the macros.
+
+pragma_c_gen__generate_pragma_c_code(CodeModel, MayCallMercury,
+ PredId, ProcId, ArgVars, ArgInfo, OrigArgTypes, _GoalInfo,
+ PragmaCode, Code) -->
+ (
+ { PragmaCode = ordinary(C_Code, Context) },
+ pragma_c_gen__ordinary_pragma_c_code(CodeModel, MayCallMercury,
+ PredId, ProcId, ArgVars, ArgInfo, OrigArgTypes,
+ C_Code, Context, Code)
+ ;
+ { PragmaCode = nondet(
+ Fields, FieldsContext, First, FirstContext,
+ Later, LaterContext, Treat, Shared, SharedContext) },
+ pragma_c_gen__nondet_pragma_c_code(CodeModel, MayCallMercury,
+ PredId, ProcId, ArgVars, ArgInfo, OrigArgTypes,
+ Fields, FieldsContext, First, FirstContext,
+ Later, LaterContext, Treat, Shared, SharedContext,
+ Code)
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred pragma_c_gen__ordinary_pragma_c_code(code_model::in,
+ may_call_mercury::in, pred_id::in, proc_id::in, list(var)::in,
+ list(maybe(pair(string, mode)))::in, list(type)::in,
+ string::in, term__context::in, code_tree::out,
+ code_info::in, code_info::out) is det.
+
+pragma_c_gen__ordinary_pragma_c_code(CodeModel, MayCallMercury,
+ PredId, ProcId, ArgVars, ArgInfo, OrigArgTypes,
+ C_Code, Context, Code) -->
% First we need to get a list of input and output arguments
code_info__get_pred_proc_arginfo(PredId, ProcId, ArgInfos),
- { make_c_arg_list(ArgVars, Names, OrigArgTypes, ArgInfos, Args) },
+ { make_c_arg_list(ArgVars, ArgInfo, OrigArgTypes, ArgInfos, Args) },
{ pragma_select_in_args(Args, InArgs) },
{ pragma_select_out_args(Args, OutArgs) },
+ { make_pragma_decls(Args, Decls) },
- ( { MayCallMercury = will_not_call_mercury } ->
- { SaveVarsCode = empty }
- ;
+ ( { MayCallMercury = may_call_mercury } ->
% the C code might call back Mercury code
% which clobbers the succip
code_info__succip_is_used,
@@ -109,10 +318,11 @@
{ get_c_arg_list_vars(OutArgs, OutArgs1) },
{ set__list_to_set(OutArgs1, OutArgsSet) },
call_gen__save_variables(OutArgsSet, SaveVarsCode)
+ ;
+ { SaveVarsCode = empty }
),
- { make_pragma_decls(Args, Decls) },
- get_pragma_input_vars(InArgs, Inputs, InputVarsCode),
+ get_pragma_input_vars(InArgs, InputDescs, InputVarsCode),
( { CodeModel = model_semi } ->
% We have to clear r1 for C code that gets inlined
% so that it is safe to assign to SUCCESS_INDICATOR.
@@ -128,12 +338,19 @@
% C code goes here
- code_info__get_next_label(SkipLab),
+ code_info__get_next_label(SkipLabel),
code_info__generate_failure(FailCode),
- { CheckFailureCode = tree(node([
- if_val(lval(reg(r, 1)), label(SkipLab)) -
+ { TestCode = node([
+ if_val(lval(reg(r, 1)), label(SkipLabel)) -
"Test for success of pragma_c_code"
- ]), tree(FailCode, node([ label(SkipLab) - "" ])))
+ ]) },
+ { SkipLabelCode = node([
+ label(SkipLabel) - ""
+ ]) },
+ { CheckFailureCode =
+ tree(TestCode,
+ tree(FailCode,
+ SkipLabelCode))
},
code_info__lock_reg(reg(r, 1)),
@@ -156,45 +373,333 @@
pragma_acquire_regs(OutArgs, Regs)
),
- place_pragma_output_args_in_regs(OutArgs, Regs, Outputs),
+ place_pragma_output_args_in_regs(OutArgs, Regs, OutputDescs),
- ( { MayCallMercury = will_not_call_mercury } ->
- { Wrapped_C_Code = C_Code }
+ { C_Code_Comp = pragma_c_user_code(Context, C_Code) },
+ { MayCallMercury = will_not_call_mercury ->
+ WrappedComp = [C_Code_Comp]
;
- { string__append_list([
- "\tsave_registers();\n{\n",
- C_Code, "\n}\n",
- "#ifndef CONSERVATIVE_GC\n",
- "\trestore_registers();\n",
- "#endif\n"
- ], Wrapped_C_Code) }
- ),
-
- % The context in the goal_info we are given is the context of the
- % call to the predicate whose definition is a pragma_c_code.
- % The context we want to put into the LLDS code we generate
- % is the context of the pragma_c_code line in the definition
- % of that predicate.
- code_info__get_module_info(ModuleInfo),
- { module_info_pred_proc_info(ModuleInfo, PredId, ProcId, _, ProcInfo) },
- { proc_info_goal(ProcInfo, OrigGoal) },
- { OrigGoal = _ - OrigGoalInfo },
- { goal_info_get_context(OrigGoalInfo, Context) },
+ SaveRegsComp = pragma_c_raw_code(
+ "\tsave_registers();\n"
+ ),
+ RestoreRegsComp = pragma_c_raw_code(
+ "#ifndef CONSERVATIVE_GC\n\trestore_registers();\n#endif\n"
+ ),
+ WrappedComp = [SaveRegsComp, C_Code_Comp, RestoreRegsComp]
+ },
+ { InputComp = pragma_c_inputs(InputDescs) },
+ { OutputComp = pragma_c_outputs(OutputDescs) },
+ { list__append([InputComp | WrappedComp], [OutputComp], Components) },
- { PragmaCode = node([
- pragma_c(Decls, Inputs, Wrapped_C_Code, Outputs, Context) -
+ { PragmaCCode = node([
+ pragma_c(Decls, Components, MayCallMercury, no) -
"Pragma C inclusion"
]) },
+
{ Code =
tree(SaveVarsCode,
tree(InputVarsCode,
tree(ShuffleR1_Code,
- tree(PragmaCode,
+ tree(PragmaCCode,
CheckFailureCode))))
}.
%---------------------------------------------------------------------------%
+:- pred pragma_c_gen__nondet_pragma_c_code(code_model::in,
+ may_call_mercury::in, pred_id::in, proc_id::in, list(var)::in,
+ list(maybe(pair(string, mode)))::in, list(type)::in,
+ string::in, term__context::in, string::in, term__context::in,
+ string::in, term__context::in, pragma_shared_code_treatment::in,
+ string::in, term__context::in, code_tree::out,
+ code_info::in, code_info::out) is det.
+
+pragma_c_gen__nondet_pragma_c_code(CodeModel, MayCallMercury,
+ PredId, ProcId, ArgVars, ArgInfo, OrigArgTypes,
+ _Fields, _FieldsContext, First, FirstContext,
+ Later, LaterContext, Treat, Shared, SharedContext, Code) -->
+ { require(unify(CodeModel, model_non),
+ "inappropriate code model for nondet pragma C code") },
+ % First we need to get a list of input and output arguments
+ code_info__get_pred_proc_arginfo(PredId, ProcId, ArgInfos),
+ { make_c_arg_list(ArgVars, ArgInfo, OrigArgTypes, ArgInfos, Args) },
+ { pragma_select_in_args(Args, InArgs) },
+ { pragma_select_out_args(Args, OutArgs) },
+ { make_pragma_decls(Args, Decls) },
+ { make_pragma_decls(OutArgs, OutDecls) },
+
+ { input_descs_from_arg_info(InArgs, InputDescs) },
+ { output_descs_from_arg_info(OutArgs, OutputDescs) },
+
+ code_info__get_module_info(ModuleInfo),
+ { predicate_module(ModuleInfo, PredId, ModuleName) },
+ { predicate_name(ModuleInfo, PredId, PredName) },
+ { predicate_arity(ModuleInfo, PredId, Arity) },
+ { pragma_c_gen__struct_name(ModuleName, PredName, Arity, ProcId,
+ StructName) },
+ { SaveStructDecl = pragma_c_struct_ptr_decl(StructName, "LOCALS") },
+ { string__format("\tLOCALS = (struct %s *) (
+ (char *) (curfr - MR_ORDINARY_SLOTS - NONDET_FIXED_SIZE)
+ - sizeof(struct %s));\n",
+ [s(StructName), s(StructName)],
+ InitSaveStruct) },
+
+ code_info__get_next_label(RetryLabel),
+ { ModFrameCode = node([
+ modframe(label(RetryLabel)) -
+ "Set up backtracking to retry label"
+ ]) },
+ { RetryLabelCode = node([
+ label(RetryLabel) -
+ "Start of the retry block"
+ ]) },
+
+ code_info__get_globals(Globals),
+
+ { globals__lookup_bool_option(Globals, reclaim_heap_on_nondet_failure,
+ ReclaimHeap) },
+ code_info__maybe_save_hp(ReclaimHeap, SaveHeapCode, MaybeHpSlot),
+ code_info__maybe_restore_hp(MaybeHpSlot, RestoreHeapCode),
+
+ { globals__lookup_bool_option(Globals, use_trail, UseTrail) },
+ code_info__maybe_save_ticket(UseTrail, SaveTicketCode, MaybeTicketSlot),
+ code_info__maybe_reset_ticket(MaybeTicketSlot, undo, RestoreTicketCode),
+
+ code_info__get_maybe_trace_info(MaybeTraceInfo),
+ ( { MaybeTraceInfo = yes(TraceInfo) } ->
+ trace__generate_event_code(disj([disj(1)]), TraceInfo,
+ FirstTraceCode),
+ trace__generate_event_code(disj([disj(2)]), TraceInfo,
+ LaterTraceCode)
+ ;
+ { FirstTraceCode = empty },
+ { LaterTraceCode = empty }
+ ),
+
+ { FirstDisjunctCode =
+ tree(SaveHeapCode,
+ tree(SaveTicketCode,
+ FirstTraceCode))
+ },
+ { LaterDisjunctCode =
+ tree(RestoreHeapCode,
+ tree(RestoreTicketCode,
+ LaterTraceCode))
+ },
+
+ {
+ SaveRegs = "\tsave_registers();\n",
+ RestoreRegs = "\trestore_registers();\n",
+
+ Succeed = "\tsucceed();\n",
+ SucceedDiscard = "\tsucceed_discard();\n",
+
+ CallDef1 = "#define\tSUCCEED \tgoto MR_call_success\n",
+ CallDef2 = "#define\tSUCCEED_LAST\tgoto MR_call_success_last\n",
+ CallDef3 = "#define\tFAIL\tfail()\n",
+
+ CallSuccessLabel = "MR_call_success:\n",
+ CallLastSuccessLabel = "MR_call_success_last:\n",
+
+ RetryDef1 = "#define\tSUCCEED \tgoto MR_retry_success\n",
+ RetryDef2 = "#define\tSUCCEED_LAST\tgoto MR_retry_success_last\n",
+ RetryDef3 = "#define\tFAIL\tfail()\n",
+
+ RetrySuccessLabel = "MR_retry_success:\n",
+ RetryLastSuccessLabel = "MR_retry_success_last:\n",
+
+ Undef1 = "#undef\tSUCCEED\n",
+ Undef2 = "#undef\tSUCCEED_LAST\n",
+ Undef3 = "#undef\tFAIL\n"
+ },
+
+ (
+ {
+ Treat = duplicate
+ ;
+ Treat = automatic,
+ string__length(Shared, Len),
+ Len < 1024
+ }
+ ->
+ {
+ CallDecls = [SaveStructDecl | Decls],
+ CallComponents = [
+ pragma_c_inputs(InputDescs),
+ pragma_c_raw_code(InitSaveStruct),
+ pragma_c_raw_code(SaveRegs),
+ pragma_c_raw_code(CallDef1),
+ pragma_c_raw_code(CallDef2),
+ pragma_c_raw_code(CallDef3),
+ pragma_c_user_code(FirstContext, First),
+ pragma_c_user_code(SharedContext, Shared),
+ pragma_c_raw_code(CallSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(Succeed),
+ pragma_c_raw_code(CallLastSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(SucceedDiscard),
+ pragma_c_raw_code(Undef1),
+ pragma_c_raw_code(Undef2),
+ pragma_c_raw_code(Undef3)
+ ],
+ CallBlockCode = node([
+ pragma_c(CallDecls, CallComponents,
+ MayCallMercury, no)
+ - "Call and shared pragma C inclusion"
+ ]),
+
+ RetryDecls = [SaveStructDecl | OutDecls],
+ RetryComponents = [
+ pragma_c_raw_code(InitSaveStruct),
+ pragma_c_raw_code(SaveRegs),
+ pragma_c_raw_code(RetryDef1),
+ pragma_c_raw_code(RetryDef2),
+ pragma_c_raw_code(RetryDef3),
+ pragma_c_user_code(LaterContext, Later),
+ pragma_c_user_code(SharedContext, Shared),
+ pragma_c_raw_code(RetrySuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(Succeed),
+ pragma_c_raw_code(RetryLastSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(SucceedDiscard),
+ pragma_c_raw_code(Undef1),
+ pragma_c_raw_code(Undef2),
+ pragma_c_raw_code(Undef3)
+ ],
+ RetryBlockCode = node([
+ pragma_c(RetryDecls, RetryComponents,
+ MayCallMercury, no)
+ - "Retry and shared pragma C inclusion"
+ ]),
+
+ Code =
+ tree(ModFrameCode,
+ tree(FirstDisjunctCode,
+ tree(CallBlockCode,
+ tree(RetryLabelCode,
+ tree(LaterDisjunctCode,
+ RetryBlockCode)))))
+ }
+ ;
+ code_info__get_next_label(SharedLabel),
+ {
+ SharedLabelCode = node([
+ label(SharedLabel) -
+ "Start of the shared block"
+ ]),
+
+ SharedDef1 = "#define\tSUCCEED \tgoto MR_shared_success\n",
+ SharedDef2 = "#define\tSUCCEED_LAST\tgoto MR_shared_success_last\n",
+ SharedDef3 = "#define\tFAIL\tfail()\n",
+
+ SharedSuccessLabel = "MR_shared_success:\n",
+ SharedLastSuccessLabel = "MR_shared_success_last:\n",
+
+ llds_out__get_label(SharedLabel, yes, LabelStr),
+ string__format("\tGOTO_LABEL(%s);\n", [s(LabelStr)],
+ GotoSharedLabel),
+
+ CallDecls = [SaveStructDecl | Decls],
+ CallComponents = [
+ pragma_c_inputs(InputDescs),
+ pragma_c_raw_code(InitSaveStruct),
+ pragma_c_raw_code(SaveRegs),
+ pragma_c_raw_code(CallDef1),
+ pragma_c_raw_code(CallDef2),
+ pragma_c_raw_code(CallDef3),
+ pragma_c_user_code(FirstContext, First),
+ pragma_c_raw_code(GotoSharedLabel),
+ pragma_c_raw_code(CallSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(Succeed),
+ pragma_c_raw_code(CallLastSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(SucceedDiscard),
+ pragma_c_raw_code(Undef1),
+ pragma_c_raw_code(Undef2),
+ pragma_c_raw_code(Undef3)
+ ],
+ CallBlockCode = node([
+ pragma_c(CallDecls, CallComponents,
+ MayCallMercury, yes(SharedLabel))
+ - "Call pragma C inclusion"
+ ]),
+
+ RetryDecls = [SaveStructDecl | OutDecls],
+ RetryComponents = [
+ pragma_c_raw_code(InitSaveStruct),
+ pragma_c_raw_code(SaveRegs),
+ pragma_c_raw_code(RetryDef1),
+ pragma_c_raw_code(RetryDef2),
+ pragma_c_raw_code(RetryDef3),
+ pragma_c_user_code(LaterContext, Later),
+ pragma_c_raw_code(GotoSharedLabel),
+ pragma_c_raw_code(RetrySuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(Succeed),
+ pragma_c_raw_code(RetryLastSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(SucceedDiscard),
+ pragma_c_raw_code(Undef1),
+ pragma_c_raw_code(Undef2),
+ pragma_c_raw_code(Undef3)
+ ],
+ RetryBlockCode = node([
+ pragma_c(RetryDecls, RetryComponents,
+ MayCallMercury, yes(SharedLabel))
+ - "Retry pragma C inclusion"
+ ]),
+
+ SharedDecls = [SaveStructDecl | OutDecls],
+ SharedComponents = [
+ pragma_c_raw_code(InitSaveStruct),
+ pragma_c_raw_code(SaveRegs),
+ pragma_c_raw_code(SharedDef1),
+ pragma_c_raw_code(SharedDef2),
+ pragma_c_raw_code(SharedDef3),
+ pragma_c_user_code(SharedContext, Shared),
+ pragma_c_raw_code(SharedSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(Succeed),
+ pragma_c_raw_code(SharedLastSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(SucceedDiscard),
+ pragma_c_raw_code(Undef1),
+ pragma_c_raw_code(Undef2),
+ pragma_c_raw_code(Undef3)
+ ],
+ SharedBlockCode = node([
+ pragma_c(SharedDecls, SharedComponents,
+ MayCallMercury, no)
+ - "Shared pragma C inclusion"
+ ]),
+
+ Code =
+ tree(ModFrameCode,
+ tree(FirstDisjunctCode,
+ tree(CallBlockCode,
+ tree(RetryLabelCode,
+ tree(LaterDisjunctCode,
+ tree(RetryBlockCode,
+ tree(SharedLabelCode,
+ SharedBlockCode)))))))
+ }
+ ).
+
+%---------------------------------------------------------------------------%
+
:- type c_arg
---> c_arg(
var,
@@ -207,13 +712,30 @@
arg_info
).
-:- pred make_c_arg_list(list(var)::in, list(maybe(string))::in,
+:- pred make_c_arg_list(list(var)::in, list(maybe(pair(string, mode)))::in,
list(type)::in, list(arg_info)::in, list(c_arg)::out) is det.
-make_c_arg_list(Vars, Names, Types, ArgInfos, ArgList) :-
- ( Vars = [], Names = [], Types = [], ArgInfos = [] ->
+make_c_arg_list(Vars, ArgInfo, Types, ArgInfos, ArgList) :-
+ (
+ Vars = [],
+ ArgInfo = [],
+ Types = [],
+ ArgInfos = []
+ ->
ArgList = []
- ; Vars = [V|Vs], Names = [N|Ns], Types = [T|Ts], ArgInfos = [A|As] ->
+ ;
+ Vars = [V|Vs],
+ ArgInfo = [MN|Ns],
+ Types = [T|Ts],
+ ArgInfos = [A|As]
+ ->
+ (
+ MN = yes(Name - _),
+ N = yes(Name)
+ ;
+ MN = no,
+ N = no
+ ),
Arg = c_arg(V, N, T, A),
make_c_arg_list(Vs, Ns, Ts, As, Args),
ArgList = [Arg | Args]
@@ -269,7 +791,7 @@
%---------------------------------------------------------------------------%
% make_pragma_decls returns the list of pragma_decls for the pragma_c
-% data structure in the llds. It is essentially a list of pairs of type and
+% data structure in the LLDS. It is essentially a list of pairs of type and
% variable name, so that declarations of the form "Type Name;" can be made.
:- pred make_pragma_decls(list(c_arg)::in, list(pragma_c_decl)::out) is det.
@@ -278,7 +800,7 @@
make_pragma_decls([Arg | Args], Decls) :-
Arg = c_arg(_Var, ArgName, OrigType, _ArgInfo),
( ArgName = yes(Name) ->
- Decl = pragma_c_decl(OrigType, Name),
+ Decl = pragma_c_arg_decl(OrigType, Name),
make_pragma_decls(Args, Decls1),
Decls = [Decl | Decls1]
;
@@ -290,7 +812,7 @@
%---------------------------------------------------------------------------%
% get_pragma_input_vars returns a list of pragma_c_inputs for the pragma_c
-% data structure in the llds. It is essentially a list of the input variables,
+% data structure in the LLDS. It is essentially a list of the input variables,
% and the corresponding rvals assigned to those (C) variables.
:- pred get_pragma_input_vars(list(c_arg)::in, list(pragma_c_input)::out,
@@ -353,8 +875,53 @@
%---------------------------------------------------------------------------%
-pragma_c_gen__generate_backtrack_pragma_c_code(_, _, _, _, _, _, _, _, _, _,
- _, _) -->
- { error("Sorry, nondet pragma_c_codes not yet implemented") }.
+% input_descs_from_arg_info returns a list of pragma_c_inputs, which
+% are pairs of rvals and (C) variables which receive the input value.
+
+:- pred input_descs_from_arg_info(list(c_arg)::in, list(pragma_c_input)::out)
+ is det.
+
+input_descs_from_arg_info([], []).
+input_descs_from_arg_info([Arg | Args], Inputs) :-
+ Arg = c_arg(_Var, MaybeName, OrigType, ArgInfo),
+ ( MaybeName = yes(Name) ->
+ ArgInfo = arg_info(N, _),
+ Reg = reg(r, N),
+ Input = pragma_c_input(Name, OrigType, lval(Reg)),
+ Inputs = [Input | Inputs1],
+ input_descs_from_arg_info(Args, Inputs1)
+ ;
+ input_descs_from_arg_info(Args, Inputs)
+ ).
+
+%---------------------------------------------------------------------------%
+
+% output_descs_from_arg_info returns a list of pragma_c_outputs, which
+% are pairs of names of output registers and (C) variables which hold the
+% output value.
+
+:- pred output_descs_from_arg_info(list(c_arg)::in, list(pragma_c_output)::out)
+ is det.
+
+output_descs_from_arg_info([], []).
+output_descs_from_arg_info([Arg | Args], [Output | Outputs]) :-
+ Arg = c_arg(_Var, MaybeName, OrigType, ArgInfo),
+ ( MaybeName = yes(Name) ->
+ ArgInfo = arg_info(N, _),
+ Reg = reg(r, N),
+ Output = pragma_c_output(Reg, OrigType, Name)
+ ;
+ error("output_descs_from_arg_info: unnamed arg")
+ ),
+ output_descs_from_arg_info(Args, Outputs).
+
+%---------------------------------------------------------------------------%
+
+pragma_c_gen__struct_name(ModuleName, PredName, Arity, ProcId, StructName) :-
+ proc_id_to_int(ProcId, ProcNum),
+ string__int_to_string(Arity, ArityStr),
+ string__int_to_string(ProcNum, ProcNumStr),
+ string__append_list(["mercury_save__", ModuleName, "__",
+ PredName, "__", ArityStr, "_", ProcNumStr], StructName).
%---------------------------------------------------------------------------%
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.29
diff -u -u -r1.29 prog_data.m
--- prog_data.m 1997/12/22 09:56:16 1.29
+++ prog_data.m 1998/01/06 07:17:35
@@ -99,18 +99,10 @@
; c_code(string)
; c_code(may_call_mercury, sym_name, pred_or_func,
- list(pragma_var), varset, string)
+ list(pragma_var), varset, pragma_code)
% Whether or not the C code may call Mercury,
% PredName, Predicate or Function, Vars/Mode,
- % VarNames, C Code
-
- ; c_code(may_call_mercury, sym_name,
- pred_or_func, list(pragma_var),
- list(string), list(string),
- varset, string)
- % Whether or not the C code may call Mercury,
- % PredName, Predicate or Function, Vars/Mode,
- % SavedeVars, LabelNames, VarNames, C Code
+ % VarNames, C Code Info
; memo(sym_name, arity)
% Predname, Arity
@@ -166,6 +158,47 @@
; check_termination(sym_name, arity).
% Predname, Arity
+
+ % All the strings in this type are accompanied by the context
+ % of their appearance in the source code. These contexts are
+ % used to tell the C compiler where the included C code comes from,
+ % to allow it to generate error messages that refer to the original
+ % appearance of the code in the Mercury program.
+:- type pragma_code
+ ---> ordinary( % This is a C definition of a model_det
+ % or model_semi procedure. (We also
+ % allow model_non, until everyone has
+ % had time to adapt to the new way
+ % of handling model_non pragmas.
+ string, % The C code of the procedure.
+ term__context
+ )
+ ; nondet( % This is a C definition of a model_non
+ % procedure.
+ string, % The info saved for the time when
+ term__context, % backtracking reenters this procedure
+ % is stored in a C struct. This arg
+ % contains the field declarations.
+ string, % Gives the code to be executed when
+ term__context, % the procedure is called for the first
+ % time. This code may access the input
+ % variables.
+ string, % Gives the code to be executed when
+ term__context, % control backtracks into the procedure.
+ % This code may not access the input
+ % variables.
+ pragma_shared_code_treatment,
+ % How should the shared code be
+ % treated during code generation.
+ string, % Shared code that is executed after
+ term__context % both the previous code fragments.
+ % May not access the input variables.
+ ).
+
+:- type pragma_shared_code_treatment
+ ---> duplicate
+ ; share
+ ; automatic.
:- type class_constraint ---> constraint(class_name, list(type)).
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.10
diff -u -u -r1.10 prog_io_pragma.m
--- prog_io_pragma.m 1997/12/22 09:56:18 1.10
+++ prog_io_pragma.m 1998/01/08 06:37:18
@@ -23,7 +23,7 @@
:- implementation.
:- import_module prog_io_goal, hlds_pred, term_util, term_errors.
-:- import_module string, std_util, bool, require.
+:- import_module int, string, std_util, bool, require.
parse_pragma(ModuleName, VarSet, PragmaTerms, Result) :-
(
@@ -106,42 +106,97 @@
% XXX we should issue a warning; this syntax is deprecated.
% Result = error("pragma c_code doesn't say whether it can call mercury", PredAndVarsTerm)
MayCallMercury = will_not_call_mercury,
- parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm,
- no, C_CodeTerm, VarSet, Result)
+ (
+ C_CodeTerm = term__functor(term__string(C_Code), [], Context)
+ ->
+ parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm,
+ ordinary(C_Code, Context), VarSet, Result)
+ ;
+ Result = error("invalid `:- pragma c_code' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury', and a string for C code",
+ C_CodeTerm)
+ )
;
PragmaTerms = [PredAndVarsTerm, MayCallMercuryTerm, C_CodeTerm]
->
- ( parse_may_call_mercury(MayCallMercuryTerm, MayCallMercury) ->
- parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm,
- no, C_CodeTerm, VarSet, Result)
- ; parse_may_call_mercury(PredAndVarsTerm, MayCallMercury) ->
- % XXX we should issue a warning; this syntax is deprecated
- parse_pragma_c_code(ModuleName, MayCallMercury,
- MayCallMercuryTerm, no, C_CodeTerm, VarSet, Result)
- ;
- Result = error("invalid second argument in `:- pragma c_code(..., ..., ...)' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
+ (
+ C_CodeTerm = term__functor(term__string(C_Code), [], Context)
+ ->
+ ( parse_may_call_mercury(MayCallMercuryTerm, MayCallMercury) ->
+ parse_pragma_c_code(ModuleName, MayCallMercury,
+ PredAndVarsTerm, ordinary(C_Code, Context),
+ VarSet, Result)
+ ; parse_may_call_mercury(PredAndVarsTerm, MayCallMercury) ->
+ % XXX we should issue a warning; this syntax is deprecated
+ parse_pragma_c_code(ModuleName, MayCallMercury,
+ MayCallMercuryTerm, ordinary(C_Code, Context),
+ VarSet, Result)
+ ;
+ Result = error("invalid second argument in `:- pragma c_code' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
MayCallMercuryTerm)
+ )
+ ;
+ Result = error("invalid third argument in `:- pragma c_code' declaration -- expecting string for C code",
+ C_CodeTerm)
)
;
- PragmaTerms = [PredAndVarsTerm, MayCallMercuryTerm,
- SavedVarsTerm, LabelNamesTerm, C_CodeTerm]
+ (
+ PragmaTerms = [PredAndVarsTerm, MayCallMercuryTerm,
+ FieldsTerm, FirstTerm, LaterTerm],
+ term__context_init(DummyContext),
+ SharedTerm = term__functor(term__atom("common_code"),
+ [term__functor(term__string(""), [], DummyContext)],
+ DummyContext)
+ ;
+ PragmaTerms = [PredAndVarsTerm, MayCallMercuryTerm,
+ FieldsTerm, FirstTerm, LaterTerm, SharedTerm]
+ )
->
( parse_may_call_mercury(MayCallMercuryTerm, MayCallMercury) ->
- ( parse_ident_list(SavedVarsTerm, SavedVars) ->
- ( parse_ident_list(LabelNamesTerm, LabelNames) ->
- parse_pragma_c_code(ModuleName, MayCallMercury,
- PredAndVarsTerm, yes(SavedVars - LabelNames),
- C_CodeTerm, VarSet, Result)
+ ( parse_pragma_keyword("local_vars", FieldsTerm, Fields, FieldsContext) ->
+ ( parse_pragma_keyword("first_code", FirstTerm, First, FirstContext) ->
+ ( parse_pragma_keyword("retry_code", LaterTerm, Later, LaterContext) ->
+ ( parse_pragma_keyword("shared_code", SharedTerm, Shared, SharedContext) ->
+ parse_pragma_c_code(ModuleName, MayCallMercury,
+ PredAndVarsTerm,
+ nondet(Fields, FieldsContext,
+ First, FirstContext,
+ Later, LaterContext,
+ share, Shared, SharedContext),
+ VarSet, Result)
+ ; parse_pragma_keyword("duplicated_code", SharedTerm, Shared, SharedContext) ->
+ parse_pragma_c_code(ModuleName, MayCallMercury,
+ PredAndVarsTerm,
+ nondet(Fields, FieldsContext,
+ First, FirstContext,
+ Later, LaterContext,
+ duplicate, Shared, SharedContext),
+ VarSet, Result)
+ ; parse_pragma_keyword("common_code", SharedTerm, Shared, SharedContext) ->
+ parse_pragma_c_code(ModuleName, MayCallMercury,
+ PredAndVarsTerm,
+ nondet(Fields, FieldsContext,
+ First, FirstContext,
+ Later, LaterContext,
+ automatic, Shared, SharedContext),
+ VarSet, Result)
+ ;
+ Result = error("invalid sixth argument in `:- pragma c_code' declaration -- expecting `shared_code(<code>')",
+ LaterTerm)
+ )
+ ;
+ Result = error("invalid fifth argument in `:- pragma c_code' declaration -- expecting `later_code(<code>')",
+ LaterTerm)
+ )
;
- Result = error("invalid fourth argument in `:- pragma c_code/5' declaration -- expecting a list of C identifiers",
- MayCallMercuryTerm)
+ Result = error("invalid fourth argument in `:- pragma c_code' declaration -- expecting `first_code(<code>')",
+ FirstTerm)
)
;
- Result = error("invalid third argument in `:- pragma c_code/5' declaration -- expecting a list of C identifiers",
- MayCallMercuryTerm)
+ Result = error("invalid third argument in `:- pragma c_code' declaration -- expecting `local_vars(<fields>)'",
+ FieldsTerm)
)
;
- Result = error("invalid second argument in `:- pragma c_code/3' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
+ Result = error("invalid second argument in `:- pragma c_code' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
MayCallMercuryTerm)
)
;
@@ -426,7 +481,6 @@
Pragma = check_termination(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
-
:- pred parse_simple_pragma(module_name, string,
pred(sym_name, int, pragma_type),
list(term), term, maybe1(item)).
@@ -468,6 +522,24 @@
%-----------------------------------------------------------------------------%
+:- pred parse_pragma_keyword(string, term, string, term__context).
+:- mode parse_pragma_keyword(in, in, out, out) is semidet.
+
+parse_pragma_keyword(ExpectedKeyword, Term, StringArg, StartContext) :-
+ Term = term__functor(term__atom(ExpectedKeyword), [Arg], _),
+ Arg = term__functor(term__string(StringArg), [], StartContext).
+% EndContext = term__context(File, EndLine),
+% AddOneIfNewline = lambda([Char::in, Count0::in, Count::out] is det, (
+% ( Char = '\n' ->
+% Count is Count0 + 1
+% ;
+% Count = Count0
+% )
+% )),
+% string__foldl(AddOneIfNewline, StringArg, 0, LinesInString),
+% StartLine is EndLine - LinesInString - 1,
+% StartContext = term__context(File, StartLine).
+
:- pred parse_may_call_mercury(term, may_call_mercury).
:- mode parse_may_call_mercury(in, out) is semidet.
@@ -477,27 +549,17 @@
will_not_call_mercury).
parse_may_call_mercury(term__functor(term__atom("may_call_mercury"), [], _),
may_call_mercury).
-parse_may_call_mercury(term__functor(term__atom("will_not_call_mercury"), [], _),
- will_not_call_mercury).
-
-:- pred parse_ident_list(term, list(string)).
-:- mode parse_ident_list(in, out) is semidet.
-
-parse_ident_list(term__functor(term__atom("[]"), [], _), []).
-parse_ident_list(term__functor(term__atom("."), [Head, Tail], _),
- [SavedVar | SavedVars]) :-
- % XXX liberalize this
- Head = term__functor(term__atom(SavedVar), [], _),
- parse_ident_list(Tail, SavedVars).
+parse_may_call_mercury(term__functor(term__atom("will_not_call_mercury"), [],
+ _), will_not_call_mercury).
% parse a pragma c_code declaration
:- pred parse_pragma_c_code(module_name, may_call_mercury, term,
- maybe(pair(list(string))), term, varset, maybe1(item)).
-:- mode parse_pragma_c_code(in, in, in, in, in, in, out) is det.
+ pragma_code, varset, maybe1(item)).
+:- mode parse_pragma_c_code(in, in, in, in, in, out) is det.
-parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm0, ExtraInfo,
- C_CodeTerm, VarSet, Result) :-
+parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm0, PragmaCode,
+ VarSet, Result) :-
(
PredAndVarsTerm0 = term__functor(Const, Terms0, _)
->
@@ -509,7 +571,7 @@
% function
PredOrFunc = function,
PredAndVarsTerm = FuncAndVarsTerm,
- FuncResultTerms = [ FuncResultTerm0 ]
+ FuncResultTerms = [FuncResultTerm0]
;
% predicate
PredOrFunc = predicate,
@@ -517,7 +579,7 @@
FuncResultTerms = []
),
parse_qualified_term(ModuleName, PredAndVarsTerm, PredAndVarsTerm0,
- "pragma c_code declaration", PredNameResult),
+ "pragma c_code declaration", PredNameResult),
(
PredNameResult = ok(PredName, VarList0),
(
@@ -527,29 +589,14 @@
PredOrFunc = function,
list__append(VarList0, FuncResultTerms, VarList)
),
+ parse_pragma_c_code_varlist(VarSet, VarList, PragmaVars, Error),
(
- C_CodeTerm = term__functor(term__string(C_Code), [], _)
- ->
- parse_pragma_c_code_varlist(VarSet,
- VarList, PragmaVars, Error),
- (
- Error = no,
- (
- ExtraInfo = no,
- Result = ok(pragma(c_code(MayCallMercury, PredName,
- PredOrFunc, PragmaVars, VarSet, C_Code)))
- ;
- ExtraInfo = yes(SavedVars - LabelNames),
- Result = ok(pragma(c_code(MayCallMercury, PredName,
- PredOrFunc, PragmaVars, SavedVars, LabelNames,
- VarSet, C_Code)))
- )
- ;
- Error = yes(ErrorMessage),
- Result = error(ErrorMessage, PredAndVarsTerm)
- )
+ Error = no,
+ Result = ok(pragma(c_code(MayCallMercury, PredName,
+ PredOrFunc, PragmaVars, VarSet, PragmaCode)))
;
- Result = error("expected string for C code", C_CodeTerm)
+ Error = yes(ErrorMessage),
+ Result = error(ErrorMessage, PredAndVarsTerm)
)
;
PredNameResult = error(Msg, Term),
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.5
diff -u -u -r1.5 purity.m
--- purity.m 1998/01/06 06:31:36 1.5
+++ purity.m 1998/01/08 08:01:09
@@ -587,7 +587,7 @@
{ worst_purity(Purity12, Purity3, Purity) }.
compute_expr_purity(Ccode, Ccode, _, _, ModuleInfo, _, Purity,
NumErrors, NumErrors) -->
- { Ccode = pragma_c_code(_,_,PredId,_,_,_,_,_) },
+ { Ccode = pragma_c_code(_,PredId,_,_,_,_,_) },
{ module_info_preds(ModuleInfo, Preds) },
{ map__lookup(Preds, PredId, PredInfo) },
{ pred_info_get_purity(PredInfo, Purity) }.
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.55
diff -u -u -r1.55 quantification.m
--- quantification.m 1997/12/22 09:56:21 1.55
+++ quantification.m 1998/01/02 04:42:33
@@ -317,8 +317,8 @@
{ set__union(NonLocalVars1, NonLocalVars2, NonLocalVars) },
quantification__set_nonlocals(NonLocalVars).
-implicitly_quantify_goal_2(pragma_c_code(A,B,C,D,Vars,F,G,H), _,
- pragma_c_code(A,B,C,D,Vars,F,G,H)) -->
+implicitly_quantify_goal_2(pragma_c_code(A,B,C,Vars,E,F,G), _,
+ pragma_c_code(A,B,C,Vars,E,F,G)) -->
implicitly_quantify_atomic_goal(Vars).
:- pred implicitly_quantify_atomic_goal(list(var), quant_info, quant_info).
@@ -642,7 +642,7 @@
set__union(Set5, Set6, Set),
set__union(LambdaSet5, LambdaSet6, LambdaSet).
-quantification__goal_vars_2(pragma_c_code(_, _, _, _, ArgVars, _, _, _),
+quantification__goal_vars_2(pragma_c_code(_, _, _, ArgVars, _, _, _),
Set0, LambdaSet, Set, LambdaSet) :-
set__insert_list(Set0, ArgVars, Set).
Index: compiler/saved_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/saved_vars.m,v
retrieving revision 1.13
diff -u -u -r1.13 saved_vars.m
--- saved_vars.m 1997/12/22 09:56:22 1.13
+++ saved_vars.m 1998/01/02 04:42:41
@@ -122,7 +122,7 @@
Goal = GoalExpr0 - GoalInfo0,
SlotInfo = SlotInfo0
;
- GoalExpr0 = pragma_c_code(_, _, _, _, _, _, _, _),
+ GoalExpr0 = pragma_c_code(_, _, _, _, _, _, _),
Goal = GoalExpr0 - GoalInfo0,
SlotInfo = SlotInfo0
),
@@ -287,7 +287,7 @@
IsNonLocal, SlotInfo1, Goals1, SlotInfo),
Goals = [NewConstruct, Goal1 | Goals1]
;
- Goal0Expr = pragma_c_code(_, _, _, _, _, _, _, _),
+ Goal0Expr = pragma_c_code(_, _, _, _, _, _, _),
rename_var(SlotInfo0, Var, _NewVar, Subst, SlotInfo1),
goal_util__rename_vars_in_goal(Construct, Subst,
NewConstruct),
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.50
diff -u -u -r1.50 simplify.m
--- simplify.m 1997/12/22 09:56:24 1.50
+++ simplify.m 1998/01/02 06:09:11
@@ -784,9 +784,10 @@
Goal = some(Vars, Goal3).
simplify__goal_2(Goal0, GoalInfo, Goal, GoalInfo, Info0, Info) :-
- Goal0 = pragma_c_code(_, _, PredId, ProcId, Args, _, _, _),
- ( simplify_do_calls(Info0),
- goal_info_is_pure(GoalInfo)
+ Goal0 = pragma_c_code(_, PredId, ProcId, Args, _, _, _),
+ (
+ simplify_do_calls(Info0),
+ goal_info_is_pure(GoalInfo)
->
common__optimise_call(PredId, ProcId, Args, Goal0,
GoalInfo, Goal, Info0, Info)
@@ -1597,7 +1598,7 @@
Goal = GoalExpr - _,
GoalExpr \= call(_, _, _, _, _, _),
GoalExpr \= higher_order_call(_, _, _, _, _, _),
- GoalExpr \= pragma_c_code(_, _, _, _, _, _, _, _)
+ GoalExpr \= pragma_c_code(_, _, _, _, _, _, _)
)
->
simplify_info_get_common_info(Info0, CommonInfo0),
Index: compiler/store_alloc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/store_alloc.m,v
retrieving revision 1.56
diff -u -u -r1.56 store_alloc.m
--- store_alloc.m 1997/12/19 03:08:12 1.56
+++ store_alloc.m 1998/01/02 07:15:04
@@ -177,8 +177,8 @@
store_alloc_in_goal_2(unify(A,B,C,D,E), Liveness, _, _,
unify(A,B,C,D,E), Liveness).
-store_alloc_in_goal_2(pragma_c_code(A, B, C, D, E, F, G, H), Liveness, _, _,
- pragma_c_code(A, B, C, D, E, F, G, H), Liveness).
+store_alloc_in_goal_2(pragma_c_code(A, B, C, D, E, F, G), Liveness, _, _,
+ pragma_c_code(A, B, C, D, E, F, G), Liveness).
%-----------------------------------------------------------------------------%
Index: compiler/stratify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stratify.m,v
retrieving revision 1.12
diff -u -u -r1.12 stratify.m
--- stratify.m 1997/12/19 03:08:15 1.12
+++ stratify.m 1998/01/02 04:43:23
@@ -37,7 +37,6 @@
:- import_module hlds_module, io.
-
% Perform stratification analysis, for the given module.
% If the "warn-non-stratification" option is set this
% pred will check the entire module for stratification
@@ -49,7 +48,6 @@
io__state, io__state).
:- mode stratify__check_stratification(in, out, di, uo) is det.
-
:- implementation.
:- import_module dependency_graph, hlds_pred, hlds_goal, hlds_data.
@@ -58,8 +56,6 @@
:- import_module assoc_list, map, list, set, bool, std_util, relation, require.
-
-
stratify__check_stratification(Module0, Module) -->
{ module_info_ensure_dependency_info(Module0, Module1) },
{ module_info_dependency_info(Module1, DepInfo) },
@@ -81,8 +77,6 @@
%{ dep_sets_to_lists_and_sets(HOSCCs1, [], HOSCCs) },
%higher_order_check_sccs(HOSCCs, HOInfo, Module2, Module).
-
-
%-----------------------------------------------------------------------------%
:- pred dep_sets_to_lists_and_sets(list(set(pred_proc_id)),
@@ -186,7 +180,7 @@
WholeScc, ThisPredProcId, Error, Module0, Module) -->
first_order_check_goal(Goal, GoalInfo, yes, WholeScc, ThisPredProcId,
Error, Module0, Module).
-first_order_check_goal(pragma_c_code(_, _IsRec, CPred, CProc, _, _, _, _),
+first_order_check_goal(pragma_c_code(_IsRec, CPred, CProc, _, _, _, _),
GoalInfo, Negated, WholeScc, ThisPredProcId,
Error, Module0, Module) -->
(
@@ -372,7 +366,7 @@
ThisPredProcId, HighOrderLoops, Error, Module0, Module) -->
higher_order_check_goal(Goal, GoalInfo, yes, WholeScc, ThisPredProcId,
HighOrderLoops, Error, Module0, Module).
-higher_order_check_goal(pragma_c_code(_, _IsRec, _, _, _, _, _, _), _GoalInfo,
+higher_order_check_goal(pragma_c_code(_IsRec, _, _, _, _, _, _), _GoalInfo,
_Negated, _WholeScc, _ThisPredProcId, _HighOrderLoops,
_, Module, Module) --> [].
higher_order_check_goal(unify(_Var, _RHS, _Mode, _Uni, _Context), _GoalInfo,
@@ -505,7 +499,6 @@
map__to_assoc_list(HOInfo, HOInfoL),
add_new_arcs(HOInfoL, CallsHO, DepGraph0, DepGraph).
-
% For a given module collects for each non imported proc a set
% of called procs and a higher order info structure. This pred
% also returns a set of all non imported procs that make a
@@ -521,7 +514,6 @@
expand_predids(PredIds, Module, ProcCalls0, ProcCalls, HOInfo0,
HOInfo, CallsHO0, CallsHO).
-
% find the transitive closure of a given list of procs
% this pred is used to see how face a higher order address can
% reach though proc calls
@@ -554,7 +546,6 @@
Changed0, Changed1),
tc(Ps, ProcCalls, CallsHO, HOInfo1, HOInfo, Changed1, Changed).
-
% merge any higher order addresses that can pass between the
% given caller and callees. This code also merges any possible
% addresses that can pass in and out of higher order calls
@@ -650,7 +641,6 @@
Changed0, Changed)
).
-
% given the set of procs that make higher order calls and a
% list of procs and higher order call info this pred rebuilds
% the given call graph with new arcs for every possible higher
@@ -685,8 +675,6 @@
relation__add(DepGraph0, CallerKey, CalleeKey, DepGraph1),
add_new_arcs2(Cs, CallerKey, DepGraph1, DepGraph).
-
-
% for each given pred id pass all non imported procs onto the
% process_procs pred
:- pred expand_predids(list(pred_id), module_info, call_map, call_map,
@@ -705,7 +693,6 @@
expand_predids(PredIds, Module, ProcCalls1, ProcCalls, HOInfo1,
HOInfo, CallsHO1, CallsHO).
-
% for each given proc id generate the set of procs it calls and
% its higher order info structure
:- pred process_procs(list(proc_id), module_info, pred_id, list(type),
@@ -736,7 +723,6 @@
process_procs(Procs, Module, PredId, ArgTypes, ProcTable, ProcCalls1,
ProcCalls, HOInfo1, HOInfo, CallsHO1, CallsHO).
-
% determine if a given set of modes and types indicates that
% higher order values can be passed into and/or out of a proc
:- pred higherorder_in_out(list(type), list(mode), module_info, ho_in_out).
@@ -791,7 +777,6 @@
),
higherorder_in_out1(Types, Modes, Module, HOIn1, HOIn, HOOut1, HOOut).
-
% return the set of all procs called in and all addresses
% taken, in a given goal
:- pred check_goal(hlds_goal_expr, set(pred_proc_id), set(pred_proc_id),
@@ -878,9 +863,8 @@
CallsHO) :-
check_goal1(Goal, Calls0, Calls, HasAT0, HasAT, CallsHO0, CallsHO).
-check_goal1(pragma_c_code(_, _IsRec, _CPred, _CProc, _, _, _, _), Calls, Calls,
+check_goal1(pragma_c_code(_IsRec, _CPred, _CProc, _, _, _, _), Calls, Calls,
HasAT, HasAT, CallsHO, CallsHO).
-
:- pred check_goal_list(list(hlds_goal), set(pred_proc_id), set(pred_proc_id),
set(pred_proc_id), set(pred_proc_id), bool, bool).
@@ -903,7 +887,6 @@
check_goal1(Goal, Calls0, Calls1, HasAT0, HasAT1, CallsHO0, CallsHO1),
check_case_list(Goals, Calls1, Calls, HasAT1, HasAT, CallsHO1, CallsHO).
-
% This pred returns a list of all the calls in a given set of
% goals including calls in unification lambda functions and
% pred_proc_id's in constructs
@@ -943,7 +926,6 @@
Calls = Calls0
).
-
% add this call to the call list
get_called_procs(call(CPred, CProc, _Args, _Builtin, _Contex, _Sym), Calls0,
Calls) :-
@@ -955,7 +937,6 @@
get_called_procs(class_method_call(_Var, _Num,_Vars, _Types, _Modes, _Det),
Calls, Calls).
-
get_called_procs(conj(Goals), Calls0, Calls) :-
check_goal_list(Goals, Calls0, Calls).
get_called_procs(disj(Goals, _Follow), Calls0, Calls) :-
@@ -971,10 +952,9 @@
get_called_procs(Goal, Calls0, Calls).
get_called_procs(not(Goal - _GoalInfo), Calls0, Calls) :-
get_called_procs(Goal, Calls0, Calls).
-get_called_procs(pragma_c_code(_, _IsRec, _CPred, _CProc, _, _, _, _),
+get_called_procs(pragma_c_code(_IsRec, _CPred, _CProc, _, _, _, _),
Calls, Calls).
-
:- pred check_goal_list(list(hlds_goal), list(pred_proc_id),
list(pred_proc_id)).
:- mode check_goal_list(in, in, out) is det.
@@ -995,8 +975,6 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-
-
:- pred emit_message(pred_proc_id, term__context, string, bool,
module_info, module_info, io__state, io__state).
Index: compiler/switch_detection.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_detection.m,v
retrieving revision 1.77
diff -u -u -r1.77 switch_detection.m
--- switch_detection.m 1997/12/19 03:08:17 1.77
+++ switch_detection.m 1998/01/02 04:43:36
@@ -190,8 +190,8 @@
VarTypes, ModuleInfo, switch(Var, CanFail, Cases, SM)) :-
detect_switches_in_cases(Cases0, InstMap, VarTypes, ModuleInfo, Cases).
-detect_switches_in_goal_2(pragma_c_code(A,B,C,D,E,F,G,H), _, _, _, _,
- pragma_c_code(A,B,C,D,E,F,G,H)).
+detect_switches_in_goal_2(pragma_c_code(A,B,C,D,E,F,G), _, _, _, _,
+ pragma_c_code(A,B,C,D,E,F,G)).
%-----------------------------------------------------------------------------%
Index: compiler/term_traversal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_traversal.m,v
retrieving revision 1.1
diff -u -u -r1.1 term_traversal.m
--- term_traversal.m 1997/12/22 09:56:32 1.1
+++ term_traversal.m 1998/01/02 04:43:44
@@ -179,7 +179,7 @@
traverse_goal(Else, Params, Info0, Info2),
combine_paths(Info1, Info2, Params, Info).
-traverse_goal_2(pragma_c_code(_, _, CallPredId, CallProcId, Args, _, _, _),
+traverse_goal_2(pragma_c_code(_, CallPredId, CallProcId, Args, _, _, _),
GoalInfo, Params, Info0, Info) :-
params_get_module_info(Params, Module),
module_info_pred_proc_info(Module, CallPredId, CallProcId, _,
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.224
diff -u -u -r1.224 typecheck.m
--- typecheck.m 1998/01/02 00:10:51 1.224
+++ typecheck.m 1998/01/02 04:44:05
@@ -762,8 +762,7 @@
typecheck_goal_2(switch(_, _, _, _), _) -->
{ error("unexpected switch") }.
% no need to typecheck pragmas
-typecheck_goal_2(pragma_c_code(A,B,C,D,E,F,G,H),
- pragma_c_code(A,B,C,D,E,F,G,H))
+typecheck_goal_2(pragma_c_code(A,B,C,D,E,F,G), pragma_c_code(A,B,C,D,E,F,G))
--> [].
%-----------------------------------------------------------------------------%
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unique_modes.m,v
retrieving revision 1.43
diff -u -u -r1.43 unique_modes.m
--- unique_modes.m 1998/01/05 07:26:22 1.43
+++ unique_modes.m 1998/01/08 03:08:54
@@ -423,14 +423,14 @@
% to modecheck a pragma_c_code, we just modecheck the proc for
% which it is the goal.
-unique_modes__check_goal_2(pragma_c_code(IsRecursive, C_Code, PredId, ProcId0,
- Args, ArgNameMap, OrigArgTypes, ExtraPragmaInfo),
+unique_modes__check_goal_2(pragma_c_code(IsRecursive, PredId, ProcId0,
+ Args, ArgNameMap, OrigArgTypes, PragmaCode),
_GoalInfo, Goal) -->
mode_checkpoint(enter, "pragma_c_code"),
mode_info_set_call_context(call(PredId)),
unique_modes__check_call(PredId, ProcId0, Args, ProcId),
- { Goal = pragma_c_code(IsRecursive, C_Code, PredId, ProcId, Args,
- ArgNameMap, OrigArgTypes, ExtraPragmaInfo) },
+ { Goal = pragma_c_code(IsRecursive, PredId, ProcId, Args,
+ ArgNameMap, OrigArgTypes, PragmaCode) },
mode_info_unset_call_context,
mode_checkpoint(exit, "pragma_c_code").
Index: compiler/unused_args.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.39
diff -u -u -r1.39 unused_args.m
--- unused_args.m 1997/12/22 09:56:39 1.39
+++ unused_args.m 1998/01/02 06:09:28
@@ -444,7 +444,7 @@
set_list_vars_used(UseInf0, [PredVar|Args], UseInf).
% handle pragma(c_code, ...) - pragma_c_code uses all its args
-traverse_goal(_, pragma_c_code(_, _, _, _, Args, _, _, _), UseInf0, UseInf) :-
+traverse_goal(_, pragma_c_code(_, _, _, Args, _, _, _), UseInf0, UseInf) :-
set_list_vars_used(UseInf0, Args, UseInf).
% cases to handle all the different types of unification
@@ -1246,7 +1246,7 @@
fixup_goal_expr(_ModuleInfo, _UnusedVars, _ProcCallInfo, no,
GoalExpr - GoalInfo, GoalExpr - GoalInfo) :-
- GoalExpr = pragma_c_code(_, _, _, _, _, _, _, _).
+ GoalExpr = pragma_c_code(_, _, _, _, _, _, _).
% Remove useless unifications from a list of conjuncts.
:- pred fixup_conjuncts(module_info::in, list(var)::in, proc_call_info::in,
Index: compiler/value_number.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/value_number.m,v
retrieving revision 1.88
diff -u -u -r1.88 value_number.m
--- value_number.m 1997/12/22 06:58:44 1.88
+++ value_number.m 1998/01/06 08:24:03
@@ -172,7 +172,7 @@
Target = succfr(_)
)
;
- Uinstr0 = mkframe(_, _, _)
+ Uinstr0 = mkframe(_, _, _, _)
)
->
N1 is N0 + 1,
@@ -1075,7 +1075,7 @@
value_number__boundary_instr(block(_, _, _), no).
value_number__boundary_instr(assign(_,_), no).
value_number__boundary_instr(call(_, _, _, _), yes).
-value_number__boundary_instr(mkframe(_, _, _), yes).
+value_number__boundary_instr(mkframe(_, _, _, _), yes).
value_number__boundary_instr(modframe(_), yes).
value_number__boundary_instr(label(_), yes).
value_number__boundary_instr(goto(_), yes).
@@ -1092,7 +1092,7 @@
value_number__boundary_instr(discard_tickets_to(_), no).
value_number__boundary_instr(incr_sp(_, _), yes).
value_number__boundary_instr(decr_sp(_), yes).
-value_number__boundary_instr(pragma_c(_, _, _, _, _), yes).
+value_number__boundary_instr(pragma_c(_, _, _, _), yes).
%-----------------------------------------------------------------------------%
Index: compiler/vn_block.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_block.m,v
retrieving revision 1.50
diff -u -u -r1.50 vn_block.m
--- vn_block.m 1997/12/05 15:48:02 1.50
+++ vn_block.m 1998/01/06 08:15:33
@@ -229,10 +229,10 @@
vn_block__new_ctrl_node(vn_call(Proc, Return, Info, CallModel), Livemap,
Params, VnTables0, VnTables,
Liveset0, Liveset, Tuple0, Tuple).
-vn_block__handle_instr(mkframe(Name, Size, Redoip), Livemap, Params,
+vn_block__handle_instr(mkframe(Name, Size, Pragma, Redoip), Livemap, Params,
VnTables0, VnTables, Liveset0, Liveset,
SeenIncr0, SeenIncr, Tuple0, Tuple) :-
- vn_block__new_ctrl_node(vn_mkframe(Name, Size, Redoip),
+ vn_block__new_ctrl_node(vn_mkframe(Name, Size, Pragma, Redoip),
Livemap, Params, VnTables0, VnTables1,
Liveset0, Liveset1, Tuple0, Tuple1),
vn_block__handle_instr(assign(redoip(lval(maxfr)),
@@ -353,7 +353,7 @@
vn_block__new_ctrl_node(vn_decr_sp(N), Livemap,
Params, VnTables0, VnTables,
Liveset0, Liveset, Tuple0, Tuple).
-vn_block__handle_instr(pragma_c(_, _, _, _, _),
+vn_block__handle_instr(pragma_c(_, _, _, _),
_Livemap, _Params, VnTables, VnTables, Liveset, Liveset,
SeenIncr, SeenIncr, Tuple, Tuple) :-
error("value numbering not supported for pragma_c").
@@ -388,7 +388,7 @@
LabelNo = LabelNo0,
Parallels = []
;
- VnInstr = vn_mkframe(_, _, _),
+ VnInstr = vn_mkframe(_, _, _, _),
VnTables = VnTables0,
Liveset = Liveset0,
FlushEntry = FlushEntry0,
@@ -874,7 +874,7 @@
vn_block__is_ctrl_instr(block(_, _, _), no).
vn_block__is_ctrl_instr(assign(_, _), no).
vn_block__is_ctrl_instr(call(_, _, _, _), yes).
-vn_block__is_ctrl_instr(mkframe(_, _, _), yes).
+vn_block__is_ctrl_instr(mkframe(_, _, _, _), yes).
vn_block__is_ctrl_instr(modframe(_), no).
vn_block__is_ctrl_instr(label(_), yes).
vn_block__is_ctrl_instr(goto(_), yes).
@@ -891,7 +891,7 @@
vn_block__is_ctrl_instr(discard_tickets_to(_), yes).
vn_block__is_ctrl_instr(incr_sp(_, _), yes).
vn_block__is_ctrl_instr(decr_sp(_), yes).
-vn_block__is_ctrl_instr(pragma_c(_, _, _, _, _), no).
+vn_block__is_ctrl_instr(pragma_c(_, _, _, _), no).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/vn_cost.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_cost.m,v
retrieving revision 1.29
diff -u -u -r1.29 vn_cost.m
--- vn_cost.m 1997/12/05 15:48:05 1.29
+++ vn_cost.m 1998/01/06 08:15:39
@@ -111,7 +111,7 @@
Uinstr = call(_, _, _, _),
Cost = 0
;
- Uinstr = mkframe(_, _, _),
+ Uinstr = mkframe(_, _, _, _),
Cost = 0
;
Uinstr = modframe(_),
@@ -181,7 +181,7 @@
Uinstr = decr_sp(_),
Cost = 0
;
- Uinstr = pragma_c(_, _, _, _, _),
+ Uinstr = pragma_c(_, _, _, _),
error("pragma_c found in vn_block_cost")
).
Index: compiler/vn_filter.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_filter.m,v
retrieving revision 1.13
diff -u -u -r1.13 vn_filter.m
--- vn_filter.m 1997/12/05 15:48:06 1.13
+++ vn_filter.m 1998/01/06 08:15:56
@@ -136,7 +136,7 @@
error("inappropriate instruction in vn__filter").
vn_filter__user_instr(assign(_, Rval), yes(Rval)).
vn_filter__user_instr(call(_, _, _, _), no).
-vn_filter__user_instr(mkframe(_, _, _), no).
+vn_filter__user_instr(mkframe(_, _, _, _), no).
vn_filter__user_instr(modframe(_), no).
vn_filter__user_instr(label(_), no).
vn_filter__user_instr(goto(_), no).
@@ -154,7 +154,7 @@
vn_filter__user_instr(discard_tickets_to(Rval), yes(Rval)).
vn_filter__user_instr(incr_sp(_, _), no).
vn_filter__user_instr(decr_sp(_), no).
-vn_filter__user_instr(pragma_c(_, _, _, _, _), _):-
+vn_filter__user_instr(pragma_c(_, _, _, _), _):-
error("inappropriate instruction in vn__filter").
% vn_filter__replace_in_user_instr(Instr0, Old, New, Instr):
@@ -176,7 +176,7 @@
vn_filter__replace_in_rval(Rval0, Temp, Defn, Rval).
vn_filter__replace_in_user_instr(call(_, _, _, _), _, _, _) :-
error("non-user instruction in vn_filter__replace_in_user_instr").
-vn_filter__replace_in_user_instr(mkframe(_, _, _), _, _, _) :-
+vn_filter__replace_in_user_instr(mkframe(_, _, _, _), _, _, _) :-
error("non-user instruction in vn_filter__replace_in_user_instr").
vn_filter__replace_in_user_instr(modframe(_), _, _, _) :-
error("non-user instruction in vn_filter__replace_in_user_instr").
@@ -216,7 +216,7 @@
error("non-user instruction in vn_filter__replace_in_user_instr").
vn_filter__replace_in_user_instr(decr_sp(_), _, _, _) :-
error("non-user instruction in vn_filter__replace_in_user_instr").
-vn_filter__replace_in_user_instr(pragma_c(_, _, _, _, _), _, _, _):-
+vn_filter__replace_in_user_instr(pragma_c(_, _, _, _), _, _, _):-
error("inappropriate instruction in vn__filter").
% Check whether this instruction defines the value of any lval.
@@ -230,7 +230,7 @@
error("inappropriate instruction in vn__filter").
vn_filter__defining_instr(assign(Lval, _), yes(Lval)).
vn_filter__defining_instr(call(_, _, _, _), no).
-vn_filter__defining_instr(mkframe(_, _, _), no).
+vn_filter__defining_instr(mkframe(_, _, _, _), no).
vn_filter__defining_instr(modframe(_), no).
vn_filter__defining_instr(label(_), no).
vn_filter__defining_instr(goto(_), no).
@@ -248,7 +248,7 @@
vn_filter__defining_instr(discard_tickets_to(_), no).
vn_filter__defining_instr(incr_sp(_, _), no).
vn_filter__defining_instr(decr_sp(_), no).
-vn_filter__defining_instr(pragma_c(_, _, _, _, _), _):-
+vn_filter__defining_instr(pragma_c(_, _, _, _), _):-
error("inappropriate instruction in vn__filter").
% vn_filter__replace_in_defining_instr(Instr0, Old, New, Instr):
@@ -270,7 +270,7 @@
vn_filter__replace_in_lval(Lval0, Temp, Defn, Lval).
vn_filter__replace_in_defining_instr(call(_, _, _, _), _, _, _) :-
error("non-def instruction in vn_filter__replace_in_defining_instr").
-vn_filter__replace_in_defining_instr(mkframe(_, _, _), _, _, _) :-
+vn_filter__replace_in_defining_instr(mkframe(_, _, _, _), _, _, _) :-
error("non-def instruction in vn_filter__replace_in_defining_instr").
vn_filter__replace_in_defining_instr(modframe(_), _, _, _) :-
error("non-def instruction in vn_filter__replace_in_defining_instr").
@@ -308,7 +308,7 @@
error("non-def instruction in vn_filter__replace_in_defining_instr").
vn_filter__replace_in_defining_instr(decr_sp(_), _, _, _) :-
error("non-def instruction in vn_filter__replace_in_defining_instr").
-vn_filter__replace_in_defining_instr(pragma_c(_, _, _, _, _), _, _, _):-
+vn_filter__replace_in_defining_instr(pragma_c(_, _, _, _), _, _, _):-
error("inappropriate instruction in vn__filter").
% vn_filter__replace_in_lval(Lval0, Old, New, Lval):
Index: compiler/vn_flush.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_flush.m,v
retrieving revision 1.44
diff -u -u -r1.44 vn_flush.m
--- vn_flush.m 1997/12/05 15:48:09 1.44
+++ vn_flush.m 1998/01/05 08:25:10
@@ -190,7 +190,7 @@
Templocs = Templocs0,
Instrs = [call(ProcAddr, RetAddr, LiveInfo, CodeModel) - ""]
;
- Vn_instr = vn_mkframe(Name, Size, Redoip),
+ Vn_instr = vn_mkframe(Name, Size, Pragma, Redoip),
vn_util__rval_to_vn(const(code_addr_const(Redoip)), AddrVn,
VnTables0, VnTables1),
vn_util__lval_to_vnlval(redoip(lval(maxfr)), SlotVnlval,
@@ -198,7 +198,7 @@
vn_table__set_current_value(SlotVnlval, AddrVn,
VnTables2, VnTables),
Templocs = Templocs0,
- Instrs = [mkframe(Name, Size, Redoip) - ""]
+ Instrs = [mkframe(Name, Size, Pragma, Redoip) - ""]
;
Vn_instr = vn_label(Label),
VnTables = VnTables0,
Index: compiler/vn_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_order.m,v
retrieving revision 1.43
diff -u -u -r1.43 vn_order.m
--- vn_order.m 1997/12/05 15:48:11 1.43
+++ vn_order.m 1998/01/01 06:23:52
@@ -328,7 +328,7 @@
Predmap1 = Predmap0,
VnTables1 = VnTables0
;
- Vn_instr = vn_mkframe(_, _, _),
+ Vn_instr = vn_mkframe(_, _, _, _),
Succmap1 = Succmap0,
Predmap1 = Predmap0,
VnTables1 = VnTables0
Index: compiler/vn_type.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_type.m,v
retrieving revision 1.36
diff -u -u -r1.36 vn_type.m
--- vn_type.m 1997/12/22 06:58:47 1.36
+++ vn_type.m 1998/01/05 08:29:11
@@ -70,7 +70,8 @@
:- type vn_instr ---> vn_livevals(lvalset)
; vn_call(code_addr, code_addr,
list(liveinfo), call_model)
- ; vn_mkframe(string, int, code_addr)
+ ; vn_mkframe(string, int, maybe(pragma_struct),
+ code_addr)
; vn_label(label)
; vn_goto(code_addr)
; vn_computed_goto(vn, list(label))
Index: compiler/vn_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_util.m,v
retrieving revision 1.58
diff -u -u -r1.58 vn_util.m
--- vn_util.m 1997/12/05 15:48:14 1.58
+++ vn_util.m 1998/01/01 06:23:58
@@ -1219,7 +1219,7 @@
VnInstr = vn_call(_, _, _, _),
VnTables1 = VnTables0
;
- VnInstr = vn_mkframe(_, _, _),
+ VnInstr = vn_mkframe(_, _, _, _),
VnTables1 = VnTables0
;
VnInstr = vn_label(_),
Index: compiler/vn_verify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_verify.m,v
retrieving revision 1.14
diff -u -u -r1.14 vn_verify.m
--- vn_verify.m 1997/12/05 15:48:16 1.14
+++ vn_verify.m 1998/01/06 08:16:01
@@ -298,7 +298,7 @@
NoDeref = NoDeref0,
Tested = Tested0
;
- Instr = mkframe(_, _, _),
+ Instr = mkframe(_, _, _, _),
NoDeref = NoDeref0,
Tested = Tested0
;
@@ -373,7 +373,7 @@
NoDeref = NoDeref0,
Tested = Tested0
;
- Instr = pragma_c(_, _, _, _, _),
+ Instr = pragma_c(_, _, _, _),
error("found c_code in vn_verify__tags_instr")
).
cvs diff: Diffing compiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
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/graphics
cvs diff: Diffing extras/graphics/Togl-1.2
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing library
cvs diff: Diffing lp_solve
cvs diff: Diffing lp_solve/lp_examples
cvs diff: Diffing profiler
cvs diff: Diffing runtime
Index: runtime/mercury_stacks.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_stacks.h,v
retrieving revision 1.2
diff -u -u -r1.2 mercury_stacks.h
--- mercury_stacks.h 1997/11/23 07:21:35 1.2
+++ mercury_stacks.h 1998/01/05 10:50:31
@@ -108,16 +108,15 @@
#define mkframe_save_prednm(prednm) /* nothing */
#endif
-
-#define mkframe(prednm, numslots, redoip) \
+#define mkframe(prednm, numslots, redoip) \
do { \
reg Word *prevfr; \
reg Word *succfr; \
\
- prevfr = MR_maxfr; \
- succfr = MR_curfr; \
+ prevfr = MR_maxfr; \
+ succfr = MR_curfr; \
MR_maxfr += (NONDET_FIXED_SIZE + numslots);\
- MR_curfr = MR_maxfr; \
+ MR_curfr = MR_maxfr; \
curredoip = redoip; \
curprevfr = prevfr; \
cursuccip = MR_succip; \
@@ -127,7 +126,24 @@
nondstack_overflow_check(); \
} while (0)
-
+#define mkpragmaframe(prednm, numslots, structname, redoip) \
+ do { \
+ reg Word *prevfr; \
+ reg Word *succfr; \
+ \
+ prevfr = MR_maxfr; \
+ succfr = MR_curfr; \
+ MR_maxfr += (NONDET_FIXED_SIZE + numslots \
+ + sizeof(struct structname)); \
+ MR_curfr = MR_maxfr; \
+ curredoip = redoip; \
+ curprevfr = prevfr; \
+ cursuccip = MR_succip; \
+ cursuccfr = succfr; \
+ mkframe_save_prednm(prednm); \
+ debugmkframe(); \
+ nondstack_overflow_check(); \
+ } while (0)
#define modframe(redoip) \
do { \
@@ -135,7 +151,6 @@
debugmodframe(); \
} while (0)
-
#define succeed() do { \
reg Word *childfr; \
\
@@ -156,7 +171,6 @@
GOTO(bt_succip(childfr)); \
} while (0)
-
#define fail() do { \
debugfail(); \
MR_maxfr = curprevfr; \
@@ -164,7 +178,6 @@
nondstack_underflow_check(); \
GOTO(curredoip); \
} while (0)
-
#define redo() do { \
debugredo(); \
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/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/general
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trial
cvs diff: Diffing util
More information about the developers
mailing list