mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-12 20:34:19 +00:00
Add support for the MLDS back-end (i.e. the `--high-level-code'
Estimated hours taken: 10 Add support for the MLDS back-end (i.e. the `--high-level-code' option) to various parts of the standard library. library/benchmarking.m: Add `#ifndef MR_HIGHLEVEL_CODE' to ifdef out the parts of `report_stats' which depend on the details of the low-level execution model. Rewrite benchmark_det and benchmark_nondet using impure Mercury with `pragma c_code' fragments, rather than using low-level C code. The low-level C code was a maintenance problem (e.g. I don't think it was restoring the MR_ticket_counter properly in trailing grades) and this way avoids the need to duplicate the hand-written code for the MLDS back-end. library/exception.m: Implement exception handling for the MLDS back-end, using setjmp() and longjmp(). library/math.m: Add `#ifndef MR_HIGHLEVEL_CODE' around the call to MR_dump_stack(), since that code requires the low-level execution model. library/gc.m: Add `#ifndef MR_HIGHLEVEL_CODE' around the calls to MR_clear_zone_for_GC(), since they depend on the details of the low-level execution model and are not required for --high-level-code.
This commit is contained in:
Fergus Henderson
@@ -15,7 +15,6 @@
|
||||
%-----------------------------------------------------------------------------%
|
||||
|
||||
:- module benchmarking.
|
||||
|
||||
:- interface.
|
||||
|
||||
% `report_stats' is a non-logical procedure intended for use in profiling
|
||||
@@ -53,7 +52,10 @@
|
||||
:- mode benchmark_nondet(pred(in, out) is nondet, in, out, in, out)
|
||||
is cc_multi.
|
||||
|
||||
%-----------------------------------------------------------------------------%
|
||||
|
||||
:- implementation.
|
||||
:- import_module int, std_util.
|
||||
|
||||
:- pragma c_header_code("
|
||||
|
||||
@@ -139,7 +141,9 @@ void
|
||||
ML_report_stats(void)
|
||||
{
|
||||
int time_at_prev_stat;
|
||||
#ifndef MR_HIGHLEVEL_CODE
|
||||
MercuryEngine *eng;
|
||||
#endif
|
||||
#ifdef PROFILE_MEMORY
|
||||
int num_table_entries;
|
||||
ML_memprof_report_entry table[MEMORY_PROFILE_SIZE];
|
||||
@@ -152,17 +156,24 @@ ML_report_stats(void)
|
||||
time_at_prev_stat = time_at_last_stat;
|
||||
time_at_last_stat = MR_get_user_cpu_miliseconds();
|
||||
|
||||
#ifdef MR_HIGHLEVEL_CODE
|
||||
eng = MR_get_engine();
|
||||
#endif
|
||||
|
||||
fprintf(stderr,
|
||||
""[Time: +%.3fs, %.3fs, D Stack: %.3fk, ND Stack: %.3fk,"",
|
||||
""[Time: +%.3fs, %.3fs,"",
|
||||
(time_at_last_stat - time_at_prev_stat) / 1000.0,
|
||||
(time_at_last_stat - time_at_start) / 1000.0,
|
||||
(time_at_last_stat - time_at_start) / 1000.0
|
||||
);
|
||||
|
||||
#ifndef MR_HIGHLEVEL_CODE
|
||||
fprintf(stderr, "" D Stack: %.3fk, ND Stack: %.3fk,"",
|
||||
((char *) MR_sp - (char *)
|
||||
eng->context.detstack_zone->min) / 1024.0,
|
||||
((char *) MR_maxfr - (char *)
|
||||
eng->context.nondetstack_zone->min) / 1024.0
|
||||
);
|
||||
#endif
|
||||
|
||||
#ifdef CONSERVATIVE_GC
|
||||
{ char local_var;
|
||||
@@ -539,255 +550,107 @@ ML_memory_profile_compare_final(const void *i1, const void *i2)
|
||||
|
||||
%-----------------------------------------------------------------------------%
|
||||
|
||||
:- external(benchmark_det/5).
|
||||
:- external(benchmark_nondet/5).
|
||||
:- pragma promise_pure(benchmark_det/5).
|
||||
benchmark_det(Pred, In, Out, Repeats, Time) :-
|
||||
impure get_user_cpu_miliseconds(StartTime),
|
||||
impure benchmark_det_loop(Pred, In, Out, Repeats),
|
||||
impure get_user_cpu_miliseconds(EndTime),
|
||||
Time0 = StartTime - EndTime,
|
||||
cc_multi_equal(Time0, Time).
|
||||
|
||||
:- pragma c_code("
|
||||
:- impure pred benchmark_det_loop(pred(T1, T2), T1, T2, int).
|
||||
:- mode benchmark_det_loop(pred(in, out) is det, in, out, in) is det.
|
||||
|
||||
benchmark_det_loop(Pred, In, Out, Repeats) :-
|
||||
% The call to do_nothing/1 here is to make sure the compiler
|
||||
% doesn't optimize away the call to `Pred'.
|
||||
Pred(In, Out0),
|
||||
impure do_nothing(Out0),
|
||||
( Repeats > 1 ->
|
||||
impure benchmark_det_loop(Pred, In, Out, Repeats - 1)
|
||||
;
|
||||
Out = Out0
|
||||
).
|
||||
|
||||
:- pragma promise_pure(benchmark_nondet/5).
|
||||
benchmark_nondet(Pred, In, Count, Repeats, Time) :-
|
||||
impure get_user_cpu_miliseconds(StartTime),
|
||||
impure benchmark_nondet_loop(Pred, In, Count, Repeats),
|
||||
impure get_user_cpu_miliseconds(EndTime),
|
||||
Time0 = StartTime - EndTime,
|
||||
cc_multi_equal(Time0, Time).
|
||||
|
||||
:- impure pred benchmark_nondet_loop(pred(T1, T2), T1, int, int).
|
||||
:- mode benchmark_nondet_loop(pred(in, out) is nondet, in, out, in) is det.
|
||||
|
||||
benchmark_nondet_loop(Pred, In, Count, Repeats) :-
|
||||
impure new_int_reference(0, SolutionCounter),
|
||||
(
|
||||
impure repeat(Repeats),
|
||||
impure update_ref(SolutionCounter, 0),
|
||||
Pred(In, Out0),
|
||||
impure do_nothing(Out0),
|
||||
impure incr_ref(SolutionCounter),
|
||||
fail
|
||||
;
|
||||
true
|
||||
),
|
||||
semipure ref_value(SolutionCounter, Count).
|
||||
|
||||
:- impure pred repeat(int::in) is nondet.
|
||||
repeat(N) :-
|
||||
N > 0,
|
||||
( true ; impure repeat(N - 1) ).
|
||||
|
||||
:- impure pred get_user_cpu_miliseconds(int::out) is det.
|
||||
:- pragma c_code(get_user_cpu_miliseconds(Time::out), [will_not_call_mercury],
|
||||
"
|
||||
Time = MR_get_user_cpu_miliseconds();
|
||||
").
|
||||
|
||||
/*
|
||||
INIT mercury_benchmarking_init_benchmark
|
||||
ENDINIT
|
||||
** To prevent the C compiler from optimizing the benchmark code
|
||||
** away, we assign the benchmark output to a volatile global variable.
|
||||
*/
|
||||
|
||||
/*
|
||||
** :- pred benchmark_nondet(pred(T1, T2), T1, int, int, int).
|
||||
** :- mode benchmark_nondet(pred(in, out) is nondet, in, out, in, out) is det.
|
||||
**
|
||||
** :- pred benchmark_det(pred(T1, T2), T1, int, int, int).
|
||||
** :- mode benchmark_det(pred(in, out) is det, in, out, in, out) is det.
|
||||
**
|
||||
** Polymorphism will add two extra input parameters, type_infos for T1 and T2,
|
||||
** which we don't use. These will be in r1 and r2, while the closure will be
|
||||
** in r3, and the input data in r4. The repetition count will be in r5.
|
||||
**
|
||||
** The first output is a count of solutions for benchmark_nondet and the
|
||||
** actual solution for benchmark_det; the second output for both is the
|
||||
** time taken in milliseconds.
|
||||
*/
|
||||
|
||||
#ifdef MR_USE_TRAIL
|
||||
#define BENCHMARK_NONDET_STACK_SLOTS 7
|
||||
#else
|
||||
#define BENCHMARK_NONDET_STACK_SLOTS 6
|
||||
#endif
|
||||
|
||||
Define_extern_entry(mercury__benchmarking__benchmark_nondet_5_0);
|
||||
Declare_label(mercury__benchmarking__benchmark_nondet_5_0_i1);
|
||||
Declare_label(mercury__benchmarking__benchmark_nondet_5_0_i2);
|
||||
|
||||
MR_MAKE_PROC_LAYOUT(mercury__benchmarking__benchmark_nondet_5_0,
|
||||
MR_DETISM_NON, BENCHMARK_NONDET_STACK_SLOTS, MR_LONG_LVAL_TYPE_UNKNOWN,
|
||||
MR_PREDICATE, ""benchmarking"", ""benchmark_nondet"", 5, 0);
|
||||
MR_MAKE_INTERNAL_LAYOUT(mercury__benchmarking__benchmark_nondet_5_0, 1);
|
||||
MR_MAKE_INTERNAL_LAYOUT(mercury__benchmarking__benchmark_nondet_5_0, 2);
|
||||
|
||||
Declare_entry(mercury__do_call_closure);
|
||||
|
||||
BEGIN_MODULE(benchmark_nondet_module)
|
||||
init_entry_sl(mercury__benchmarking__benchmark_nondet_5_0);
|
||||
MR_INIT_PROC_LAYOUT_ADDR(mercury__benchmarking__benchmark_nondet_5_0);
|
||||
init_label_sl(mercury__benchmarking__benchmark_nondet_5_0_i1);
|
||||
init_label_sl(mercury__benchmarking__benchmark_nondet_5_0_i2);
|
||||
BEGIN_CODE
|
||||
|
||||
Define_entry(mercury__benchmarking__benchmark_nondet_5_0);
|
||||
|
||||
/*
|
||||
** Create a nondet stack frame. The contents of the slots:
|
||||
**
|
||||
** MR_framevar(1): the closure to be called.
|
||||
** MR_framevar(2): the input for the closure.
|
||||
** MR_framevar(3): the number of iterations left to be done.
|
||||
** MR_framevar(4): the number of solutions found so far.
|
||||
** MR_framevar(5): the time at entry to the first iteration.
|
||||
** MR_framevar(6): the saved heap pointer
|
||||
** MR_framevar(7): the saved trail pointer (if trailing enabled)
|
||||
**
|
||||
** We must make that the closure is called at least once,
|
||||
** otherwise the count we return isn't valid.
|
||||
*/
|
||||
|
||||
MR_mkframe(""benchmark_nondet"", BENCHMARK_NONDET_STACK_SLOTS,
|
||||
LABEL(mercury__benchmarking__benchmark_nondet_5_0_i2));
|
||||
|
||||
MR_framevar(1) = r3;
|
||||
MR_framevar(2) = r4;
|
||||
|
||||
/* r5 is the repetition count */
|
||||
if ((Integer) r5 <= 0) {
|
||||
MR_framevar(3) = 1;
|
||||
} else {
|
||||
MR_framevar(3) = r5;
|
||||
}
|
||||
|
||||
MR_framevar(4) = 0;
|
||||
mark_hp(MR_framevar(6));
|
||||
#ifdef MR_USE_TRAIL
|
||||
MR_framevar(7) = (Word) MR_trail_ptr;
|
||||
#endif
|
||||
MR_framevar(5) = MR_get_user_cpu_miliseconds();
|
||||
|
||||
/* call the higher-order pred closure that we were passed in r3 */
|
||||
r1 = r3;
|
||||
r2 = (Word) 1; /* the higher-order call has 1 extra input argument */
|
||||
r3 = (Word) 1; /* the higher-order call has 1 extra output argument */
|
||||
/* r4 already has the extra input argument */
|
||||
call(ENTRY(mercury__do_call_closure),
|
||||
LABEL(mercury__benchmarking__benchmark_nondet_5_0_i1),
|
||||
LABEL(mercury__benchmarking__benchmark_nondet_5_0));
|
||||
|
||||
Define_label(mercury__benchmarking__benchmark_nondet_5_0_i1);
|
||||
update_prof_current_proc(
|
||||
LABEL(mercury__benchmarking__benchmark_nondet_5_0));
|
||||
|
||||
/* we found a solution */
|
||||
MR_framevar(4) = MR_framevar(4) + 1;
|
||||
MR_redo();
|
||||
|
||||
Define_label(mercury__benchmarking__benchmark_nondet_5_0_i2);
|
||||
update_prof_current_proc(
|
||||
LABEL(mercury__benchmarking__benchmark_nondet_5_0));
|
||||
|
||||
/* no more solutions for this iteration, so mark it completed */
|
||||
MR_framevar(3) = MR_framevar(3) - 1;
|
||||
|
||||
/* we can now reclaim memory by resetting the heap pointer */
|
||||
restore_hp(MR_framevar(6));
|
||||
#ifdef MR_USE_TRAIL
|
||||
/* ... and the trail pointer */
|
||||
MR_trail_ptr = (MR_TrailEntry *) MR_framevar(7);
|
||||
#endif
|
||||
|
||||
/* are there any other iterations? */
|
||||
if (MR_framevar(3) > 0) {
|
||||
/* yes, so reset the solution counter */
|
||||
/* and then set up the call just like last time */
|
||||
MR_framevar(4) = 0;
|
||||
r1 = MR_framevar(1);
|
||||
r2 = (Word) 1;
|
||||
r3 = (Word) 1;
|
||||
r4 = MR_framevar(2);
|
||||
call(ENTRY(mercury__do_call_closure),
|
||||
LABEL(mercury__benchmarking__benchmark_nondet_5_0_i1),
|
||||
LABEL(mercury__benchmarking__benchmark_nondet_5_0));
|
||||
}
|
||||
|
||||
/* no more iterations */
|
||||
r1 = MR_framevar(4);
|
||||
r2 = MR_get_user_cpu_miliseconds() - MR_framevar(5);
|
||||
MR_succeed_discard();
|
||||
|
||||
END_MODULE
|
||||
|
||||
#undef BENCHMARK_NONDET_STACK_SLOTS
|
||||
|
||||
#ifdef MR_USE_TRAIL
|
||||
#define BENCHMARK_DET_STACK_SLOTS 7
|
||||
#else
|
||||
#define BENCHMARK_DET_STACK_SLOTS 6
|
||||
#endif
|
||||
|
||||
Define_extern_entry(mercury__benchmarking__benchmark_det_5_0);
|
||||
Declare_label(mercury__benchmarking__benchmark_det_5_0_i1);
|
||||
MR_MAKE_PROC_LAYOUT(mercury__benchmarking__benchmark_det_5_0,
|
||||
MR_DETISM_NON, BENCHMARK_DET_STACK_SLOTS, MR_LONG_LVAL_STACKVAR(6),
|
||||
MR_PREDICATE, ""benchmarking"", ""benchmark_nondet"", 5, 0);
|
||||
MR_MAKE_INTERNAL_LAYOUT(mercury__benchmarking__benchmark_det_5_0, 1);
|
||||
|
||||
BEGIN_MODULE(benchmark_det_module)
|
||||
init_entry_sl(mercury__benchmarking__benchmark_det_5_0);
|
||||
MR_INIT_PROC_LAYOUT_ADDR(mercury__benchmarking__benchmark_det_5_0);
|
||||
init_label_sl(mercury__benchmarking__benchmark_det_5_0_i1);
|
||||
BEGIN_CODE
|
||||
|
||||
Define_entry(mercury__benchmarking__benchmark_det_5_0);
|
||||
|
||||
/*
|
||||
** Create a det stack frame. The contents of the slots:
|
||||
**
|
||||
** MR_stackvar(1): the closure to be called.
|
||||
** MR_stackvar(2): the input for the closure.
|
||||
** MR_stackvar(3): the number of iterations left to be done.
|
||||
** MR_stackvar(4): the time at entry to the first iteration.
|
||||
** MR_stackvar(5): the saved heap pointer
|
||||
** MR_stackvar(6): the return address.
|
||||
** MR_stackvar(7): the saved trail pointer (if trailing enabled)
|
||||
**
|
||||
** We must make that the closure is called at least once,
|
||||
** otherwise the count we return isn't valid.
|
||||
*/
|
||||
|
||||
MR_incr_sp(BENCHMARK_DET_STACK_SLOTS);
|
||||
#ifdef MR_USE_TRAIL
|
||||
MR_stackvar(7) = (Word) MR_trail_ptr;
|
||||
#endif
|
||||
MR_stackvar(6) = (Word) MR_succip;
|
||||
mark_hp(MR_stackvar(5));
|
||||
|
||||
MR_stackvar(1) = r3;
|
||||
MR_stackvar(2) = r4;
|
||||
|
||||
/* r5 is the repetition count */
|
||||
if ((Integer) r5 <= 0) {
|
||||
MR_stackvar(3) = 1;
|
||||
} else {
|
||||
MR_stackvar(3) = r5;
|
||||
}
|
||||
|
||||
MR_stackvar(4) = MR_get_user_cpu_miliseconds();
|
||||
|
||||
/* call the higher-order pred closure that we were passed in r3 */
|
||||
r1 = r3;
|
||||
r2 = (Word) 1; /* the higher-order call has 1 extra input argument */
|
||||
r3 = (Word) 1; /* the higher-order call has 1 extra output argument */
|
||||
/* r4 already has the extra input argument */
|
||||
call(ENTRY(mercury__do_call_closure),
|
||||
LABEL(mercury__benchmarking__benchmark_det_5_0_i1),
|
||||
LABEL(mercury__benchmarking__benchmark_det_5_0));
|
||||
|
||||
Define_label(mercury__benchmarking__benchmark_det_5_0_i1);
|
||||
update_prof_current_proc(
|
||||
LABEL(mercury__benchmarking__benchmark_det_5_0));
|
||||
|
||||
/* mark current iteration completed */
|
||||
MR_stackvar(3) = MR_stackvar(3) - 1;
|
||||
|
||||
/* are there any other iterations? */
|
||||
if (MR_stackvar(3) > 0) {
|
||||
/* yes, so set up the call just like last time */
|
||||
#ifdef MR_USE_TRAIL
|
||||
/* Restore the trail... */
|
||||
MR_TrailEntry *old_trail_ptr = (MR_TrailEntry *) MR_stackvar(7);
|
||||
MR_untrail_to(old_trail_ptr, MR_undo);
|
||||
MR_trail_ptr = old_trail_ptr;
|
||||
#endif
|
||||
restore_hp(MR_stackvar(5));
|
||||
r1 = MR_stackvar(1);
|
||||
r2 = (Word) 1;
|
||||
r3 = (Word) 1;
|
||||
r4 = MR_stackvar(2);
|
||||
call(ENTRY(mercury__do_call_closure),
|
||||
LABEL(mercury__benchmarking__benchmark_det_5_0_i1),
|
||||
LABEL(mercury__benchmarking__benchmark_det_5_0));
|
||||
}
|
||||
|
||||
/* no more iterations */
|
||||
/* r1 already contains the right value */
|
||||
r2 = MR_get_user_cpu_miliseconds() - MR_stackvar(4);
|
||||
MR_succip = (Word *) MR_stackvar(6);
|
||||
MR_decr_sp(BENCHMARK_DET_STACK_SLOTS);
|
||||
proceed();
|
||||
|
||||
END_MODULE
|
||||
|
||||
#undef BENCHMARK_DET_STACK_SLOTS
|
||||
|
||||
void mercury_benchmarking_init_benchmark(void); /* suppress gcc warning */
|
||||
void mercury_benchmarking_init_benchmark(void) {
|
||||
benchmark_nondet_module();
|
||||
benchmark_det_module();
|
||||
}
|
||||
:- pragma c_header_code("
|
||||
volatile Word ML_benchmarking_dummy_word;
|
||||
").
|
||||
|
||||
:- impure pred do_nothing(T::in) is det.
|
||||
:- pragma c_code(do_nothing(X::in), [will_not_call_mercury, thread_safe], "
|
||||
ML_benchmarking_dummy_word = (Word) X;
|
||||
").
|
||||
|
||||
%-----------------------------------------------------------------------------%
|
||||
|
||||
% Impure integer references.
|
||||
% This type is implemented in C.
|
||||
:- type int_reference ---> int_reference(c_pointer).
|
||||
|
||||
% Create a new int_reference given a term for it to reference.
|
||||
:- impure pred new_int_reference(int::in, int_reference::out) is det.
|
||||
:- pragma inline(new_int_reference/2).
|
||||
:- pragma c_code(new_int_reference(X::in, Ref::out), will_not_call_mercury, "
|
||||
incr_hp(Ref, 1);
|
||||
*(Integer *)Ref = X;
|
||||
").
|
||||
|
||||
:- impure pred incr_ref(int_reference::in) is det.
|
||||
incr_ref(Ref) :-
|
||||
semipure ref_value(Ref, X),
|
||||
impure update_ref(Ref, X + 1).
|
||||
|
||||
:- semipure pred ref_value(int_reference::in, int::out) is det.
|
||||
:- pragma inline(ref_value/2).
|
||||
:- pragma c_code(ref_value(Ref::in, X::out), will_not_call_mercury, "
|
||||
X = *(Integer *) Ref;
|
||||
").
|
||||
|
||||
:- impure pred update_ref(int_reference::in, T::in) is det.
|
||||
:- pragma inline(update_ref/2).
|
||||
:- pragma c_code(update_ref(Ref::in, X::in), will_not_call_mercury, "
|
||||
*(Integer *) Ref = X;
|
||||
").
|
||||
|
||||
%-----------------------------------------------------------------------------%
|
||||
|
||||
@@ -448,8 +448,367 @@ wrap_exception(Exception, exception(Exception)).
|
||||
:- external(builtin_catch/3).
|
||||
|
||||
%-----------------------------------------------------------------------------%
|
||||
%
|
||||
% The --high-level-code implementation
|
||||
%
|
||||
|
||||
:- pragma c_header_code("
|
||||
#ifdef MR_HIGHLEVEL_CODE
|
||||
|
||||
/* det ==> model_det */
|
||||
#define mercury__exception__builtin_catch_3_p_0 \
|
||||
mercury__exception__builtin_catch_model_det
|
||||
|
||||
/* semidet ==> model_semi */
|
||||
#define mercury__exception__builtin_catch_3_p_1 \
|
||||
mercury__exception__builtin_catch_model_semi
|
||||
|
||||
/* cc_multi ==> model_det */
|
||||
#define mercury__exception__builtin_catch_3_p_2 \
|
||||
mercury__exception__builtin_catch_model_det
|
||||
|
||||
/* cc_nondet ==> model_semi */
|
||||
#define mercury__exception__builtin_catch_3_p_3 \
|
||||
mercury__exception__builtin_catch_model_semi
|
||||
|
||||
/* multi ==> model_non */
|
||||
#define mercury__exception__builtin_catch_3_p_4 \
|
||||
mercury__exception__builtin_catch_model_non
|
||||
|
||||
/* nondet ==> model_non */
|
||||
#define mercury__exception__builtin_catch_3_p_5 \
|
||||
mercury__exception__builtin_catch_model_non
|
||||
|
||||
void mercury__exception__builtin_throw_1_p_0(MR_Word);
|
||||
|
||||
void mercury__exception__builtin_throw_1_p_0(MR_Word exception);
|
||||
void mercury__exception__builtin_catch_model_det(MR_Word type_info,
|
||||
MR_Word pred, MR_Word handler_pred, MR_Box *output);
|
||||
bool mercury__exception__builtin_catch_model_semi(MR_Word type_info,
|
||||
MR_Word pred, MR_Word handler_pred, MR_Box *output);
|
||||
void mercury__exception__builtin_catch_model_non(MR_Word type_info,
|
||||
MR_Word pred, MR_Word handler_pred, MR_Box *output,
|
||||
#ifdef MR_USE_GCC_NESTED_FUNCTIONS
|
||||
MR_NestedCont cont
|
||||
#else
|
||||
MR_Cont cont, void *cont_env
|
||||
#endif
|
||||
);
|
||||
#endif /* MR_HIGHLEVEL_CODE */
|
||||
").
|
||||
|
||||
:- pragma c_code("
|
||||
#ifdef MR_HIGHLEVEL_CODE
|
||||
|
||||
/*---------------------------------------------------------------------------*/
|
||||
|
||||
static void
|
||||
ML_call_goal_det(MR_Word type_info, MR_Word closure, MR_Box *result)
|
||||
{
|
||||
typedef void FuncType(void *, MR_Box *);
|
||||
FuncType *code = (FuncType *)
|
||||
MR_field(MR_mktag(0), closure, (Integer) 1);
|
||||
(*code)((void *) closure, result);
|
||||
}
|
||||
|
||||
static bool
|
||||
ML_call_goal_semi(MR_Word type_info, MR_Word closure, MR_Box *result)
|
||||
{
|
||||
typedef bool FuncType(void *, MR_Box *);
|
||||
FuncType *code = (FuncType *)
|
||||
MR_field(MR_mktag(0), closure, (Integer) 1);
|
||||
return (*code)((void *) closure, result);
|
||||
}
|
||||
|
||||
#ifdef MR_USE_GCC_NESTED_FUNCTIONS
|
||||
|
||||
static void
|
||||
ML_call_goal_non(MR_Word type_info, MR_Word closure, MR_Box *result,
|
||||
MR_NestedCont cont)
|
||||
{
|
||||
typedef void FuncType(void *, MR_Box *, MR_NestedCont);
|
||||
FuncType *code = (FuncType *)
|
||||
MR_field(MR_mktag(0), closure, (Integer) 1);
|
||||
(*code)((void *) closure, result, cont);
|
||||
}
|
||||
|
||||
#else
|
||||
|
||||
static void
|
||||
ML_call_goal_non(MR_Word type_info, MR_Word closure, MR_Box *result,
|
||||
MR_Cont cont, void *cont_env)
|
||||
{
|
||||
typedef void FuncType(void *, MR_Box *, MR_Cont, void *);
|
||||
FuncType *code = (FuncType *)
|
||||
MR_field(MR_mktag(0), closure, (Integer) 1);
|
||||
(*code)((void *) closure, result, cont, cont_env);
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
/*---------------------------------------------------------------------------*/
|
||||
|
||||
static void
|
||||
ML_call_handler_det(MR_Word type_info, MR_Word closure, MR_Word exception,
|
||||
MR_Box *result)
|
||||
{
|
||||
typedef void FuncType(void *, MR_Box, MR_Box *);
|
||||
FuncType *code = (FuncType *)
|
||||
MR_field(MR_mktag(0), closure, (Integer) 1);
|
||||
(*code)((void *) closure, exception, result);
|
||||
}
|
||||
|
||||
static bool
|
||||
ML_call_handler_semi(MR_Word type_info, MR_Word closure, MR_Word exception,
|
||||
MR_Box *result)
|
||||
{
|
||||
typedef bool FuncType(void *, MR_Box, MR_Box *);
|
||||
FuncType *code = (FuncType *)
|
||||
MR_field(MR_mktag(0), closure, (Integer) 1);
|
||||
return (*code)((void *) closure, exception, result);
|
||||
}
|
||||
|
||||
#ifdef MR_USE_GCC_NESTED_FUNCTIONS
|
||||
|
||||
static void
|
||||
ML_call_handler_non(MR_Word type_info, MR_Word closure, MR_Word exception,
|
||||
MR_Box *result, MR_NestedCont cont)
|
||||
{
|
||||
typedef void FuncType(void *, MR_Box, MR_Box *, MR_NestedCont);
|
||||
FuncType *code = (FuncType *)
|
||||
MR_field(MR_mktag(0), closure, (Integer) 1);
|
||||
(*code)((void *) closure, exception, result, cont);
|
||||
}
|
||||
|
||||
#else
|
||||
|
||||
static void
|
||||
ML_call_handler_non(MR_Word type_info, MR_Word closure, MR_Word exception,
|
||||
MR_Box *result, MR_Cont cont, void *cont_env)
|
||||
{
|
||||
typedef void FuncType(void *, MR_Box, MR_Box *, MR_Cont, void *);
|
||||
FuncType *code = (FuncType *)
|
||||
MR_field(MR_mktag(0), closure, (Integer) 1);
|
||||
(*code)((void *) closure, exception, result, cont, cont_env);
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
/*---------------------------------------------------------------------------*/
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <setjmp.h>
|
||||
|
||||
typedef MR_Word MR_Univ;
|
||||
|
||||
typedef struct ML_ExceptionHandler_struct {
|
||||
struct ML_ExceptionHandler_struct *prev;
|
||||
jmp_buf handler;
|
||||
MR_Univ exception;
|
||||
} ML_ExceptionHandler;
|
||||
|
||||
ML_ExceptionHandler *ML_exception_handler;
|
||||
|
||||
void
|
||||
mercury__exception__builtin_throw_1_p_0(MR_Univ exception)
|
||||
{
|
||||
if (ML_exception_handler->handler == NULL) {
|
||||
ML_report_uncaught_exception(exception);
|
||||
abort();
|
||||
} else {
|
||||
ML_exception_handler->exception = exception;
|
||||
longjmp(ML_exception_handler->handler, 1);
|
||||
}
|
||||
}
|
||||
|
||||
void
|
||||
mercury__exception__builtin_catch_model_det(MR_Word type_info,
|
||||
MR_Word pred, MR_Word handler_pred, MR_Box *output)
|
||||
{
|
||||
ML_ExceptionHandler this_handler;
|
||||
|
||||
this_handler.prev = ML_exception_handler;
|
||||
ML_exception_handler = &this_handler;
|
||||
if (setjmp(this_handler.handler) == 0) {
|
||||
ML_call_goal_det(type_info, pred, output);
|
||||
ML_exception_handler = this_handler.prev;
|
||||
} else {
|
||||
ML_exception_handler = this_handler.prev;
|
||||
ML_call_handler_det(type_info, handler_pred,
|
||||
this_handler.exception, output);
|
||||
}
|
||||
}
|
||||
|
||||
bool
|
||||
mercury__exception__builtin_catch_model_semi(MR_Word type_info,
|
||||
MR_Word pred, MR_Word handler_pred, MR_Box *output)
|
||||
{
|
||||
ML_ExceptionHandler this_handler;
|
||||
|
||||
this_handler.prev = ML_exception_handler;
|
||||
ML_exception_handler = &this_handler;
|
||||
if (setjmp(this_handler.handler) == 0) {
|
||||
bool result = ML_call_goal_semi(type_info, pred, output);
|
||||
ML_exception_handler = this_handler.prev;
|
||||
return result;
|
||||
} else {
|
||||
ML_exception_handler = this_handler.prev;
|
||||
return ML_call_handler_semi(type_info, handler_pred,
|
||||
this_handler.exception, output);
|
||||
}
|
||||
}
|
||||
|
||||
#ifdef MR_USE_GCC_NESTED_FUNCTIONS
|
||||
|
||||
void
|
||||
mercury__exception__builtin_catch_model_non(MR_Word type_info,
|
||||
MR_Word pred, MR_Word handler_pred, MR_Box *output,
|
||||
MR_NestedCont cont)
|
||||
{
|
||||
ML_ExceptionHandler this_handler;
|
||||
|
||||
auto void success_cont(void);
|
||||
void success_cont(void) {
|
||||
/*
|
||||
** If we reach here, it means that
|
||||
** the nondet goal has succeeded, so we
|
||||
** need to restore the previous exception
|
||||
** handler before calling its continuation
|
||||
*/
|
||||
ML_exception_handler = this_handler.prev;
|
||||
(*cont)();
|
||||
|
||||
/*
|
||||
** If we get here, it means that the continuation
|
||||
** has failed, and so we are about to redo the
|
||||
** nondet goal. Thus we need to re-establish
|
||||
** its exception handler.
|
||||
*/
|
||||
ML_exception_handler = &this_handler;
|
||||
}
|
||||
|
||||
this_handler.prev = ML_exception_handler;
|
||||
ML_exception_handler = &this_handler;
|
||||
if (setjmp(this_handler.handler) == 0) {
|
||||
ML_call_goal_non(type_info, pred, output, success_cont);
|
||||
ML_exception_handler = this_handler.prev;
|
||||
} else {
|
||||
ML_exception_handler = this_handler.prev;
|
||||
ML_call_handler_non(type_info, handler_pred,
|
||||
this_handler.exception, output, cont);
|
||||
}
|
||||
}
|
||||
|
||||
#else /* ! MR_USE_GCC_NESTED_FUNCTIONS */
|
||||
|
||||
struct ML_catch_env {
|
||||
ML_ExceptionHandler this_handler;
|
||||
MR_Cont cont;
|
||||
void *cont_env;
|
||||
};
|
||||
|
||||
static void
|
||||
ML_catch_success_cont(void *env_ptr) {
|
||||
struct ML_catch_env *env = (struct ML_catch_env *) env_ptr;
|
||||
|
||||
/*
|
||||
** If we reach here, it means that
|
||||
** the nondet goal has succeeded, so we
|
||||
** need to restore the previous exception
|
||||
** handler before calling its continuation
|
||||
*/
|
||||
ML_exception_handler = env->this_handler.prev;
|
||||
(*env->cont)(env->cont_env);
|
||||
|
||||
/*
|
||||
** If we get here, it means that the continuation
|
||||
** has failed, and so we are about to redo the
|
||||
** nondet goal. Thus we need to re-establish
|
||||
** its exception handler.
|
||||
*/
|
||||
ML_exception_handler = &env->this_handler;
|
||||
}
|
||||
|
||||
void
|
||||
mercury__exception__builtin_catch_model_non(MR_Word type_info,
|
||||
MR_Word pred, MR_Word handler_pred, MR_Box *output,
|
||||
MR_Cont cont, void *cont_env)
|
||||
{
|
||||
struct ML_catch_env locals;
|
||||
locals.cont = cont;
|
||||
locals.cont_env = cont_env;
|
||||
|
||||
locals.this_handler.prev = ML_exception_handler;
|
||||
ML_exception_handler = &locals.this_handler;
|
||||
if (setjmp(locals.this_handler.handler) == 0) {
|
||||
ML_call_goal_non(type_info, pred, output,
|
||||
ML_catch_success_cont, &locals);
|
||||
/*
|
||||
** If we reach here, it means that
|
||||
** the nondet goal has failed, so we
|
||||
** need to restore the previous exception
|
||||
** handler
|
||||
*/
|
||||
ML_exception_handler = locals.this_handler.prev;
|
||||
return;
|
||||
} else {
|
||||
/*
|
||||
** We caught an exception.
|
||||
** Restore the previous exception handler,
|
||||
** and then invoke the handler predicate
|
||||
** for this handler.
|
||||
*/
|
||||
ML_exception_handler = locals.this_handler.prev;
|
||||
ML_call_handler_non(type_info, handler_pred,
|
||||
locals.this_handler.exception, output,
|
||||
cont, cont_env);
|
||||
}
|
||||
}
|
||||
|
||||
#endif /* ! MR_USE_GCC_NESTED_FUNCTIONS */
|
||||
|
||||
#endif /* MR_HIGHLEVEL_CODE */
|
||||
").
|
||||
|
||||
/*********
|
||||
This causes problems because the LLDS back-end
|
||||
does not let you export code with determinism `nondet'.
|
||||
Instead we handle-code it... see below.
|
||||
|
||||
:- pred call_goal(pred(T), T).
|
||||
:- mode call_goal(pred(out) is det, out) is det.
|
||||
:- mode call_goal(pred(out) is semidet, out) is semidet.
|
||||
:- mode call_goal(pred(out) is nondet, out) is nondet.
|
||||
|
||||
call_goal(Goal, Result) :- Goal(Result).
|
||||
|
||||
:- pred call_handler(pred(univ, T), univ, T).
|
||||
:- mode call_handler(pred(in, out) is det, in, out) is det.
|
||||
:- mode call_handler(pred(in, out) is semidet, in, out) is semidet.
|
||||
:- mode call_handler(pred(in, out) is nondet, in, out) is nondet.
|
||||
|
||||
call_handler(Handler, Exception, Result) :- Handler(Exception, Result).
|
||||
|
||||
:- pragma export(call_goal(pred(out) is det, out), "ML_call_goal_det").
|
||||
:- pragma export(call_goal(pred(out) is semidet, out), "ML_call_goal_semidet").
|
||||
% :- pragma export(call_goal(pred(out) is nondet, out), "ML_call_goal_nondet").
|
||||
|
||||
:- pragma export(call_handler(pred(in, out) is det, in, out),
|
||||
"ML_call_handler_det").
|
||||
:- pragma export(call_handler(pred(in, out) is semidet, in, out),
|
||||
"ML_call_handler_semidet").
|
||||
% :- pragma export(call_handler(pred(in, out) is nondet, in, out),
|
||||
% "ML_call_handler_nondet").
|
||||
|
||||
*******/
|
||||
|
||||
%-----------------------------------------------------------------------------%
|
||||
%
|
||||
% The --no-high-level-code implementation
|
||||
%
|
||||
|
||||
:- pragma c_header_code("
|
||||
#ifndef MR_HIGHLEVEL_CODE
|
||||
#include <assert.h>
|
||||
#include <stdio.h>
|
||||
#include ""mercury_deep_copy.h""
|
||||
@@ -459,9 +818,11 @@ wrap_exception(Exception, exception(Exception)).
|
||||
|
||||
MR_DECLARE_TYPE_CTOR_INFO_STRUCT( \
|
||||
mercury_data_std_util__type_ctor_info_univ_0);
|
||||
#endif
|
||||
").
|
||||
|
||||
:- pragma c_code("
|
||||
#ifndef MR_HIGHLEVEL_CODE
|
||||
|
||||
/*
|
||||
** MR_trace_throw():
|
||||
@@ -1076,6 +1437,8 @@ void mercury_sys_init_exceptions(void) {
|
||||
exceptions_module();
|
||||
}
|
||||
|
||||
#endif /* ! MR_HIGHLEVEL_CODE */
|
||||
|
||||
").
|
||||
|
||||
%-----------------------------------------------------------------------------%
|
||||
|
||||
@@ -40,10 +40,12 @@ garbage_collect -->
|
||||
|
||||
:- pragma c_code(garbage_collect, [will_not_call_mercury], "
|
||||
#ifdef CONSERVATIVE_GC
|
||||
#ifndef MR_HIGHLEVEL_CODE
|
||||
/* clear out the stacks and registers before garbage collecting */
|
||||
MR_clear_zone_for_GC(MR_CONTEXT(detstack_zone), MR_sp + 1);
|
||||
MR_clear_zone_for_GC(MR_CONTEXT(nondetstack_zone), MR_maxfr + 1);
|
||||
MR_clear_regs_for_GC();
|
||||
#endif
|
||||
|
||||
GC_gcollect();
|
||||
#endif
|
||||
|
||||
@@ -227,7 +227,9 @@
|
||||
""Software error: Domain error in call to `%s'\\n"",
|
||||
where);
|
||||
MR_trace_report(stderr);
|
||||
#ifndef MR_HIGHLEVEL_CODE
|
||||
MR_dump_stack(MR_succip, MR_sp, MR_curfr, FALSE);
|
||||
#endif
|
||||
exit(1);
|
||||
}
|
||||
|
||||
|
||||
Reference in New Issue
Block a user