% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
%-----------------------------------------------------------------------------%
% This program causes rotd-2008-03-03 to abort in debug grades with the
% following:
%
%   Uncaught Mercury exception:
%   Software Error: continuation_info.m: Unexpected: find_typeinfos_for_tvars:
%       can't find rval for type_info var V_59
%
% To reproduce compile with:
%
%   $ mmc -C --grade asm_fast.gc.debug 
%
% (This test case is derived from g12/zinc/compiler/flatzinc_colgen_solver.m
%  in r4693 of G12.)
%
%-----------------------------------------------------------------------------%

:- module fzn_missing_rval.
:- interface.

:- import_module map.
:- import_module maybe.
:- import_module list.

:- type maybe_lower_bound(T)
    --->    no_lb
    ;       lb(T).

:- type maybe_upper_bound(T)
    --->    no_ub
    ;       ub(T).

:- type solver_annotations(Var) == list(solver_annotation(Var)).

:- type solver_annotation(Var)
    --->    solver_annotation(string, list(Var)).

:- typeclass flatzinc_solver(Solver, Var) <= (Solver -> Var) where [

    pred new_float_var(Solver::in,
        maybe_lower_bound(float)::in,
        maybe_upper_bound(float)::in,
        solver_annotations(Var)::ia, Var::oa) is det
].

:- type flatzinc_colgen_solver 
    ---> some [Solver, Var] flatzinc_colgen_solver(
        fcb_colgen_dw_solver :: colgen_dw_solver,
        fcb_sp_solvers       :: bt_ref(map(int,
                                    {Solver,
                                     maybe(int),
                                     map(flatzinc_colgen_var, Var),
                                     map(int, flatzinc_colgen_var)
                                     })),
        fcb_colgen_var_map   :: bt_ref(map(flatzinc_colgen_var, colgen_dw_var))
    ) => ( flatzinc_solver(Solver, Var) ).               

:- type flatzinc_colgen_var
    --->    colgen_var(int)
    ;       colgen_master_var(int)
    ;       sp_var(int, int, flatzinc_type).

:- type flatzinc_type
    --->    scalar(flatzinc_scalar_type)
    ;       array(int, flatzinc_scalar_type).

:- type flatzinc_scalar_type
    --->    flatzinc_bool
    ;       flatzinc_float(maybe_lower_bound(float), maybe_upper_bound(float)).

:- pred fcb_new_float_var(flatzinc_colgen_solver::in,
    maybe_lower_bound(float)::in,
    maybe_upper_bound(float)::in,
    solver_annotations(flatzinc_colgen_var)::ia,
    flatzinc_colgen_var::oa) is det.

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

:- implementation.

:- import_module exception.
:- import_module int.

:- typeclass linear_solver(Solver, Var)
    <=  ( (Solver -> Var) )   
    where [
    pred new_var(Solver::in, Var::oa) is det
].

:- type colgen_dw_solver ---> colgen_dw_solver.

:- type colgen_dw_var ---> colgen_dw_var.

:- type var_ann
    --->    var_ann_colgen_master_var
    ;       var_ann_colgen_sp_var(int, string).

:- instance linear_solver(colgen_dw_solver, colgen_dw_var) where
[
    (new_var(_, _) :- throw(""))
].

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

:- type sp_solver_instance 
    ---> some[Solver, Var] sp_solver_instance(
        spsi_solver   :: Solver,
        spsi_var_map  :: map(flatzinc_colgen_var, Var)
    ) => flatzinc_solver(Solver, Var).

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

fcb_new_float_var(FCBackend, MaybeLo, MaybeHi, Anns, FCVar) :-
    promise_pure (
        fcb_extract_var_ann(Anns, VarAnn)
    ->
        (
            VarAnn = var_ann_colgen_master_var,
            promise_pure (
                ColgenSolver = FCBackend ^ fcb_colgen_dw_solver,
                new_var(ColgenSolver, Var),
                semipure Vars0 = get(FCBackend ^ fcb_colgen_var_map),
                VarID = 1,
                FCVar = colgen_master_var(VarID),
                det_insert(Vars0, FCVar, Var, Vars),
                impure set(FCBackend ^ fcb_colgen_var_map, Vars)
            )
        ;
            VarAnn = var_ann_colgen_sp_var(SPID, SPSolverName),
        FCBackend = flatzinc_colgen_solver(_, SPSolversRef, _),
        FZN_Type = scalar(flatzinc_float(MaybeLo, MaybeHi)),
        VarCreator = new_float_var_wrapper(MaybeLo, MaybeHi),
        fcb_new_var(SPSolversRef, SPID, SPSolverName,
                FZN_Type, Anns, VarCreator, FCVar)
        )
    ;
        throw("")
    ).

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

:- pred fcb_extract_var_ann(solver_annotations(flatzinc_colgen_var)::ia,
    var_ann::oa) is semidet.

fcb_extract_var_ann( [_A | _Anns], VarAnn) :-
        VarAnn = var_ann_colgen_master_var.

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

:- pred new_float_var_wrapper(
    maybe_lower_bound(float)::in, maybe_upper_bound(float)::in,
    Solver::in, solver_annotations(Var)::ia, Var::oa)
    is det <=  flatzinc_solver(Solver, Var).

new_float_var_wrapper(MaybeLo, MaybeHi, Solver, Anns, Var) :-
    new_float_var(Solver, MaybeLo, MaybeHi, Anns, Var).

:- pred fcb_new_var(
    bt_ref(map(int, {Solver, maybe(int), map(flatzinc_colgen_var, Var),
                     map(int, flatzinc_colgen_var)}))::in,
    int::in, string::in, flatzinc_type::in,
    solver_annotations(flatzinc_colgen_var)::ia, 
    pred(Solver, solver_annotations(Var), Var)::in(pred(in, ia, oa) is det),
    flatzinc_colgen_var::oa) is det <= flatzinc_solver(Solver, Var).

fcb_new_var(_SPSolversRef, SPID, _SPSolverName, FznType, _Anns, _NewVarPred, FCVar) :-
    VarID = 0,
    FCVar = sp_var(SPID, VarID, FznType).

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

:- pred fcb_anns_to_sp_anns(Solver::in, map(flatzinc_colgen_var, Var)::in,
   solver_annotations(flatzinc_colgen_var)::ia, solver_annotations(Var)::oa)
   is det <=  flatzinc_solver(Solver, Var).

fcb_anns_to_sp_anns(_, _, _, []).

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

:- interface.

:- type bt_ref(T).

:- impure func new(T::in(I =< any)) = (bt_ref(T)::out(I =< any)) is det.

:- impure pred set(bt_ref(T)::in(I =< any), T::in(I =< any)) is det.

:- semipure func get(bt_ref(T)::in(I =< any)) = (T::out(I =< any)) is det.

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

:- implementation.

:- pragma foreign_type("C", bt_ref(T), "MR_Word *", [can_pass_as_mercury_type]).

:- pragma foreign_proc("C",
    new(X::in(I =< any)) = (R::out(I =< any)),
    [will_not_call_mercury, will_not_modify_trail],
"
    R = MR_GC_NEW(MR_Word);
    *R = X;
").

:- pragma foreign_proc("C",
    set(R::in(I =< any), X::in(I =< any)),
    [will_not_call_mercury],
"
    /*MR_trail_current_value(R);*/
    *R = X;
").

:- pragma foreign_proc("C",
    get(R::in(I =< any)) = (X::out(I =< any)),
    [will_not_call_mercury, promise_semipure, will_not_modify_trail],
"
    X = *R;
").

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