Summary: Move Sil.Subtype module into separate Subtype module. Reviewed By: dulmarod Differential Revision: D3548084 fbshipit-source-id: 52fcademaster
Josh Berdine
8 years ago
committed by
Facebook Github Bot 7
parent
aba67b4a2a
commit
eefe05b240
@ -0,0 +1,341 @@
|
||||
/*
|
||||
* vim: set ft=rust:
|
||||
* vim: set ft=reason:
|
||||
*
|
||||
* Copyright (c) 2009 - 2013 Monoidics ltd.
|
||||
* Copyright (c) 2013 - present Facebook, Inc.
|
||||
* All rights reserved.
|
||||
*
|
||||
* This source code is licensed under the BSD style license found in the
|
||||
* LICENSE file in the root directory of this source tree. An additional grant
|
||||
* of patent rights can be found in the PATENTS file in the same directory.
|
||||
*/
|
||||
|
||||
open! Utils;
|
||||
|
||||
|
||||
/** The Smallfoot Intermediate Language: Subtypes */
|
||||
let module L = Logging;
|
||||
|
||||
let module F = Format;
|
||||
|
||||
let list_to_string list => {
|
||||
let rec aux list =>
|
||||
switch list {
|
||||
| [] => ""
|
||||
| [el, ...rest] =>
|
||||
let s = aux rest;
|
||||
if (s == "") {
|
||||
Typename.name el
|
||||
} else {
|
||||
Typename.name el ^ ", " ^ s
|
||||
}
|
||||
};
|
||||
if (IList.length list == 0) {
|
||||
"( sub )"
|
||||
} else {
|
||||
"- {" ^ aux list ^ "}"
|
||||
}
|
||||
};
|
||||
|
||||
type t' =
|
||||
| Exact /** denotes the current type only */
|
||||
| Subtypes of (list Typename.t);
|
||||
|
||||
|
||||
/** denotes the current type and a list of types that are not their subtypes */
|
||||
type kind = | CAST | INSTOF | NORMAL;
|
||||
|
||||
type t = (t', kind);
|
||||
|
||||
let module SubtypesPair = {
|
||||
type t = (Typename.t, Typename.t);
|
||||
let compare (e1: t) (e2: t) :int => pair_compare Typename.compare Typename.compare e1 e2;
|
||||
};
|
||||
|
||||
let module SubtypesMap = Map.Make SubtypesPair;
|
||||
|
||||
type subtMap = SubtypesMap.t bool;
|
||||
|
||||
let subtMap: ref subtMap = ref SubtypesMap.empty;
|
||||
|
||||
let check_subtype f c1 c2 =>
|
||||
try (SubtypesMap.find (c1, c2) !subtMap) {
|
||||
| Not_found =>
|
||||
let is_subt = f c1 c2;
|
||||
subtMap := SubtypesMap.add (c1, c2) is_subt !subtMap;
|
||||
is_subt
|
||||
};
|
||||
|
||||
let flag_to_string flag =>
|
||||
switch flag {
|
||||
| CAST => "(cast)"
|
||||
| INSTOF => "(instof)"
|
||||
| NORMAL => ""
|
||||
};
|
||||
|
||||
let pp f (t, flag) =>
|
||||
if Config.print_types {
|
||||
switch t {
|
||||
| Exact => F.fprintf f "%s" (flag_to_string flag)
|
||||
| Subtypes list => F.fprintf f "%s" (list_to_string list ^ flag_to_string flag)
|
||||
}
|
||||
};
|
||||
|
||||
let exact = (Exact, NORMAL);
|
||||
|
||||
let all_subtypes = Subtypes [];
|
||||
|
||||
let subtypes = (all_subtypes, NORMAL);
|
||||
|
||||
let subtypes_cast = (all_subtypes, CAST);
|
||||
|
||||
let subtypes_instof = (all_subtypes, INSTOF);
|
||||
|
||||
let is_cast t => snd t == CAST;
|
||||
|
||||
let is_instof t => snd t == INSTOF;
|
||||
|
||||
let list_intersect equal l1 l2 => {
|
||||
let in_l2 a => IList.mem equal a l2;
|
||||
IList.filter in_l2 l1
|
||||
};
|
||||
|
||||
let join_flag flag1 flag2 =>
|
||||
switch (flag1, flag2) {
|
||||
| (CAST, _) => CAST
|
||||
| (_, CAST) => CAST
|
||||
| (_, _) => NORMAL
|
||||
};
|
||||
|
||||
let join (s1, flag1) (s2, flag2) => {
|
||||
let s =
|
||||
switch (s1, s2) {
|
||||
| (Exact, _) => s2
|
||||
| (_, Exact) => s1
|
||||
| (Subtypes l1, Subtypes l2) => Subtypes (list_intersect Typename.equal l1 l2)
|
||||
};
|
||||
let flag = join_flag flag1 flag2;
|
||||
(s, flag)
|
||||
};
|
||||
|
||||
let subtypes_compare l1 l2 => IList.compare Typename.compare l1 l2;
|
||||
|
||||
let compare_flag flag1 flag2 =>
|
||||
switch (flag1, flag2) {
|
||||
| (CAST, CAST) => 0
|
||||
| (INSTOF, INSTOF) => 0
|
||||
| (NORMAL, NORMAL) => 0
|
||||
| (CAST, _) => (-1)
|
||||
| (_, CAST) => 1
|
||||
| (INSTOF, NORMAL) => (-1)
|
||||
| (NORMAL, INSTOF) => 1
|
||||
};
|
||||
|
||||
let compare_subt s1 s2 =>
|
||||
switch (s1, s2) {
|
||||
| (Exact, Exact) => 0
|
||||
| (Exact, _) => (-1)
|
||||
| (_, Exact) => 1
|
||||
| (Subtypes l1, Subtypes l2) => subtypes_compare l1 l2
|
||||
};
|
||||
|
||||
let compare t1 t2 => pair_compare compare_subt compare_flag t1 t2;
|
||||
|
||||
let equal_modulo_flag (st1, _) (st2, _) => compare_subt st1 st2 == 0;
|
||||
|
||||
let update_flag c1 c2 flag flag' =>
|
||||
switch flag {
|
||||
| INSTOF =>
|
||||
if (Typename.equal c1 c2) {
|
||||
flag
|
||||
} else {
|
||||
flag'
|
||||
}
|
||||
| _ => flag'
|
||||
};
|
||||
|
||||
let change_flag st_opt c1 c2 flag' =>
|
||||
switch st_opt {
|
||||
| Some st =>
|
||||
switch st {
|
||||
| (Exact, flag) =>
|
||||
let new_flag = update_flag c1 c2 flag flag';
|
||||
Some (Exact, new_flag)
|
||||
| (Subtypes t, flag) =>
|
||||
let new_flag = update_flag c1 c2 flag flag';
|
||||
Some (Subtypes t, new_flag)
|
||||
}
|
||||
| None => None
|
||||
};
|
||||
|
||||
let normalize_subtypes t_opt c1 c2 flag1 flag2 => {
|
||||
let new_flag = update_flag c1 c2 flag1 flag2;
|
||||
switch t_opt {
|
||||
| Some t =>
|
||||
switch t {
|
||||
| Exact => Some (t, new_flag)
|
||||
| Subtypes l => Some (Subtypes (IList.sort Typename.compare l), new_flag)
|
||||
}
|
||||
| None => None
|
||||
}
|
||||
};
|
||||
|
||||
let subtypes_to_string t =>
|
||||
switch (fst t) {
|
||||
| Exact => "ex" ^ flag_to_string (snd t)
|
||||
| Subtypes l => list_to_string l ^ flag_to_string (snd t)
|
||||
};
|
||||
|
||||
/* c is a subtype when it does not appear in the list l of no-subtypes */
|
||||
let is_subtype f c l =>
|
||||
try {
|
||||
ignore (IList.find (f c) l);
|
||||
false
|
||||
} {
|
||||
| Not_found => true
|
||||
};
|
||||
|
||||
let is_strict_subtype f c1 c2 => f c1 c2 && not (Typename.equal c1 c2);
|
||||
|
||||
/* checks for redundancies when adding c to l
|
||||
Xi in A - { X1,..., Xn } is redundant in two cases:
|
||||
1) not (Xi <: A) because removing the subtypes of Xi has no effect unless Xi is a subtype of A
|
||||
2) Xi <: Xj because the subtypes of Xi are a subset of the subtypes of Xj */
|
||||
let check_redundancies f c l => {
|
||||
let aux (l, add) ci => {
|
||||
let (l, should_add) =
|
||||
if (f ci c) {
|
||||
(l, true)
|
||||
} else if (f c ci) {
|
||||
([ci, ...l], false)
|
||||
} else {
|
||||
([ci, ...l], true)
|
||||
};
|
||||
(l, add && should_add)
|
||||
};
|
||||
IList.fold_left aux ([], true) l
|
||||
};
|
||||
|
||||
let rec updates_head f c l =>
|
||||
switch l {
|
||||
| [] => []
|
||||
| [ci, ...rest] =>
|
||||
if (is_strict_subtype f ci c) {
|
||||
[ci, ...updates_head f c rest]
|
||||
} else {
|
||||
updates_head f c rest
|
||||
}
|
||||
};
|
||||
|
||||
/* adds the classes of l2 to l1 and checks that no redundancies or inconsistencies will occur
|
||||
A - { X1,..., Xn } is inconsistent if A <: Xi for some i */
|
||||
let rec add_not_subtype f c1 l1 l2 =>
|
||||
switch l2 {
|
||||
| [] => l1
|
||||
| [c, ...rest] =>
|
||||
if (f c1 c) {
|
||||
add_not_subtype f c1 l1 rest
|
||||
} else {
|
||||
/* checks for inconsistencies */
|
||||
let (l1', should_add) = check_redundancies f c l1; /* checks for redundancies */
|
||||
let rest' = add_not_subtype f c1 l1' rest;
|
||||
if should_add {
|
||||
[c, ...rest']
|
||||
} else {
|
||||
rest'
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
let get_subtypes (c1, (st1, flag1)) (c2, (st2, flag2)) f is_interface => {
|
||||
let is_sub = f c1 c2;
|
||||
let (pos_st, neg_st) =
|
||||
switch (st1, st2) {
|
||||
| (Exact, Exact) =>
|
||||
if is_sub {
|
||||
(Some st1, None)
|
||||
} else {
|
||||
(None, Some st1)
|
||||
}
|
||||
| (Exact, Subtypes l2) =>
|
||||
if (is_sub && is_subtype f c1 l2) {
|
||||
(Some st1, None)
|
||||
} else {
|
||||
(None, Some st1)
|
||||
}
|
||||
| (Subtypes l1, Exact) =>
|
||||
if is_sub {
|
||||
(Some st1, None)
|
||||
} else {
|
||||
let l1' = updates_head f c2 l1;
|
||||
if (is_subtype f c2 l1) {
|
||||
(Some (Subtypes l1'), Some (Subtypes (add_not_subtype f c1 l1 [c2])))
|
||||
} else {
|
||||
(None, Some st1)
|
||||
}
|
||||
}
|
||||
| (Subtypes l1, Subtypes l2) =>
|
||||
if (is_interface c2 || is_sub) {
|
||||
if (is_subtype f c1 l2) {
|
||||
let l2' = updates_head f c1 l2;
|
||||
(Some (Subtypes (add_not_subtype f c1 l1 l2')), None)
|
||||
} else {
|
||||
(None, Some st1)
|
||||
}
|
||||
} else if (
|
||||
(is_interface c1 || f c2 c1) && is_subtype f c2 l1
|
||||
) {
|
||||
let l1' = updates_head f c2 l1;
|
||||
(
|
||||
Some (Subtypes (add_not_subtype f c2 l1' l2)),
|
||||
Some (Subtypes (add_not_subtype f c1 l1 [c2]))
|
||||
)
|
||||
} else {
|
||||
(None, Some st1)
|
||||
}
|
||||
};
|
||||
(normalize_subtypes pos_st c1 c2 flag1 flag2, normalize_subtypes neg_st c1 c2 flag1 flag2)
|
||||
};
|
||||
|
||||
let case_analysis_basic (c1, st) (c2, (_, flag2)) f => {
|
||||
let (pos_st, neg_st) =
|
||||
if (f c1 c2) {
|
||||
(Some st, None)
|
||||
} else if (f c2 c1) {
|
||||
switch st {
|
||||
| (Exact, _) =>
|
||||
if (Typename.equal c1 c2) {
|
||||
(Some st, None)
|
||||
} else {
|
||||
(None, Some st)
|
||||
}
|
||||
| (Subtypes _, _) =>
|
||||
if (Typename.equal c1 c2) {
|
||||
(Some st, None)
|
||||
} else {
|
||||
(Some st, Some st)
|
||||
}
|
||||
}
|
||||
} else {
|
||||
(None, Some st)
|
||||
};
|
||||
(change_flag pos_st c1 c2 flag2, change_flag neg_st c1 c2 flag2)
|
||||
};
|
||||
|
||||
|
||||
/** [case_analysis (c1, st1) (c2,st2) f] performs case analysis on [c1 <: c2]
|
||||
according to [st1] and [st2]
|
||||
where f c1 c2 is true if c1 is a subtype of c2.
|
||||
get_subtypes returning a pair:
|
||||
- whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1]
|
||||
- whether [st1] and [st2] admit [not(c1 <: c2)],
|
||||
and in case return the updated subtype [st1] */
|
||||
let case_analysis (c1, st1) (c2, st2) f is_interface => {
|
||||
let f = check_subtype f;
|
||||
if Config.subtype_multirange {
|
||||
get_subtypes (c1, st1) (c2, st2) f is_interface
|
||||
} else {
|
||||
case_analysis_basic (c1, st1) (c2, st2) f
|
||||
}
|
||||
};
|
||||
@ -0,0 +1,62 @@
|
||||
/*
|
||||
* vim: set ft=rust:
|
||||
* vim: set ft=reason:
|
||||
*
|
||||
* Copyright (c) 2009 - 2013 Monoidics ltd.
|
||||
* Copyright (c) 2013 - present Facebook, Inc.
|
||||
* All rights reserved.
|
||||
*
|
||||
* This source code is licensed under the BSD style license found in the
|
||||
* LICENSE file in the root directory of this source tree. An additional grant
|
||||
* of patent rights can be found in the PATENTS file in the same directory.
|
||||
*/
|
||||
|
||||
open! Utils;
|
||||
|
||||
|
||||
/** The Smallfoot Intermediate Language: Subtypes */
|
||||
let module L = Logging;
|
||||
|
||||
let module F = Format;
|
||||
|
||||
type t;
|
||||
|
||||
let compare: t => t => int;
|
||||
|
||||
let pp: F.formatter => t => unit;
|
||||
|
||||
let exact: t; /** denotes the current type only */
|
||||
|
||||
let subtypes: t; /** denotes the current type and any subtypes */
|
||||
|
||||
let subtypes_cast: t;
|
||||
|
||||
let subtypes_instof: t;
|
||||
|
||||
let join: t => t => t;
|
||||
|
||||
|
||||
/** [case_analysis (c1, st1) (c2,st2) f] performs case analysis on [c1 <: c2] according
|
||||
to [st1] and [st2] where f c1 c2 is true if c1 is a subtype of c2.
|
||||
get_subtypes returning a pair:
|
||||
- whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1]
|
||||
- whether [st1] and [st2] admit [not(c1 <: c2)], and in case return
|
||||
the updated subtype [st1] */
|
||||
let case_analysis:
|
||||
(Typename.t, t) =>
|
||||
(Typename.t, t) =>
|
||||
(Typename.t => Typename.t => bool) =>
|
||||
(Typename.t => bool) =>
|
||||
(option t, option t);
|
||||
|
||||
let check_subtype: (Typename.t => Typename.t => bool) => Typename.t => Typename.t => bool;
|
||||
|
||||
let subtypes_to_string: t => string;
|
||||
|
||||
let is_cast: t => bool;
|
||||
|
||||
let is_instof: t => bool;
|
||||
|
||||
|
||||
/** equality ignoring flags in the subtype */
|
||||
let equal_modulo_flag: t => t => bool;
|
||||
Loading…
Reference in new issue