Module SubSolver (T: TYPE_ALGEBRA).
(* The current set of constraints is represented by a record with two components: - [te_typ]: a partial map from variables to pairs [tlo, thi] of types, representing the low and high bounds for this variable. - [te_sub]: a list of pairs [(x,y)] of variables, indicating that the type of [x] must be a subtype of the type of [y]. *)
Inductive bounds : Type := B (lo: T.t) (hi: T.t) (SUB: T.sub lo hi).
Definition constraint : Type := (positive * positive)%type.
Record typenv : Type := Typenv {
te_typ: PTree.t bounds;    (**r mapping var -> low & high bounds *)
te_sub: list constraint    (**r additional subtyping constraints *)
}.
Definition initial : typenv := {| te_typ := PTree.empty _; te_sub := nil |}.
(** Add the constraint [ty <: T(x)]. *)
Definition type_def (e: typenv) (x: positive) (ty: T.t) : res typenv :=
match e.(te_typ)!x with
| None =>
let b := B ty (T.high_bound ty) (T.high_bound_sub ty) in
OK {| te_typ := PTree.set x b e.(te_typ);
te_sub := e.(te_sub) |}
| Some(B lo hi s1) =>
match T.sub_dec ty hi with
| left s2 =>
let lo' := T.lub lo ty in
if T.eq lo lo' then OK e else
let b := B lo' hi (T.lub_min lo ty hi s1 s2) in
OK {| te_typ := PTree.set x b e.(te_typ);
te_sub := e.(te_sub) |}
| right _ =>
Error (MSG "bad definition of variable " :: POS x :: nil)
end
end.
Fixpoint type_defs (e: typenv) (rl: list positive) (tyl: list T.t) {struct rl}: res typenv :=
match rl, tyl with
| nil, nil => OK e
| r1::rs, ty1::tys => do e1 <- type_def e r1 ty1; type_defs e1 rs tys
| _, _ => Error (msg "arity mismatch")
end.
(** Add the constraint [T(x) <: ty]. *)
Definition type_use (e: typenv) (x: positive) (ty: T.t) : res typenv :=
match e.(te_typ)!x with
| None =>
let b := B (T.low_bound ty) ty (T.low_bound_sub ty) in
OK {| te_typ := PTree.set x b e.(te_typ);
te_sub := e.(te_sub) |}
| Some(B lo hi s1) =>
match T.sub_dec lo ty with
| left s2 =>
let hi' := T.glb hi ty in
if T.eq hi hi' then OK e else
let b := B lo hi' (T.glb_max hi ty lo s1 s2) in
OK {| te_typ := PTree.set x b e.(te_typ);
te_sub := e.(te_sub) |}
| right _ =>
Error (MSG "bad use of variable " :: POS x :: nil)
end
end.
Fixpoint type_uses (e: typenv) (rl: list positive) (tyl: list T.t) {struct rl}: res typenv :=
match rl, tyl with
| nil, nil => OK e
| r1::rs, ty1::tys => do e1 <- type_use e r1 ty1; type_uses e1 rs tys
| _, _ => Error (msg "arity mismatch")
end.
(** Add the constraint [T(x) <: T(y)]. The boolean result is [true] if the types of [r1] and [r2] could be made more precise.  Otherwise, [te_typ] does not change and [false] is returned. *)
Definition type_move (e: typenv) (r1 r2: positive) : res (bool * typenv) :=
if peq r1 r2 then OK (false, e) else
match e.(te_typ)!r1, e.(te_typ)!r2 with
| None, None =>
OK (false, {| te_typ := e.(te_typ); te_sub := (r1, r2) :: e.(te_sub) |})
| Some(B lo1 hi1 s1), None =>
let b2 := B lo1 (T.high_bound lo1) (T.high_bound_sub lo1) in
OK (true, {| te_typ := PTree.set r2 b2 e.(te_typ);
te_sub := if T.sub_dec hi1 lo1 then e.(te_sub)
else (r1, r2) :: e.(te_sub) |})
| None, Some(B lo2 hi2 s2) =>
let b1 := B (T.low_bound hi2) hi2 (T.low_bound_sub hi2) in
OK (true, {| te_typ := PTree.set r1 b1 e.(te_typ);
te_sub := if T.sub_dec hi2 lo2 then e.(te_sub)
else (r1, r2) :: e.(te_sub) |})
| Some(B lo1 hi1 s1), Some(B lo2 hi2 s2) =>
if T.sub_dec hi1 lo2 then
(* The constraint is always true, don't record it *)
OK (false, e)
else match T.sub_dec lo1 hi2 with
| left s =>
(* Tighten the bounds on [r1] and [r2] when possible and record the constraint. *)
let lo2' := T.lub lo1 lo2 in
let hi1' := T.glb hi1 hi2 in
let b1 := B lo1 hi1' (T.glb_max hi1 hi2 lo1 s1 s) in
let b2 := B lo2' hi2 (T.lub_min lo1 lo2 hi2 s s2) in
if T.eq lo2 lo2' then
if T.eq hi1 hi1' then
OK (false, {| te_typ := e.(te_typ);
te_sub := (r1, r2) :: e.(te_sub) |})
else
OK (true, {| te_typ := PTree.set r1 b1 e.(te_typ);
te_sub := (r1, r2) :: e.(te_sub) |})
else
if T.eq hi1 hi1' then
OK (true, {| te_typ := PTree.set r2 b2 e.(te_typ);
te_sub := (r1, r2) :: e.(te_sub) |})
else
OK (true, {| te_typ := PTree.set r2 b2 (PTree.set r1 b1 e.(te_typ));
te_sub := (r1, r2) :: e.(te_sub) |})
| right _ =>
Error(MSG "ill-typed move from " :: POS r1 :: MSG " to " :: POS r2 :: nil)
end
end.
(** Solve the remaining subtyping constraints by iteration. *)
Fixpoint solve_rec (e: typenv) (changed: bool) (q: list constraint) : res (typenv * bool) :=
match q with
| nil =>
OK (e, changed)
| (r1, r2) :: q' =>
do (changed1, e1) <- type_move e r1 r2; solve_rec e1 (changed || changed1) q'
end.
(** Measuring the state *)
Definition weight_bounds (ob: option bounds) : nat :=
match ob with None => T.max_weight + 1 | Some(B lo hi s) => T.weight hi - T.weight lo end.
Hint Resolve T.sub_refl: ty.
Definition weight_constraints (b: PTree.t bounds) (cstr: list constraint) : nat :=
List.fold_right (fun xy n => n + weight_bounds b!(fst xy) + weight_bounds b!(snd xy)) 0 cstr.
Remark weight_constraints_tighter:
forall b1 b2, (forall r, weight_bounds b1!r <= weight_bounds b2!r) ->
forall q, weight_constraints b1 q <= weight_constraints b2 q.
Definition weight_typenv (e: typenv) : nat :=
weight_constraints e.(te_typ) e.(te_sub).
(** Iterative solving of the remaining constraints *)
Function solve_constraints (e: typenv) {measure weight_typenv e}: res typenv :=
match solve_rec {| te_typ := e.(te_typ); te_sub := nil |} false e.(te_sub) with
| OK(e', false) => OK e                   (**r no more changes, fixpoint reached *)
| OK(e', true)  => solve_constraints e'   (**r one more iteration *)
| Error msg => Error msg
end.
Definition typassign := positive -> T.t.
Definition makeassign (e: typenv) : typassign :=
fun x => match e.(te_typ)!x with Some(B lo hi s) => lo | None => T.default end.
Definition solve (e: typenv) : res typassign :=
do e' <- solve_constraints e; OK(makeassign e').
(** What it means to be a solution *)
Definition satisf (te: typassign) (e: typenv) : Prop :=
(forall x lo hi s, e.(te_typ)!x = Some(B lo hi s) -> T.sub lo (te x) /\ T.sub (te x) hi)
/\ (forall x y, In (x, y) e.(te_sub) -> T.sub (te x) (te y)).
(** Soundness proof *)
Hint Resolve type_def_incr: ty.
Hint Resolve type_defs_incr: ty.
Hint Resolve type_use_incr: ty.
Hint Resolve type_uses_incr: ty.
Hint Resolve type_move_incr: ty.

Lemma solve_constraints_sound:
forall e e', solve_constraints e = OK e' -> satisf (makeassign e') e'.