(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)
(* A solver for unification constraints. *)
Local Open Scope nat_scope.
Local Open Scope error_monad_scope.
(** This module provides a solver for sets of unification constraints of the following kinds: [T(x) = base-type] or [T(x) = T(y)]. The unknowns are the types [T(x)] of every identifier [x]. *)
(** The interface for base types. *)
Module Type TYPE_ALGEBRA.
Parameter t: Type.
Parameter eq: forall (x y: t), {x=y} + {x<>y}.
Parameter default: t.
End TYPE_ALGEBRA.
(** The constraint solver. *)
Module UniSolver (T: TYPE_ALGEBRA).
(* The current set of constraints is represented by a record with two components: - [te_typ]: a partial map from variables to types - [te_equ]: a list of pairs [(x,y)] of variables, indicating that the type of [x] must be equal to the type of [y]. *)
Definition constraint : Type := (positive * positive)%type.
Record typenv : Type := Typenv {
te_typ: PTree.t T.t;       (**r mapping var -> typ *)
te_equ: list constraint    (**r additional equality constraints *)
}.
Definition initial : typenv := {| te_typ := PTree.empty _; te_equ := nil |}.
(** Add the constraint [T(x) = ty]. *)
Definition set (e: typenv) (x: positive) (ty: T.t) : res typenv :=
match e.(te_typ)!x with
| None =>
OK {| te_typ := PTree.set x ty e.(te_typ);
te_equ := e.(te_equ) |}
| Some ty' =>
if T.eq ty ty'
then OK e
else Error (MSG "bad definition/use of variable " :: POS x :: nil)
end.
Fixpoint set_list (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 <- set e r1 ty1; set_list e1 rs tys
| _, _ => Error (msg "arity mismatch")
end.
(** Add the constraint [T(x) = T(y)]. The boolean result is [true] if the types of [x] or [y] could be made more precise.  Otherwise, [te_typ] does not change and [false] is returned. *)
Definition 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_equ := (r1, r2) :: e.(te_equ) |})
| Some ty1, None =>
OK (true, {| te_typ := PTree.set r2 ty1 e.(te_typ); te_equ := e.(te_equ) |})
| None, Some ty2 =>
OK (true, {| te_typ := PTree.set r1 ty2 e.(te_typ); te_equ := e.(te_equ) |})
| Some ty1, Some ty2 =>
if T.eq ty1 ty2
then OK (false, e)
else Error(MSG "ill-typed move from " :: POS r1 :: MSG " to " :: POS r2 :: nil)
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) <- move e r1 r2; solve_rec e1 (changed || changed1) q'
end.
(** Measuring the state *)

(* Specifications: *)
Lemma move_shape:
forall e r1 r2 changed e',
move e r1 r2 = OK (changed, e') ->
(e'.(te_equ) = e.(te_equ) \/ e'.(te_equ) = (r1, r2) :: e.(te_equ))
/\ (changed = true -> e'.(te_equ) = e.(te_equ)).
Lemma length_move:
forall e r1 r2 changed e',
move e r1 r2 = OK (changed, e') ->
length e'.(te_equ) + (if changed then 1 else 0) <= S(length e.(te_equ)).
Lemma length_solve_rec:
forall q e ch e' ch',
solve_rec e ch q = OK (e', ch') ->
length e'.(te_equ) + (if ch' && negb ch then 1 else 0) <= length e.(te_equ) + length q.
Lemma move_shape:
forall e r1 r2 changed e',
move e r1 r2 = OK (changed, e') ->
(e'.(te_equ) = e.(te_equ) \/ e'.(te_equ) = (r1, r2) :: e.(te_equ))
/\ (changed = true -> e'.(te_equ) = e.(te_equ)).
Lemma length_move:
forall e r1 r2 changed e',
move e r1 r2 = OK (changed, e') ->
length e'.(te_equ) + (if changed then 1 else 0) <= S(length e.(te_equ)).
Lemma length_solve_rec:
forall q e ch e' ch',
solve_rec e ch q = OK (e', ch') ->
length e'.(te_equ) + (if ch' && negb ch then 1 else 0) <= length e.(te_equ) + length q.