[m-users.] Mercury with Guile (was Re: installation failure (Mercury 14.01))

[Peter Wang]

On Sat, 2 Aug 2014 20:12:25 +0200, "Tomas By" <tomas at basun.net> wrote:
> 
> This code:
> http://www.mercurylang.org/list-archives/users/2011-June/005409.html
> 
> I am trying to create a binary containing both Mercury and Guile that does
> not crash immediately.

Hi Tomas,

When Guile is first initialised it calls GC_set_all_interior_pointers(0)
which resets the pointer displacements registered by the Mercury
wrapper.  This will cause premature collection of Mercury structures.

The following program works for me, though it's not very comprehensive.

I built Guile against Mercury's par_gc library by setting BDW_GC_CFLAGS
and BDW_GC_LIBS when configuring Guile.  I needed to comment out a call
to GC_dump as it does not exist in Mercury's build.

Peter
-------------- next part --------------
%-----------------------------------------------------------------------------%

:- module t.
:- interface.

:- import_module io.

:- pred main(io::di, io::uo) is det.

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

:- implementation.

:- import_module bool.
:- import_module int.
:- import_module list.
:- import_module thread.

:- pragma foreign_decl("C", "
    #include <libguile.h>
").

%-----------------------------------------------------------------------------%

main(!IO) :-
    init_guile(!IO),
    p1(!IO), p2(!IO),
    p1(!IO), p2(!IO),
    p1(!IO), p2(!IO),
    p1(!IO), p2(!IO),
    p1(!IO), p2(!IO),
    p1(!IO), p2(!IO),
    p1(!IO), p2(!IO),
    p1(!IO), p2(!IO),
    p1(!IO), p2(!IO),
    p1(!IO), p2(!IO),
    p1(!IO), p2(!IO),
    p1(!IO), p2(!IO).

%-----------------------------------------------------------------------------%

:- pred p1(io::di, io::uo) is det.

p1(!IO) :-
    scm_with_guile(do_scm, !IO).

:- pred do_scm(io::di, io::uo) is det.

do_scm(!IO) :-
    scm_c_eval_string(alloc_scm, R, !IO),
    io.write_int(R, !IO),
    io.nl(!IO).

:- func alloc_scm = string.

alloc_scm =
    "(let loop ((i 0) (xs '()))
        (if (>= i 10000)
            (length xs)
            (loop (+ i 1) (cons (make-vector 1000 #f) xs))))".

%-----------------------------------------------------------------------------%

:- pred p2(io::di, io::uo) is det.

p2(!IO) :-
    R = alloc(0, []),
    io.write_int(R, !IO),
    io.nl(!IO).

:- func alloc(int, list(list(int))) = int.

alloc(I, Xs) =
    ( I >= 10000 ->
        length(Xs)
    ;
        alloc(I + 1, cons(1 .. 1000, Xs))
    ).

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

:- pred init_guile(io::di, io::uo) is det.

:- pragma foreign_proc("C",
    init_guile(_IO0::di, _IO::uo),
    [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io,
        may_not_duplicate],
"
    scm_with_guile(nothing, NULL);
    /*
    ** scm_storage_prehistory calls GC_set_all_interior_pointers which has the
    ** side-effect of resetting the pointer displacements which were set up
    ** before entering main, so we need to register them again.
    */
    register_displacements();
").

:- pragma foreign_decl("C", local, "
static void *
nothing(void *extra)
{
    return NULL;
}

static void
register_displacements(void)
{
    int i;
    int limit;

    limit = (1 << MR_LOW_TAG_BITS);

#if defined(MR_RECORD_TERM_SIZES) || \
    defined(MR_MPROF_PROFILE_MEMORY_ATTRIBUTION)
    limit += sizeof(MR_Word);
#endif

    for (i = 1; i < limit; i++) {
        GC_REGISTER_DISPLACEMENT(i);
    }
}
").

%-----------------------------------------------------------------------------%

:- pred scm_with_guile(pred(io, io), io, io).
:- mode scm_with_guile(pred(di, uo) is det, di, uo) is det.

:- pragma foreign_proc("C",
    scm_with_guile(Pred::in(pred(di, uo) is det), _IO0::di, _IO::uo),
    [may_call_mercury, promise_pure, thread_safe, tabled_for_io,
        may_not_duplicate],
"
    scm_with_guile(call_pred, (void *) Pred);
").

:- pragma foreign_decl("C", local, "
static void *
call_pred(void *data)
{
    do_call((MR_Word) data);
    return NULL;
}
").

:- pred do_call(pred(io, io), io, io).
:- mode do_call(pred(di, uo) is det, di, uo) is det.

:- pragma foreign_export("C", do_call(pred(di, uo) is det, di, uo), "do_call").

do_call(P, !IO) :-
    call(P, !IO).

%-----------------------------------------------------------------------------%

:- pred scm_c_eval_string(string::in, int::out, io::di, io::uo) is det.

:- pragma foreign_proc("C",
    scm_c_eval_string(S::in, R::out, _IO0::di, _IO::uo),
    [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
"
    SCM r = scm_c_eval_string(S);
    R = scm_to_int(r);
").

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sts=4 sw=4 et