Commit 6ee6ef2e authored by Kim Nguyễn's avatar Kim Nguyễn

Improve pretty printing of Bdds and add debug directive to interactively...

Improve pretty printing of Bdds and add debug directive to interactively inspect the internal representation of types.
parent edd4e79d
......@@ -83,7 +83,8 @@ let directive_help ppf =
let directive_help_debug ppf =
Format.fprintf ppf
"Debug sub-directives:
#debug sybtype <type> <type> ;; check if t1 < t2 for all substitutions
#debug subtype <type> <type> ;; check if t1 < t2 for all substitutions
#debug bdd <type>;; dump the internal type representation
#debug typed <expr> ;; dump typed internal representation
#debug lambda <expr> ;; dump lambda internal representation
#debug accept <???> ;;
......@@ -201,6 +202,13 @@ let debug ppf tenv cenv = function
and t2 = Types.descr (Typer.typ tenv t2) in
let s = Types.subtype t1 t2 in
Format.fprintf ppf "%a %a %a : %b@." print_norm t1 print_protect "<=" print_norm t2 s
| `Bdd (t) ->
Format.fprintf ppf "[DEBUG:bdd]@.";
let t = Types.descr (Typer.typ tenv t) in
Format.fprintf ppf "@[%a@]@." Types.Print.dump t
| `Id_bdd (i) ->
Format.fprintf ppf "[DEBUG:id_bdd]@.";
Format.fprintf ppf "@[%a@]@." Types.Print.dump_by_id i
| `Sample t ->
Format.fprintf ppf "[DEBUG:sample]@.";
(try
......
......@@ -99,11 +99,11 @@ struct
| _ -> ()
let rec dump ppf = function
| True -> Format.fprintf ppf "+"
| False -> Format.fprintf ppf "-"
| True -> Format.fprintf ppf ""
| False -> Format.fprintf ppf ""
| Split (_,x, p,i,n) ->
Format.fprintf ppf "%i(@[%a,%a,%a@])"
(* X.dump x *) (X.hash x) dump p dump i dump n
Format.fprintf ppf "@[@[%a@][@[<hov>%a,@\n%a,@\n%a@]]@]"
X.dump x dump p dump i dump n
let rec print f ppf = function
| True -> Format.fprintf ppf "Any"
......
......@@ -31,6 +31,8 @@ and debug_directive =
| `Single of ppat
| `Typed of pexpr
| `Lambda of pexpr
| `Bdd of ppat
| `Id_bdd of int
]
and toplevel_directive =
[ `Quit
......
......@@ -227,6 +227,8 @@ EXTEND Gram
| IDENT "single"; t = pat -> `Single t
| IDENT "typed"; e = expr -> `Typed e
| IDENT "lambda"; e = expr -> `Lambda e
| IDENT "bdd"; t = pat -> `Bdd t
| IDENT "id_bdd"; i = INT -> `Id_bdd (int_of_string i)
]
];
......
......@@ -158,11 +158,19 @@ module Make (T : E) : S with type s = T.t = struct
| _ -> ()
let rec dump ppf = function
| `True -> Format.fprintf ppf "+"
| `False -> Format.fprintf ppf "-"
| `True -> Format.fprintf ppf ""
| `False -> Format.fprintf ppf ""
| `Split (_,x, p,i,n) ->
Format.fprintf ppf "%a(@[%a,%a,%a@])"
X.dump x (*X.hash x*) dump p dump i dump n
let fmt = format_of_string (
match x with
`Var _ ->
"@[{@[%a@]}{@[<hov>%a,@ %a,@ %a@]}@]"
| `Atm _ ->
"@[ {@[%a@]}@\n {@[<hov>%a,@ %a,@ %a@]}@]"
)
in
Format.fprintf ppf fmt
X.dump x dump p dump i dump n
let rec print f ppf = function
| `True -> Format.fprintf ppf "Any"
......
......@@ -190,7 +190,16 @@ struct
type t = s
let dump ppf d =
Format.fprintf ppf "<types atoms(%a) ints(%a) chars(%a) times(%a) arrow(%a) record(%a) xml(%a) abstract(%a) absent(%b)>\n"
Format.fprintf ppf "@[<v 1>types:@\n\
@<1> atoms: %a@\n\
@<1> ints: %a@\n\
@<1> chars: %a@\n\
@<1> times: %a@\n\
@<1> arrow: %a@\n\
@<1> record: %a@\n\
@<1> xml: %a@\n\
@<1> abstract: %a@\n\
@<1> absent: %b@]@\n"
BoolAtoms.dump d.atoms
BoolIntervals.dump d.ints
BoolChars.dump d.chars
......@@ -309,7 +318,11 @@ struct
let compare x y =
let c = x.id - y.id in if c = 0 then Compunit.compare x.cu y.cu else c
let equal x y = x==y || (x.id == y.id && (Compunit.equal x.cu y.cu))
let mk id d = { id = id; cu = Compunit.current (); descr = d }
end
and Pair : Bool.S with type elem = (Node.t * Node.t) =
......@@ -937,6 +950,29 @@ let subtype d1 d2 = is_empty (diff d1 d2)
let equiv d1 d2 = (subtype d1 d2) && (subtype d2 d1)
(* perform some semantic simplifications around type constructors *)
let atom a =
let atm =
if Atoms.(is_empty (diff full a)) then
BoolAtoms.full
else BoolAtoms.atom (`Atm a)
in
{ empty with atoms = atm }
let times x y =
if subtype any x.Node.descr
&& subtype any y.Node.descr
then
{ empty with times = BoolPair.full }
else times x y
let xml x y =
if subtype any x.Node.descr
&& subtype any y.Node.descr
then
{ empty with xml = BoolPair.full }
else xml x y
module Cache = struct
type 'a cache =
......@@ -2491,6 +2527,33 @@ module Print = struct
let string_of_node t = Utils.string_of_formatter pp_node t
let printf = pp_type Format.std_formatter
let gmemo = Hashtbl.create 17
let dump ppf t =
let module NodeSet = Set.Make(Node) in
Format.fprintf ppf "@[%a@]@\n" Descr.dump t;
let nodes = ref NodeSet.empty in
let ignore2 _ _ = () in
let pair (n1, n2) =
nodes := NodeSet.add n1 (NodeSet.add n2 !nodes)
in
Iter.compute ~empty:() ~full:() ~cup:ignore2 ~cap:ignore2 ~diff:ignore2
~var:ignore ~atom:ignore ~int:ignore ~char:ignore ~abs:ignore ~opt:ignore
~times:pair ~xml:pair ~arrow:pair ~record:(fun (_,lm) ->
LabelMap.iter (fun n -> nodes := NodeSet.add n !nodes) lm) t;
match NodeSet.elements !nodes with
[] -> ()
| l -> Format.fprintf ppf "@[<v 3> where:@\n";
List.iter (fun n -> Hashtbl.replace gmemo n.Node.id n.Node.descr;
Format.fprintf ppf "X%i = @[%a@]@\n" n.Node.id pp_noname n.Node.descr)
l;
Format.fprintf ppf "@]@\n"
let dump_by_id ppf i =
try dump ppf (Hashtbl.find gmemo i) with Not_found ->
Format.fprintf ppf "Unbound node id: %i@\n" i
end
module Service =
......@@ -2871,6 +2934,8 @@ module Positive = struct
let define v1 v2 = def v1 (`Cup [v2])
let diff v1 v2 = cap [v1 ; (neg v2)]
let get_opt = function Some t -> t | None -> T.any
let decompose ?(stop=(fun _ -> None)) t =
let memo = DescrHash.create 17 in
let rec loop t =
......
......@@ -335,6 +335,8 @@ module Print : sig
val string_of_type: t -> string
val string_of_node: Node.t -> string
val printf : t -> unit
val dump: Format.formatter -> t -> unit
val dump_by_id: Format.formatter -> int -> unit
end
module Service : sig
......
......@@ -4,7 +4,7 @@ module V = struct
let function_kind = 1
let argument_kind = 2
let dump ppf t = Format.fprintf ppf "{%a(%d_%d)}" Ident.U.print t.id t.fr t.kind
let dump ppf t = Format.fprintf ppf "%a(%d_%d)" Ident.U.print t.id t.fr t.kind
let compare x y = Pervasives.compare (x.kind,x.id,x.fr) (y.kind,y.id,y.fr)
let equal x y =
x == y || (x.kind == y.kind && x.fr == y.fr && Ident.U.equal x.id y.id)
......
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