Commit 58c7c621 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-06-13 15:20:13 by afrisch] Simplifications

Original author: afrisch
Date: 2005-06-13 15:20:14+00:00
parent 3cd1a52f
...@@ -145,6 +145,7 @@ OBJECTS = \ ...@@ -145,6 +145,7 @@ OBJECTS = \
misc/state.cmo misc/pool.cmo misc/encodings.cmo \ misc/state.cmo misc/pool.cmo misc/encodings.cmo \
misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo misc/imap.cmo \ misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo misc/imap.cmo \
misc/html.cmo \ misc/html.cmo \
misc/ptmap.cmo misc/hashset.cmo \
\ \
types/sortedList.cmo misc/bool.cmo types/boolean.cmo types/ident.cmo \ types/sortedList.cmo misc/bool.cmo types/boolean.cmo types/ident.cmo \
types/intervals.cmo \ types/intervals.cmo \
......
...@@ -26,11 +26,13 @@ misc/imap.cmo: misc/imap.cmi ...@@ -26,11 +26,13 @@ misc/imap.cmo: misc/imap.cmi
misc/imap.cmx: misc/imap.cmi misc/imap.cmx: misc/imap.cmi
misc/html.cmo: misc/html.cmi misc/html.cmo: misc/html.cmi
misc/html.cmx: misc/html.cmi misc/html.cmx: misc/html.cmi
misc/ptmap.cmo: misc/ptmap.cmi
misc/ptmap.cmx: misc/ptmap.cmi
types/sortedList.cmo: misc/serialize.cmi misc/custom.cmo types/sortedList.cmi types/sortedList.cmo: misc/serialize.cmi misc/custom.cmo types/sortedList.cmi
types/sortedList.cmx: misc/serialize.cmx misc/custom.cmx types/sortedList.cmi types/sortedList.cmx: misc/serialize.cmx misc/custom.cmx types/sortedList.cmi
misc/bool.cmo: types/sortedList.cmi misc/serialize.cmi misc/custom.cmo \ misc/bool.cmo: misc/serialize.cmi misc/hashset.cmo misc/custom.cmo \
misc/bool.cmi misc/bool.cmi
misc/bool.cmx: types/sortedList.cmx misc/serialize.cmx misc/custom.cmx \ misc/bool.cmx: misc/serialize.cmx misc/hashset.cmx misc/custom.cmx \
misc/bool.cmi misc/bool.cmi
types/boolean.cmo: types/sortedList.cmi misc/custom.cmo types/boolean.cmi types/boolean.cmo: types/sortedList.cmi misc/custom.cmo types/boolean.cmi
types/boolean.cmx: types/sortedList.cmx misc/custom.cmx types/boolean.cmi types/boolean.cmx: types/sortedList.cmx misc/custom.cmx types/boolean.cmi
......
...@@ -200,7 +200,7 @@ let debug ppf tenv cenv = function ...@@ -200,7 +200,7 @@ let debug ppf tenv cenv = function
Format.fprintf ppf "[DEBUG:compile]@."; Format.fprintf ppf "[DEBUG:compile]@.";
let t = Typer.typ tenv t let t = Typer.typ tenv t
and pl = List.map (Typer.pat tenv) pl in and pl = List.map (Typer.pat tenv) pl in
Patterns.Compile2.debug_compile ppf t pl; Patterns.Compile.debug_compile ppf t pl;
Format.fprintf ppf "@."; Format.fprintf ppf "@.";
(* (*
......
This diff is collapsed.
...@@ -4,6 +4,7 @@ sig ...@@ -4,6 +4,7 @@ sig
type elem type elem
val get: t -> (elem list * elem list) list val get: t -> (elem list * elem list) list
val get': t -> (elem list * (elem list) list) list
val empty : t val empty : t
val full : t val full : t
...@@ -30,6 +31,7 @@ module type MAKE = functor (X : Custom.T) -> S with type elem = X.t ...@@ -30,6 +31,7 @@ module type MAKE = functor (X : Custom.T) -> S with type elem = X.t
module Make : MAKE module Make : MAKE
(*
module type S' = sig module type S' = sig
include S include S
type bdd = False | True | Br of elem * t * t type bdd = False | True | Br of elem * t * t
...@@ -38,12 +40,10 @@ end ...@@ -38,12 +40,10 @@ end
module MakeBdd(X : Custom.T) : S' with type elem = X.t module MakeBdd(X : Custom.T) : S' with type elem = X.t
(*
module type S'' = sig module type S'' = sig
include S include S
type tree = Split of elem list * elem list * tree list option val dnf: (elem list -> (elem list) list -> unit) -> t -> unit
val get_tree: t -> tree
end end
module Simplify(X : Custom.T) : S'' with type elem = X.t module Make2(X : Custom.T) : S'' with type elem = X.t
*) *)
...@@ -599,6 +599,8 @@ module Normal = struct ...@@ -599,6 +599,8 @@ module Normal = struct
module NodeSet = SortedList.Make(Node) module NodeSet = SortedList.Make(Node)
module Nnf = struct module Nnf = struct
include Custom.Dummy
type t = NodeSet.t * Types.t * IdSet.t (* pl,t; t <= \accept{pl} *) type t = NodeSet.t * Types.t * IdSet.t (* pl,t; t <= \accept{pl} *)
let check (pl,t,xs) = let check (pl,t,xs) =
...@@ -909,6 +911,13 @@ module Normal = struct ...@@ -909,6 +911,13 @@ module Normal = struct
IdSet.empty IdSet.empty
pl pl
let factorize t0 (pl,t,xs) =
let t0 = if Types.subtype t t0 then t else Types.cap t t0 in
let vs_var = facto Factorize.var t0 xs pl in
let xs = IdSet.diff xs vs_var in
let vs_nil = facto Factorize.nil t0 xs pl in
(vs_var,vs_nil,(pl,t,xs))
let normal f l t pl xs = let normal f l t pl xs =
let a = nconstr l t in let a = nconstr l t in
...@@ -936,7 +945,7 @@ module Normal = struct ...@@ -936,7 +945,7 @@ module Normal = struct
let t = let t =
if Types.subtype t t0 then t else Types.cap t t0 in if Types.subtype t t0 then t else Types.cap t t0 in
(* let ppf = Format.std_formatter in (* let ppf = Format.std_formatter in
Format.fprintf ppf "normal nnf=%a@." Nnf.print (pl,t,xs); *) Format.fprintf ppf "normal nnf=%a@." Nnf.print (pl,t,xs); *)
normal facto lab t (NodeSet.get pl) xs normal facto lab t (NodeSet.get pl) xs
...@@ -1000,7 +1009,7 @@ struct ...@@ -1000,7 +1009,7 @@ struct
and dispatcher = { and dispatcher = {
id : int; id : int;
t : Types.t; t : Types.t;
pl : Normal.t array; pl : Normal.Nnf.t array;
label : label option; label : label option;
interface : interface; interface : interface;
codes : return_code array; codes : return_code array;
...@@ -1112,10 +1121,10 @@ struct ...@@ -1112,10 +1121,10 @@ struct
let cur_id = State.ref "Patterns.cur_id" 0 let cur_id = State.ref "Patterns.cur_id" 0
(* TODO: save dispatchers ? *) (* TODO: save dispatchers ? *)
module NfMap = Map.Make(Normal) module NfMap = Map.Make(Normal.Nnf)
module NfSet = Set.Make(Normal) module NfSet = Set.Make(Normal.Nnf)
module DispMap = Map.Make(Custom.Pair(Types)(Custom.Array(Normal))) module DispMap = Map.Make(Custom.Pair(Types)(Custom.Array(Normal.Nnf)))
(* Try with a hash-table ! *) (* Try with a hash-table ! *)
...@@ -1136,7 +1145,7 @@ struct ...@@ -1136,7 +1145,7 @@ struct
let ppf = Format.std_formatter in let ppf = Format.std_formatter in
Format.fprintf ppf "Dispatcher t=%a@." Types.Print.print disp.t; Format.fprintf ppf "Dispatcher t=%a@." Types.Print.print disp.t;
Array.iter (fun p -> Array.iter (fun p ->
Format.fprintf ppf " pat %a@." Normal.print p; Format.fprintf ppf " pat %a@." Normal.Nnf.print p;
) disp.pl ) disp.pl
let dispatcher t pl lab : dispatcher = let dispatcher t pl lab : dispatcher =
...@@ -1149,14 +1158,11 @@ struct ...@@ -1149,14 +1158,11 @@ struct
then (incr nb; let r = Array.of_list (List.rev accu) in then (incr nb; let r = Array.of_list (List.rev accu) in
codes := (t,arity,r)::!codes; `Result (!nb - 1)) codes := (t,arity,r)::!codes; `Result (!nb - 1))
else else
let p = pl.(i) in let (_,tp,v) = pl.(i) in
let tp = p.Normal.na in
let a1 = Types.cap t tp in let a1 = Types.cap t tp in
if Types.is_empty a1 then if Types.is_empty a1 then
`Switch (`None,aux t arity (i+1) (None::accu)) `Switch (`None,aux t arity (i+1) (None::accu))
else else
let v = p.Normal.nfv in
let a2 = Types.diff t tp in let a2 = Types.diff t tp in
let accu' = Some (IdMap.num arity v) :: accu in let accu' = Some (IdMap.num arity v) :: accu in
if Types.is_empty a2 then if Types.is_empty a2 then
...@@ -1243,9 +1249,9 @@ struct ...@@ -1243,9 +1249,9 @@ struct
| (l,r) -> Recompose (l,r)) | (l,r) -> Recompose (l,r))
module TypeList = SortedList.Make(Types) module TypeList = SortedList.Make(Types)
let dispatch_basic disp : (Types.t * result) list = let dispatch_basic disp pl : (Types.t * result) list =
(* TODO: try other algo, using disp.codes .... *) (* TODO: try other algo, using disp.codes .... *)
let pl = Array.map (fun p -> p.Normal.nbasic) disp.pl in let pl = Array.map (fun p -> p.Normal.nbasic) pl in
let tests = let tests =
let accu = ref [] in let accu = ref [] in
let aux i (res,x) = accu := (x, [i,res]) :: !accu in let aux i (res,x) = accu := (x, [i,res]) :: !accu in
...@@ -1280,24 +1286,31 @@ struct ...@@ -1280,24 +1286,31 @@ struct
let get_tests facto pl f t d post = let get_tests facto pl f t d post =
let pl = Array.map (List.map f) pl in let pl = Array.map (List.map f) pl in
let lab = first_lab t pl in let lab = first_lab t pl in
let pl = Array.map (List.map (fun (x,info) -> Normal.nnf facto lab t x,info)) pl
in
(* Collect all subrequests *) (* Collect all subrequests *)
let aux reqs ((_,_,req),_) = NfSet.add req reqs in let aux reqs (req,_) = NfSet.add req reqs in
let reqs = Array.fold_left (List.fold_left aux) NfSet.empty pl in let reqs = Array.fold_left (List.fold_left aux) NfSet.empty pl in
let reqs = Array.of_list (NfSet.elements reqs) in let reqs = Array.of_list (NfSet.elements reqs) in
(* Map subrequest -> idx in reqs *) (* Map subrequest -> idx in reqs *)
let idx = ref NfMap.empty in let idx = ref NfMap.empty in
Array.iteri (fun i req -> idx := NfMap.add req i !idx) reqs; Array.iteri (fun i req -> idx := NfMap.add req i !idx) reqs;
let idx = !idx in let idx = !idx in
(* Build dispatcher *) (* Build dispatcher *)
let reqs_facto =
if facto then Array.map (Normal.factorize t) reqs
else Array.map (fun r -> [],[],r) reqs in
let reqs = Array.map (fun (_,_,req) -> req) reqs_facto in
let disp = dispatcher t reqs lab in let disp = dispatcher t reqs lab in
(* Build continuation *) (* Build continuation *)
let result (t,ar,m) = let result (t,ar,m) =
let get a ((vars,nils,req),info) = let get a (req,info) =
match m.(NfMap.find req idx) with Some res -> ((vars,nils,res),info)::a | _ -> a in let i = NfMap.find req idx in
let (var,nil,_) = reqs_facto.(i) in
match m.(i) with Some res -> ((var,nil,res),info)::a | _ -> a in
let pl = Array.map (List.fold_left get []) pl in let pl = Array.map (List.fold_left get []) pl in
d t ar pl d t ar pl
in in
...@@ -1310,8 +1323,9 @@ struct ...@@ -1310,8 +1323,9 @@ struct
let t0 = ref t in let t0 = ref t in
let aux (p,e) = let aux (p,e) =
let xs = fv p in let xs = fv p in
let nnf = (Normal.NodeSet.singleton p, !t0, xs) in let tp = Types.descr (accept p) in
t0 := Types.diff !t0 (Types.descr (accept p)); let nnf = (Normal.NodeSet.singleton p, Types.cap !t0 tp, xs) in
t0 := Types.diff !t0 tp;
[(nnf, (xs, e))] in [(nnf, (xs, e))] in
let res _ _ pl = let res _ _ pl =
let aux r = function let aux r = function
...@@ -1324,12 +1338,12 @@ struct ...@@ -1324,12 +1338,12 @@ struct
get_tests false pl (fun x -> x) t res (fun x -> x) get_tests false pl (fun x -> x) t res (fun x -> x)
let rec dispatch_prod ?(kind=`Normal) disp = let rec dispatch_prod ?(kind=`Normal) disp pl =
let extr = match kind with let extr = match kind with
| `Normal -> fun p -> Normal.NLineProd.get p.Normal.nprod | `Normal -> fun p -> Normal.NLineProd.get p.Normal.nprod
| `XML -> fun p -> Normal.NLineProd.get p.Normal.nxml in | `XML -> fun p -> Normal.NLineProd.get p.Normal.nxml in
let t = Types.Product.get ~kind disp.t in let t = Types.Product.get ~kind disp.t in
dispatch_prod0 disp t (Array.map extr disp.pl) dispatch_prod0 disp t (Array.map extr pl)
and dispatch_prod0 disp t pl = and dispatch_prod0 disp t pl =
get_tests true pl get_tests true pl
(fun (res,p,q) -> p, (res,q)) (fun (res,p,q) -> p, (res,q))
...@@ -1348,7 +1362,7 @@ struct ...@@ -1348,7 +1362,7 @@ struct
return disp pl aux_final (ar1 + ar2) return disp pl aux_final (ar1 + ar2)
let dispatch_record disp : record option = let dispatch_record disp pl : record option =
let t = disp.t in let t = disp.t in
if not (Types.Record.has_record t) then None if not (Types.Record.has_record t) then None
else else
...@@ -1360,7 +1374,7 @@ struct ...@@ -1360,7 +1374,7 @@ struct
let pl = Array.map (fun p -> match p.Normal.nrecord with let pl = Array.map (fun p -> match p.Normal.nrecord with
| Normal.RecNolabel (Some x,_) -> [x] | Normal.RecNolabel (Some x,_) -> [x]
| Normal.RecNolabel (None,_) -> [] | Normal.RecNolabel (None,_) -> []
| _ -> assert false) disp.pl in | _ -> assert false) pl in
Some (return disp pl (IdMap.map_to_list conv_source_basic) 0) Some (return disp pl (IdMap.map_to_list conv_source_basic) 0)
else None else None
in in
...@@ -1369,7 +1383,7 @@ struct ...@@ -1369,7 +1383,7 @@ struct
let pl = Array.map (fun p -> match p.Normal.nrecord with let pl = Array.map (fun p -> match p.Normal.nrecord with
| Normal.RecNolabel (_,Some x) -> [x] | Normal.RecNolabel (_,Some x) -> [x]
| Normal.RecNolabel (_,None) -> [] | Normal.RecNolabel (_,None) -> []
| _ -> assert false) disp.pl in | _ -> assert false) pl in
Some (return disp pl (IdMap.map_to_list conv_source_basic) 0) Some (return disp pl (IdMap.map_to_list conv_source_basic) 0)
else None else None
in in
...@@ -1379,7 +1393,7 @@ struct ...@@ -1379,7 +1393,7 @@ struct
let pl = Array.map (fun p -> match p.Normal.nrecord with let pl = Array.map (fun p -> match p.Normal.nrecord with
| Normal.RecLabel (_,l) -> | Normal.RecLabel (_,l) ->
Normal.NLineProd.get l Normal.NLineProd.get l
| _ -> assert false) disp.pl in | _ -> assert false) pl in
Some (RecLabel (lab,dispatch_prod0 disp t pl)) Some (RecLabel (lab,dispatch_prod0 disp t pl))
let iter_disp_disp f g = function let iter_disp_disp f g = function
...@@ -1402,11 +1416,16 @@ struct ...@@ -1402,11 +1416,16 @@ struct
match disp.actions with match disp.actions with
| Some a -> a | Some a -> a
| None -> | None ->
let pl =
Array.map
(fun n -> let _,_,p = Normal.nnf false disp.label disp.t n in p)
disp.pl in
let a = combine_kind let a = combine_kind
(dispatch_basic disp) (dispatch_basic disp pl)
(dispatch_prod disp) (dispatch_prod disp pl)
(dispatch_prod ~kind:`XML disp) (dispatch_prod ~kind:`XML disp pl)
(dispatch_record disp) (dispatch_record disp pl)
in in
disp.actions <- Some a; disp.actions <- Some a;
iter_disp_actions (fun d -> to_generate := d :: !to_generate) a; iter_disp_actions (fun d -> to_generate := d :: !to_generate) a;
...@@ -1585,13 +1604,8 @@ struct ...@@ -1585,13 +1604,8 @@ struct
(Types.Record.first_label t) pl in (Types.Record.first_label t) pl in
let lab = if lab == LabelPool.dummy_max then None else Some lab in let lab = if lab == LabelPool.dummy_max then None else Some lab in
let pl = Array.of_list let pl = Array.of_list
(List.map (fun p -> (List.map (fun p -> ([p],Types.cap t (Types.descr (accept p)),fv p)) pl) in
let n = Normal.nnf false lab t ([p],t,fv p) in
match n with
| [],[],x -> x
| _ -> assert false
) pl) in
show ppf t pl lab; show ppf t pl lab;
Format.fprintf ppf "# compiled states: %i@\n" !generated Format.fprintf ppf "# compiled states: %i@\n" !generated
...@@ -1612,7 +1626,6 @@ end ...@@ -1612,7 +1626,6 @@ end
(****** More efficient compilation (less optimized) ******) (****** More efficient compilation (less optimized) ******)
module Compile2 = module Compile2 =
struct struct
type source = type source =
...@@ -2032,6 +2045,41 @@ struct ...@@ -2032,6 +2045,41 @@ struct
| None -> map_filter f tl | None -> map_filter f tl
| Some x -> x :: (map_filter f tl) | Some x -> x :: (map_filter f tl)
(*
let cup x y t =
match x t with
| `Binds _ as r1 -> r1
| `Fail -> y t
| r1 -> match y t with
| `Fail -> r1
| r2 -> `Cup (r1,r2)
let cap x y t =
match x t with
| `Fail -> `Fail
| `Binds b1 as r1 ->
(match y t with
| `Fail -> `Fail
| `Binds b2 -> `Binds (LabelMap.union_disj b1 b2)
| r2 -> `Cap (r1,r2))
| r1 -> match y t with
| `Fail -> `Fail
| r2 -> `Cap (r1,r2)
let rec prod_tests t0 d tests1 = match d with
| Req.RBinds b -> `Binds b
| Req.RTimes (q1,q2,xs,_) ->
`Times (reg_test tests1 (Types.Product.pi1 t0) q1 xs,q2,xs)
| Req.RCup (p1,p2) -> cup (prod_tests t0 p1) (prod_tests t0 p2) tests1
| Req.RCap (p2,p1) -> cap (prod_tests t0 p1) (prod_tests t0 p2) tests1
| Req.RConstr s ->
let rects = Types.Product.get ~kind:`Normal s in
let rects = List.map (fun (s1,s2) -> reg_test_type tests1 s1, s2) rects in
`Prod rects
| _ -> `Fail
*)
let rec prod_tests t0 d tests1 = match d with let rec prod_tests t0 d tests1 = match d with
| Req.RBinds b -> (fun t1 ar1 tests2 ar2 -> Some b) | Req.RBinds b -> (fun t1 ar1 tests2 ar2 -> Some b)
| Req.RTimes (q1,q2,xs,_) -> | Req.RTimes (q1,q2,xs,_) ->
......
...@@ -11,7 +11,6 @@ let (input,outdir) = ...@@ -11,7 +11,6 @@ let (input,outdir) =
| [ s ("-o" o | /(o := "www")) ] -> (s,o) | [ s ("-o" o | /(o := "www")) ] -> (s,o)
| _ -> raise "Please use --arg to specify an input file on the command line" | _ -> raise "Please use --arg to specify an input file on the command line"
(** Generic purpose functions **) (** Generic purpose functions **)
(* Recursive inclusion of XML files and verbatim text files *) (* Recursive inclusion of XML files and verbatim text files *)
...@@ -35,8 +34,6 @@ let [<site>[ <title>site (<footer>footer | /(footer:=[])) main_page ] ] = ...@@ -35,8 +34,6 @@ let [<site>[ <title>site (<footer>footer | /(footer:=[])) main_page ] ] =
print ['Invalid input document:\n' !err '\n']; print ['Invalid input document:\n' !err '\n'];
exit 2 exit 2
(* Highlighting text between {{...}} *) (* Highlighting text between {{...}} *)
let highlight (String -> [ (Char | H.strong | H.i)* ] ) let highlight (String -> [ (Char | H.strong | H.i)* ] )
...@@ -392,7 +389,7 @@ match page with ...@@ -392,7 +389,7 @@ match page with
(* Preparing left panel *) (* Preparing left panel *)
let left = let left =
if leftbar then if leftbar then
let navig = transform items with <left>c -> [ c ] in let navig = transform items with <left>c -> [ c ] in
let left = match navig with [] -> [ [<boxes-toc>[]] ] | n -> n in let left = match navig with [] -> [ [<boxes-toc>[]] ] | n -> n in
......
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