Skip to content
GitLab
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
Expand all Hide whitespace changes
Inline Side-by-side
Makefile.distrib
View file @ 58c7c621
......@@ -145,6 +145,7 @@ OBJECTS = \
misc/state.cmo misc/pool.cmo misc/encodings.cmo \
misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo misc/imap.cmo \
misc/html.cmo \
misc/ptmap.cmo misc/hashset.cmo \
\
types/sortedList.cmo misc/bool.cmo types/boolean.cmo types/ident.cmo \
types/intervals.cmo \
......
depend
View file @ 58c7c621
......@@ -26,11 +26,13 @@ misc/imap.cmo: misc/imap.cmi
misc/imap.cmx: misc/imap.cmi
misc/html.cmo: 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.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.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
types/boolean.cmo: types/sortedList.cmi misc/custom.cmo types/boolean.cmi
types/boolean.cmx: types/sortedList.cmx misc/custom.cmx types/boolean.cmi
......
driver/cduce.ml
View file @ 58c7c621
......@@ -200,7 +200,7 @@ let debug ppf tenv cenv = function
Format.fprintf ppf "[DEBUG:compile]@.";
let t = Typer.typ tenv t
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 "@.";
(*
......
misc/bool.ml
View file @ 58c7c621
This diff is collapsed.
misc/bool.mli
View file @ 58c7c621
......@@ -4,6 +4,7 @@ sig
type elem
val get: t -> (elem list * elem list) list
val get': t -> (elem list * (elem list) list) list
val empty : t
val full : t
......@@ -30,6 +31,7 @@ module type MAKE = functor (X : Custom.T) -> S with type elem = X.t
module Make : MAKE
(*
module type S' = sig
include S
type bdd = False | True | Br of elem * t * t
......@@ -38,12 +40,10 @@ end
module MakeBdd(X : Custom.T) : S' with type elem = X.t
(*
module type S'' = sig
include S
type tree = Split of elem list * elem list * tree list option
val get_tree: t -> tree
val dnf: (elem list -> (elem list) list -> unit) -> t -> unit
end
module Simplify(X : Custom.T) : S'' with type elem = X.t
module Make2(X : Custom.T) : S'' with type elem = X.t
*)
types/patterns.ml
View file @ 58c7c621
......@@ -599,6 +599,8 @@ module Normal = struct
module NodeSet = SortedList.Make(Node)
module Nnf = struct
include Custom.Dummy
type t = NodeSet.t * Types.t * IdSet.t (* pl,t; t <= \accept{pl} *)
let check (pl,t,xs) =
......@@ -909,6 +911,13 @@ module Normal = struct
IdSet.empty
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 a = nconstr l t in
......@@ -936,7 +945,7 @@ module Normal = struct
let t =
if Types.subtype t t0 then t else Types.cap t t0 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
......@@ -1000,7 +1009,7 @@ struct
and dispatcher = {
id : int;
t : Types.t;
pl : Normal.t array;
pl : Normal.Nnf.t array;
label : label option;
interface : interface;
codes : return_code array;
......@@ -1112,10 +1121,10 @@ struct
let cur_id = State.ref "Patterns.cur_id" 0
(* TODO: save dispatchers ? *)
module NfMap = Map.Make(Normal)
module NfSet = Set.Make(Normal)
module NfMap = Map.Make(Normal.Nnf)
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 ! *)
......@@ -1136,7 +1145,7 @@ struct
let ppf = Format.std_formatter in
Format.fprintf ppf "Dispatcher t=%a@." Types.Print.print disp.t;
Array.iter (fun p ->
Format.fprintf ppf " pat %a@." Normal.print p;
Format.fprintf ppf " pat %a@." Normal.Nnf.print p;
) disp.pl
let dispatcher t pl lab : dispatcher =
......@@ -1149,14 +1158,11 @@ struct
then (incr nb; let r = Array.of_list (List.rev accu) in
codes := (t,arity,r)::!codes; `Result (!nb - 1))
else
let p = pl.(i) in
let tp = p.Normal.na in
let (_,tp,v) = pl.(i) in
let a1 = Types.cap t tp in
if Types.is_empty a1 then
`Switch (`None,aux t arity (i+1) (None::accu))
else
let v = p.Normal.nfv in
let a2 = Types.diff t tp in
let accu' = Some (IdMap.num arity v) :: accu in
if Types.is_empty a2 then
......@@ -1243,9 +1249,9 @@ struct
| (l,r) -> Recompose (l,r))
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 .... *)
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 accu = ref [] in
let aux i (res,x) = accu := (x, [i,res]) :: !accu in
......@@ -1280,24 +1286,31 @@ struct
let get_tests facto pl f t d post =
let pl = Array.map (List.map f) 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 *)
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.of_list (NfSet.elements reqs) in
(* Map subrequest -> idx in reqs *)
let idx = ref NfMap.empty in
Array.iteri (fun i req -> idx := NfMap.add req i !idx) reqs;
let idx = !idx in
(* 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
(* Build continuation *)
let result (t,ar,m) =
let get a ((vars,nils,req),info) =
match m.(NfMap.find req idx) with Some res -> ((vars,nils,res),info)::a | _ -> a in
let get a (req,info) =
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
d t ar pl
in
......@@ -1310,8 +1323,9 @@ struct
let t0 = ref t in
let aux (p,e) =
let xs = fv p in
let nnf = (Normal.NodeSet.singleton p, !t0, xs) in
t0 := Types.diff !t0 (Types.descr (accept p));
let tp = Types.descr (accept p) in
let nnf = (Normal.NodeSet.singleton p, Types.cap !t0 tp, xs) in
t0 := Types.diff !t0 tp;
[(nnf, (xs, e))] in
let res _ _ pl =
let aux r = function
......@@ -1324,12 +1338,12 @@ struct
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
| `Normal -> fun p -> Normal.NLineProd.get p.Normal.nprod
| `XML -> fun p -> Normal.NLineProd.get p.Normal.nxml 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 =
get_tests true pl
(fun (res,p,q) -> p, (res,q))
......@@ -1348,7 +1362,7 @@ struct
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
if not (Types.Record.has_record t) then None
else
......@@ -1360,7 +1374,7 @@ struct
let pl = Array.map (fun p -> match p.Normal.nrecord with
| Normal.RecNolabel (Some x,_) -> [x]
| Normal.RecNolabel (None,_) -> []
| _ -> assert false) disp.pl in
| _ -> assert false) pl in
Some (return disp pl (IdMap.map_to_list conv_source_basic) 0)
else None
in
......@@ -1369,7 +1383,7 @@ struct
let pl = Array.map (fun p -> match p.Normal.nrecord with
| Normal.RecNolabel (_,Some x) -> [x]
| Normal.RecNolabel (_,None) -> []
| _ -> assert false) disp.pl in
| _ -> assert false) pl in
Some (return disp pl (IdMap.map_to_list conv_source_basic) 0)
else None
in
......@@ -1379,7 +1393,7 @@ struct
let pl = Array.map (fun p -> match p.Normal.nrecord with
| Normal.RecLabel (_,l) ->
Normal.NLineProd.get l
| _ -> assert false) disp.pl in
| _ -> assert false) pl in
Some (RecLabel (lab,dispatch_prod0 disp t pl))
let iter_disp_disp f g = function
......@@ -1402,11 +1416,16 @@ struct
match disp.actions with
| Some a -> a
| 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
(dispatch_basic disp)
(dispatch_prod disp)
(dispatch_prod ~kind:`XML disp)
(dispatch_record disp)
(dispatch_basic disp pl)
(dispatch_prod disp pl)
(dispatch_prod ~kind:`XML disp pl)
(dispatch_record disp pl)
in
disp.actions <- Some a;
iter_disp_actions (fun d -> to_generate := d :: !to_generate) a;
......@@ -1585,13 +1604,8 @@ struct
(Types.Record.first_label t) pl in
let lab = if lab == LabelPool.dummy_max then None else Some lab in
let pl = Array.of_list
(List.map (fun p ->
let n = Normal.nnf false lab t ([p],t,fv p) in
match n with
| [],[],x -> x
| _ -> assert false
) pl) in
let pl = Array.of_list
(List.map (fun p -> ([p],Types.cap t (Types.descr (accept p)),fv p)) pl) in
show ppf t pl lab;
Format.fprintf ppf "# compiled states: %i@\n" !generated
......@@ -1612,7 +1626,6 @@ end
(****** More efficient compilation (less optimized) ******)
module Compile2 =
struct
type source =
......@@ -2032,6 +2045,41 @@ struct
| None -> 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
| Req.RBinds b -> (fun t1 ar1 tests2 ar2 -> Some b)
| Req.RTimes (q1,q2,xs,_) ->
......
web/site.cd
View file @ 58c7c621
......@@ -11,7 +11,6 @@ let (input,outdir) =
| [ s ("-o" o | /(o := "www")) ] -> (s,o)
| _ -> raise "Please use --arg to specify an input file on the command line"
(** Generic purpose functions **)
(* Recursive inclusion of XML files and verbatim text files *)
......@@ -35,8 +34,6 @@ let [<site>[ <title>site (<footer>footer | /(footer:=[])) main_page ] ] =
print ['Invalid input document:\n' !err '\n'];
exit 2
(* Highlighting text between {{...}} *)
let highlight (String -> [ (Char | H.strong | H.i)* ] )
......@@ -392,7 +389,7 @@ match page with
(* Preparing left panel *)
let left =
let left =
if leftbar then
let navig = transform items with <left>c -> [ c ] in
let left = match navig with [] -> [ [<boxes-toc>[]] ] | n -> n in
......
Supports Markdown
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