[m-dev.] for review: MLDS back-end: library fixes
Fergus Henderson
fjh at cs.mu.OZ.AU
Tue Dec 7 06:13:52 AEDT 1999
Estimated hours taken: 8
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.
Workspace: /d-drive/home/hg/fjh/mercury
Index: library/benchmarking.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/benchmarking.m,v
retrieving revision 1.27
diff -u -d -r1.27 benchmarking.m
--- library/benchmarking.m 1999/11/22 04:25:55 1.27
+++ library/benchmarking.m 1999/12/06 14:40:18
@@ -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 @@
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,18 +156,33 @@
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;
+ fprintf(stderr, "" C Stack: %.3fk,"",
+ labs(&local_var - (char *) GC_stackbottom) / 1024.0);
+ }
+#endif
+
#ifdef MR_USE_TRAIL
fprintf(stderr,
"" Trail: %.3fk,"",
@@ -531,256 +550,107 @@
").
%-----------------------------------------------------------------------------%
-
-:- external(benchmark_det/5).
-:- external(benchmark_nondet/5).
-
-:- pragma c_code("
-
-/*
-INIT mercury_benchmarking_init_benchmark
-ENDINIT
-*/
-
-/*
-** :- 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);
+:- 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),
+ Time = StartTime - EndTime.
-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
+:- impure pred benchmark_det_loop(pred(T1, T2), T1, T2, int).
+:- mode benchmark_det_loop(pred(in, out) is det, in, out, in) is cc_multi.
-Define_entry(mercury__benchmarking__benchmark_det_5_0);
+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
+ ).
- /*
- ** 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.
- */
+:- 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),
+ Time = StartTime - EndTime.
- 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));
+:- impure pred benchmark_nondet_loop(pred(T1, T2), T1, int, int).
+:- mode benchmark_nondet_loop(pred(in, out) is nondet, in, out, in) is cc_multi.
- MR_stackvar(1) = r3;
- MR_stackvar(2) = r4;
+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, Count0),
+ cc_multi_equal(Count0, Count).
- /* r5 is the repetition count */
- if ((Integer) r5 <= 0) {
- MR_stackvar(3) = 1;
- } else {
- MR_stackvar(3) = r5;
- }
+:- impure pred repeat(int::in) is nondet.
+repeat(N) :-
+ N > 0,
+ ( true ; impure repeat(N - 1) ).
- MR_stackvar(4) = MR_get_user_cpu_miliseconds();
+:- 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();
+").
- /* 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));
+/*
+** To prevent the C compiler from optimizing the benchmark code
+** away, we assign the benchmark output to a volatile global variable.
+*/
-Define_label(mercury__benchmarking__benchmark_det_5_0_i1);
- update_prof_current_proc(
- LABEL(mercury__benchmarking__benchmark_det_5_0));
+:- pragma c_header_code("
+ volatile Word ML_benchmarking_dummy_word;
+").
- /* mark current iteration completed */
- MR_stackvar(3) = MR_stackvar(3) - 1;
+:- 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;
+").
- /* 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();
+% Impure integer references.
+% This type is implemented in C.
+:- type int_reference ---> int_reference(c_pointer).
-END_MODULE
+% 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;
+").
-#undef BENCHMARK_DET_STACK_SLOTS
+:- impure pred incr_ref(int_reference::in) is det.
+incr_ref(Ref) :-
+ semipure ref_value(Ref, X),
+ impure update_ref(Ref, X + 1).
-void mercury_benchmarking_init_benchmark(void); /* suppress gcc warning */
-void mercury_benchmarking_init_benchmark(void) {
- benchmark_nondet_module();
- benchmark_det_module();
-}
+:- 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;
").
%-----------------------------------------------------------------------------%
Index: library/exception.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/exception.m,v
retrieving revision 1.6
diff -u -d -r1.6 exception.m
--- library/exception.m 1999/10/04 09:04:38 1.6
+++ library/exception.m 1999/12/06 19:07:52
@@ -448,8 +448,367 @@
:- 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 = &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 @@
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():
@@ -1074,6 +1435,8 @@
void mercury_sys_init_exceptions(void) {
exceptions_module();
}
+
+#endif /* ! MR_HIGHLEVEL_CODE */
").
Index: library/math.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/math.m,v
retrieving revision 1.23
diff -u -d -r1.23 math.m
--- library/math.m 1999/10/15 21:13:41 1.23
+++ library/math.m 1999/12/06 18:55:38
@@ -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);
}
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh> | of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3 | -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list