Commit 1d4ae7d9 authored by Pietro Abate's avatar Pietro Abate

[r2005-06-16 15:44:40 by afrisch] Begin automaton minimization

Original author: afrisch
Date: 2005-06-16 15:44:41+00:00
parent 87ad191d
......@@ -151,6 +151,7 @@ OBJECTS = \
types/chars.cmo types/atoms.cmo \
types/normal.cmo \
types/types.cmo types/sample.cmo types/sequence.cmo types/patterns.cmo \
compile/auto_opt.cmo \
types/builtin_defs.cmo \
\
compile/lambda.cmo \
......
open Ident
open Patterns.Compile
type node = ptr ref
and ptr = Disp of descr | Link of node
and descr = { disp: dispatcher; mutable minimized: bool }
let rec repr n = match !n with Disp _ -> n | Link n -> repr n
let descr n = match !n with Disp d -> d | _ -> assert false
let log = ref []
let link n1 n2 = log := (n1, !n1) :: !log; n1 := Link n2
let backtrack n0 =
let rec aux = function
| (n,d)::rest -> n := d; if (n != n0) then aux rest else log := rest
| _ -> assert false
in
aux !log
let nodes = Hashtbl.create 64
let node_of d =
try Hashtbl.find nodes (id d)
with Not_found ->
let n = ref (Disp { disp = d; minimized = false }) in
Hashtbl.add nodes (id d) n;
n
exception Not_equal
let rec check_equal_nodes n1 n2 =
let n1 = repr n1 and n2 = repr n2 in
if (n1 != n2) then (
let d1 = descr n1 and d2 = descr n2 in
if d1.minimized && d2.minimized then raise Not_equal;
let n1,n2 = if d1.minimized then (n2,n1) else (n1,n2) in
link n1 n2;
try check_equal_actions (actions d1.disp) (actions d2.disp)
with Not_equal -> backtrack n1; raise Not_equal
)
and check_equal_actions a1 a2 = match a1,a2 with
| AIgnore r1, AIgnore r2 -> check_equal_results r1 r2
| AKind k1, AKind k2 ->
(check_equal_basics k1.basic k2.basic;
check_equal_prods k1.prod k2.prod;
check_equal_prods k1.xml k2.xml;
match k1.record,k2.record with
| Some(RecLabel(l1,p1)), Some(RecLabel(l2,p2)) when LabelPool.equal l1 l2 ->
check_equal_prods p1 p2
| Some(RecNolabel (a1,b1)), Some(RecNolabel (a2,b2)) ->
check_equal_result_options a1 a2;
check_equal_result_options b1 b2;
| None, None -> ()
| _ -> raise Not_equal)
| _ -> raise Not_equal
and check_equal_result_options a1 a2 = match a1,a2 with
| Some r1, Some r2 -> check_equal_results r1 r2
| None, None -> ()
| _ -> raise Not_equal
and check_equal_prods a1 a2 = match a1,a2 with
| Dispatch (d1,r1), Dispatch (d2,r2) when Array.length r1 = Array.length r2 ->
check_equal_disps d1 d2;
Array.iteri (fun i x -> check_equal_prod2 x r2.(i)) r1
| TailCall d1, TailCall d2 -> check_equal_disps d1 d2
| Ignore c1, Ignore c2 -> check_equal_prod2 c1 c2
| Impossible, Impossible -> ()
| _ -> raise Not_equal
and check_equal_prod2 a1 a2 = match a1,a2 with
| Dispatch (d1,r1), Dispatch (d2,r2) when Array.length r1 = Array.length r2 ->
check_equal_disps d1 d2;
Array.iteri (fun i x -> check_equal_results x r2.(i)) r1
| TailCall d1, TailCall d2 -> check_equal_disps d1 d2
| Ignore c1, Ignore c2 -> check_equal_results c1 c2
| Impossible, Impossible -> ()
| _ -> raise Not_equal
and check_equal_disps d1 d2 =
if d1 == d2 then ()
else check_equal_nodes (node_of d1) (node_of d2)
and check_equal_results (c1,s1,p1) (c2,s2,p2) =
if (c1 != c2) || (p1 != p2) || (Array.length s1 != Array.length s2)
then raise Not_equal;
Array.iteri (fun i x -> check_equal_source x s2.(i)) s1
and check_equal_source s1 s2 = if (s1 != s2) then match s1,s2 with
| Const c1, Const c2 when Types.Const.equal c1 c2 -> ()
| Stack i1, Stack i2 when i1 == i2 -> ()
| Recompose (i1,j1), Recompose (i2,j2) when i1 == i2 && j1 == j2 -> ()
| _ -> raise Not_equal
and check_equal_basics a1 a2 =
if (List.length a1 != List.length a2) then raise Not_equal;
List.iter2 (fun (t1,r1) (t2,r2) ->
if not (Types.equiv t1 t2) then raise Not_equal;
check_equal_results r1 r2) a1 a2
let equal_nodes n1 n2 =
try check_equal_nodes n1 n2; true
with Not_equal -> false
let minimized = ref []
let rec auto d =
let n = node_of d in
if not (List.exists (equal_nodes n) !minimized) then
let n = repr n in
(descr n).minimized <- true;
minimized := n :: !minimized;
iter_disp_actions auto (actions d)
let make_branches t brs =
let d,r = make_branches t brs in
auto d;
d,r
let () =
Stats.register Stats.Summary
(fun ppf ->
Format.fprintf ppf
"Number of minimized states:%i@."
(List.length !minimized));
open Patterns
open Patterns.Compile
val make_branches : Types.t -> (node * 'a) list -> dispatcher * 'a rhs array
......@@ -72,6 +72,10 @@ types/patterns.cmx: types/types.cmx misc/stats.cmx misc/state.cmx \
types/sortedList.cmx misc/serialize.cmx types/sequence.cmx \
types/sample.cmx types/ident.cmx misc/custom.cmx types/chars.cmx \
types/atoms.cmx types/patterns.cmi
compile/auto_opt.cmo: types/types.cmi misc/stats.cmi types/patterns.cmi \
types/ident.cmo compile/auto_opt.cmi
compile/auto_opt.cmx: types/types.cmx misc/stats.cmx types/patterns.cmx \
types/ident.cmx compile/auto_opt.cmi
types/builtin_defs.cmo: types/types.cmi types/sequence.cmi misc/ns.cmi \
types/intervals.cmi types/ident.cmo misc/encodings.cmi types/chars.cmi \
types/atoms.cmi types/builtin_defs.cmi
......@@ -198,10 +202,12 @@ runtime/run_dispatch.cmx: runtime/value.cmx types/types.cmx \
types/atoms.cmx runtime/run_dispatch.cmi
runtime/explain.cmo: runtime/value.cmi types/types.cmi \
runtime/run_dispatch.cmi types/patterns.cmi types/ident.cmo \
misc/encodings.cmi types/chars.cmi types/atoms.cmi runtime/explain.cmi
misc/encodings.cmi types/chars.cmi compile/auto_opt.cmi types/atoms.cmi \
runtime/explain.cmi
runtime/explain.cmx: runtime/value.cmx types/types.cmx \
runtime/run_dispatch.cmx types/patterns.cmx types/ident.cmx \
misc/encodings.cmx types/chars.cmx types/atoms.cmx runtime/explain.cmi
misc/encodings.cmx types/chars.cmx compile/auto_opt.cmx types/atoms.cmx \
runtime/explain.cmi
runtime/print_xml.cmo: runtime/value.cmi types/sequence.cmi \
schema/schema_builtin.cmi misc/ns.cmi types/intervals.cmi types/ident.cmo \
misc/encodings.cmi types/atoms.cmi runtime/print_xml.cmi
......@@ -211,11 +217,11 @@ runtime/print_xml.cmx: runtime/value.cmx types/sequence.cmx \
runtime/eval.cmo: runtime/value.cmi types/types.cmi typing/typer.cmi \
schema/schema_common.cmi runtime/run_dispatch.cmi types/patterns.cmi \
misc/ns.cmi compile/lambda.cmi types/ident.cmo runtime/explain.cmi \
runtime/eval.cmi
compile/auto_opt.cmi runtime/eval.cmi
runtime/eval.cmx: runtime/value.cmx types/types.cmx typing/typer.cmx \
schema/schema_common.cmx runtime/run_dispatch.cmx types/patterns.cmx \
misc/ns.cmx compile/lambda.cmx types/ident.cmx runtime/explain.cmx \
runtime/eval.cmi
compile/auto_opt.cmx runtime/eval.cmi
compile/compile.cmo: types/types.cmi typing/typer.cmi typing/typed.cmo \
misc/serialize.cmi types/patterns.cmi parser/location.cmi \
compile/lambda.cmi types/ident.cmo runtime/eval.cmi parser/ast.cmo \
......@@ -363,6 +369,7 @@ types/sample.cmi: types/types.cmi
types/sequence.cmi: types/types.cmi types/atoms.cmi
types/patterns.cmi: types/types.cmi types/ident.cmo misc/custom.cmo \
types/chars.cmi types/atoms.cmi
compile/auto_opt.cmi: types/types.cmi types/patterns.cmi
types/builtin_defs.cmi: types/types.cmi types/ident.cmo types/atoms.cmi
compile/lambda.cmi: types/types.cmi misc/serialize.cmi types/patterns.cmi \
misc/ns.cmi types/ident.cmo
......
......@@ -22,13 +22,15 @@ let make_accu () = Value.Pair(nil,Absent)
let get_accu a = snd (Obj.magic a)
let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0
let make_branches = Patterns.Compile.(*Auto_opt.*)make_branches
let dispatcher brs =
match brs.brs_compiled with
| Some d -> d
| None ->
(* Format.fprintf Format.std_formatter "Start compilation...@.";
let time = Unix.gettimeofday() in*)
let x = Patterns.Compile.make_branches brs.brs_input brs.brs in
let x = make_branches brs.brs_input brs.brs in
(* let time = Unix.gettimeofday() -. time in
if time > 1.0 then
Format.fprintf Format.std_formatter "%a@."
......@@ -327,8 +329,7 @@ let var v =
let eval_split p =
assert (!frame = 0);
let comp = Patterns.Compile.make_branches
(Types.descr (Patterns.accept p)) [ p, () ] in
let comp = make_branches (Types.descr (Patterns.accept p)) [ p, () ] in
let (disp, bind) =
match comp with
| (disp, [| Patterns.Compile.Match (l, ()) |]) -> (disp,l)
......
......@@ -155,7 +155,7 @@ let rec simplify = function
let check t0 t =
let p = Patterns.make IdSet.empty in
Patterns.define p (Patterns.constr t);
let (d,rhs) = make_branches t0 [ (p,()) ] in
let (d,rhs) = (*Auto_opt.*)Patterns.Compile.make_branches t0 [ (p,()) ] in
(* The instrumented dispatcher is slower, so we first try the normal
one. This is optimized for the case where the value matches. *)
fun v ->
......
......@@ -39,8 +39,6 @@ let push v =
incr cursor
(* Old dispatchers *)
let make_result_prod v1 v2 v (code,r,pop) =
let n = Array.length r in
if n > 0 then (
......
......@@ -835,7 +835,6 @@ module Normal = struct
aux_check [] Types.empty ResultMap.empty (Types.cap t any_basic)
IdMap.empty (List.map descr pl)
(*
let prod_tests (pl,t,xs) =
let rec aux accu q1 q2 res = function
| [] -> (res,q1,q2) :: accu
......@@ -877,7 +876,6 @@ module Normal = struct
accu (Types.Product.clean_normal (Types.Product.normal t))
in
aux_check [] ncany ncany IdMap.empty t (List.map descr pl)
*)
end
......@@ -930,6 +928,8 @@ struct
mutable printed : bool
}
let id d = d.id
let types_of_codes d = Array.map (fun (t,ar,_) -> t) d.codes
let equal_array f a1 a2 =
......@@ -1184,7 +1184,7 @@ struct
module TypeList = SortedList.Make(Types)
let dispatch_basic disp pl : (Types.t * result) list =
let dispatch_basic disp : (Types.t * result) list =
let tests =
let accu = ref [] in
let aux i res t = accu := (t, [i,res]) :: !accu in
......@@ -1197,7 +1197,7 @@ struct
if Types.non_empty t
then match l with
| [] ->
let selected = Array.create (Array.length pl) [] in
let selected = Array.create (Array.length disp.pl) [] in
let add (i,res) = selected.(i) <- res :: selected.(i) in
List.iter add success;
accu := (t, return_basic disp selected) :: !accu
......@@ -1280,8 +1280,8 @@ struct
let dispatch_prod disp pl =
let t = Types.Product.get disp.t in
dispatch_prod0 disp t
(Array.map (fun p -> Normal.NLineProd.elements p.Normal.nprod) pl)
(* dispatch_prod0 disp t (Array.map Normal.prod_tests disp.pl) *)
(Array.map (fun p -> Normal.NLineProd.elements p.Normal.nprod) pl)
(* dispatch_prod0 disp t (Array.map Normal.prod_tests disp.pl) *)
let dispatch_xml disp pl =
let t = Types.Product.get ~kind:`XML disp.t in
......@@ -1345,20 +1345,18 @@ struct
let pl = Array.map (Normal.nnf disp.label disp.t) disp.pl in
let a = combine_kind
(dispatch_basic disp pl)
(dispatch_basic disp)
(dispatch_prod disp pl)
(dispatch_xml disp pl)
(dispatch_record disp pl)
in
disp.actions <- Some a;
iter_disp_actions (fun d -> to_generate := d :: !to_generate) a;
incr generated;
incr generated;
a
let to_print = ref []
module DSET = Set.Make (struct type t = int let compare (x:t) (y:t) = x - y end)
let printed = ref DSET.empty
......
......@@ -41,6 +41,7 @@ val filter : Types.t -> node -> Types.Node.t id_map
module Compile: sig
type dispatcher
val id: dispatcher -> int
type source =
| Catch | Const of Types.const
......@@ -74,15 +75,14 @@ module Compile: sig
val types_of_codes: dispatcher -> Types.t array
type 'a rhs = Match of (id * int) list * 'a | Fail
(* ids are listed in the same order as returned by fv_list,
not fv ! *)
val make_branches : Types.t -> (node * 'a) list -> dispatcher * 'a rhs array
val print_dispatcher: Format.formatter -> dispatcher -> unit
val debug_compile : Format.formatter -> Types.Node.t -> node list -> unit
val iter_disp_actions : (dispatcher -> unit) -> actions -> unit
end
......
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