Commit dd209d29 authored by Kim Nguyễn's avatar Kim Nguyễn

Fix variable ordering problem by adding a 'kind' field inside variables so...

Fix variable ordering problem by adding a 'kind' field inside variables so that variables of the function type are processed before arguments types and after Gamma.
parent 06abcb05
...@@ -1724,7 +1724,7 @@ module Print = struct ...@@ -1724,7 +1724,7 @@ module Print = struct
let memo = DescrHash.create 63 let memo = DescrHash.create 63
let counter = ref 0 let counter = ref 0
let alloc def = { let alloc def = {
id = (incr counter; !counter); id = (incr counter; !counter);
def = def; def = def;
state = `None; state = `None;
...@@ -1957,7 +1957,7 @@ module Print = struct ...@@ -1957,7 +1957,7 @@ module Print = struct
let res = let res =
match Atoms.sample bdd with match Atoms.sample bdd with
|None -> false |None -> false
| _ -> true | _ -> true
in res in res
| _ -> false | _ -> false
with Not_found -> true with Not_found -> true
...@@ -1967,9 +1967,9 @@ module Print = struct ...@@ -1967,9 +1967,9 @@ module Print = struct
if subtype tt_times seqs_descr then if subtype tt_times seqs_descr then
let seq = cap tt seqs_descr in let seq = cap tt seqs_descr in
let seq_times = { empty with times = seq.times } in let seq_times = { empty with times = seq.times } in
if is_empty seq || (is_empty seq_times && not finite_atoms) then if is_empty seq || (is_empty seq_times && not finite_atoms) then
[], tt [], tt
else else
let tt = let tt =
let d = diff tt seqs_descr in let d = diff tt seqs_descr in
if finite_atoms then d if finite_atoms then d
...@@ -2201,7 +2201,7 @@ module Print = struct ...@@ -2201,7 +2201,7 @@ module Print = struct
| { state = `Named n } -> n | { state = `Named n } -> n
| _ -> assert false | _ -> assert false
let rec do_print_slot (pri : Level.t) ppf s = let rec do_print_slot (pri : Level.t) ppf s =
match s.state with match s.state with
| `Named n -> U.print ppf n | `Named n -> U.print ppf n
...@@ -2314,10 +2314,10 @@ module Print = struct ...@@ -2314,10 +2314,10 @@ module Print = struct
(List.rev (c :: accu), None) (List.rev (c :: accu), None)
| r -> (List.rev accu,Some r) | r -> (List.rev accu,Some r)
and print_gname ppf = function and print_gname ppf = function
|(cu,n,[||]) -> Format.fprintf ppf "%s%a" cu Ns.QName.print n |(cu,n,[||]) -> Format.fprintf ppf "%s%a" cu Ns.QName.print n
|(cu,n,al) -> |(cu,n,al) ->
Format.fprintf ppf "%s%a(%s)" cu Ns.QName.print n Format.fprintf ppf "%s%a(%s)" cu Ns.QName.print n
(String.concat "," (List.map (Utils.string_of_formatter pp_type) (Array.to_list al))) (String.concat "," (List.map (Utils.string_of_formatter pp_type) (Array.to_list al)))
and pp_type ppf t = and pp_type ppf t =
...@@ -2814,7 +2814,7 @@ module Positive = struct ...@@ -2814,7 +2814,7 @@ module Positive = struct
else begin else begin
let subst l d = let subst l d =
try ty(snd(List.find (fun (alpha,_) -> Var.equal d alpha) l)) try ty(snd(List.find (fun (alpha,_) -> Var.equal d alpha) l))
with Not_found -> var d with Not_found -> var d
in in
let new_t = (substitute_aux Var.Set.empty (decompose t) (subst l)) in let new_t = (substitute_aux Var.Set.empty (decompose t) (subst l)) in
descr (solve new_t) descr (solve new_t)
...@@ -2826,7 +2826,7 @@ module Positive = struct ...@@ -2826,7 +2826,7 @@ module Positive = struct
let subst h d = let subst h d =
try Hashtbl.find h d try Hashtbl.find h d
with Not_found -> begin with Not_found -> begin
let x = var (Var.fresh d) in let x = var (Var.fresh d) in
Hashtbl.add h d x ; Hashtbl.add h d x ;
x x
end end
...@@ -2835,6 +2835,13 @@ module Positive = struct ...@@ -2835,6 +2835,13 @@ module Positive = struct
let new_t = substitute_aux delta dec (subst h) in let new_t = substitute_aux delta dec (subst h) in
descr (solve new_t) descr (solve new_t)
let substitute_kind delta kind t =
if no_var t then t else
let subst kin d = var (Var.set_kind kind d) in
let dec = decompose t in
let new_t = substitute_aux delta dec (subst kind) in
descr (solve new_t)
(* We cannot use the variance annotation of variables to simplify them, (* We cannot use the variance annotation of variables to simplify them,
since variables are shared amongst types. If we have two types since variables are shared amongst types. If we have two types
A -> A and (A,A) (produced by the algorithm) then we can still simplify the A -> A and (A,A) (produced by the algorithm) then we can still simplify the
...@@ -2930,8 +2937,8 @@ module Tallying = struct ...@@ -2930,8 +2937,8 @@ module Tallying = struct
* equivalent *) * equivalent *)
let semantic_compare t1 t2 = let semantic_compare t1 t2 =
let c = Descr.compare t1 t2 in let c = Descr.compare t1 t2 in
if c = 0 then 0 else if c = 0 then 0 else
if equiv t1 t2 then 0 if equiv t1 t2 then 0
else c else c
(* constraint set : map to store constraints of the form (s <= alpha <= t) *) (* constraint set : map to store constraints of the form (s <= alpha <= t) *)
...@@ -3592,8 +3599,11 @@ exception FoundApply of t * int * int * Tallying.CS.sl ...@@ -3592,8 +3599,11 @@ exception FoundApply of t * int * int * Tallying.CS.sl
(** find two sets of type substitutions I,J such that (** find two sets of type substitutions I,J such that
s @@ sigma_i < t @@ sigma_j for all i \in I, j \in J *) s @@ sigma_i < t @@ sigma_j for all i \in I, j \in J *)
let apply_raw delta s t = let apply_raw delta s t =
Tallying.NormMemoHash.clear Tallying.memo_norm; Tallying.NormMemoHash.clear Tallying.memo_norm;
let s = Positive.substitute_kind delta Var.function_kind s in
let t = Positive.substitute_kind delta Var.argument_kind t in
let vgamma = Var.mk "Gamma" in let vgamma = Var.mk "Gamma" in
let gamma = var vgamma in let gamma = var vgamma in
let cgamma = cons gamma in let cgamma = cons gamma in
......
module V = struct module V = struct
type t = { id : Ident.U.t ; fr : int } type t = { id : Ident.U.t ; fr : int ; kind : int }
type kind = int
let function_kind = 1
let argument_kind = 2
let dump ppf t = Format.fprintf ppf "{%a(%d)}" Ident.U.print t.id t.fr let dump ppf t = Format.fprintf ppf "{%a(%d)}" Ident.U.print t.id t.fr
let compare x y = Pervasives.compare (x.id,x.fr) (y.id,y.fr) let compare x y = Pervasives.compare (x.kind,x.id,x.fr) (y.kind,y.id,y.fr)
let equal x y = (compare x y) = 0 let equal x y = (compare x y) = 0
let hash x = Hashtbl.hash (x.id,x.fr) let hash x = Hashtbl.hash (x.id,x.fr,x.kind)
let check _ = () let check _ = ()
let freshcounter = ref 0
let is_fresh x = x.fr > 0 let is_fresh x = x.fr > 0
let fresh v = { v with fr = v.fr + 1 }
let mk id = { id = Ident.U.mk id; fr = 0 } let fresh v = { v with fr = (incr freshcounter;!freshcounter) }
let id x = Ident.U.get_str x.id
let mk id = { id = Ident.U.mk id; fr = 0; kind = 0; }
let id x = Ident.U.get_str x.id
let set_kind k v = { v with kind = k }
let pp ppf x = Format.fprintf ppf "'%a" Ident.U.print x.id let pp ppf x = Format.fprintf ppf "'%a" Ident.U.print x.id
let pp ppf x = dump ppf x
end end
include V include V
......
include Custom.T include Custom.T
type kind
type var = t type var = t
val function_kind : kind
val argument_kind : kind
val set_kind : kind -> t -> t
val pp : Format.formatter -> t -> unit val pp : Format.formatter -> t -> unit
val mk : string -> t val mk : string -> t
val id : t -> string val id : t -> string
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment