Commit f3cbd9e0 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-06-09 15:28:55 by afrisch] Begin simplified compilation

Original author: afrisch
Date: 2005-06-09 15:28:55+00:00
parent 56b96519
......@@ -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.Compile.debug_compile ppf t pl;
Patterns.Compile2.debug_compile ppf t pl;
Format.fprintf ppf "@.";
(*
......
......@@ -291,6 +291,11 @@ module Pat = struct
| Capture x -> 7 + (Id.hash x)
| Constant (x,c) -> 8 + 17 * (Id.hash x) + 257 * (Types.Const.hash c)
| Dummy -> assert false
let serialize _ _ = assert false
let deserialize _ = assert false
let check _ = assert false
let dump _ = assert false
end
module Print = struct
......@@ -1443,7 +1448,7 @@ struct
)
let print_ret lhs ppf (code,ret,ar) =
Format.fprintf ppf "$%i{%i}" code ar;
Format.fprintf ppf "$%i" code;
if Array.length ret <> 0 then
Format.fprintf ppf "(%a)" (print_result lhs) ret
......@@ -1603,3 +1608,789 @@ struct
let j = !generated in
Format.fprintf ppf "Total number of states: %i@." j)
end
(****** More efficient compilation (less optimized) ******)
module Compile2 =
struct
type source =
| Catch | Const of Types.const
| Stack of int | Left | Right | Nil | Recompose of int * int
let compare_source s1 s2 = match (s1,s2) with
| Catch, Catch | Left,Left | Right,Right | Nil,Nil -> 0
| Catch, _ -> -1 | _,Catch -> 1
| Left,_ -> -1 | _, Left -> 1
| Right,_ -> -1 | _, Right -> 1
| Nil,_ -> -1 | _, Nil -> 1
| Const c1, Const c2 -> Types.Const.compare c1 c2
| Const _, _ -> -1 | _, Const _ -> 1
| Stack i, Stack j -> i - j
| Stack _, _ -> -1
| _, Stack _ -> 1
| Recompose (i,j), Recompose (i',j') -> if i == j then i' - j' else i - j
module Req = struct
include Custom.Dummy
type t =
| RFail
| RBinds of source id_map
| RCap of t * t
| RCup of t * t
| RConstr of Types.t
| RTimes of node * node * IdSet.t * Types.t
| RXml of node * node * IdSet.t * Types.t
| RRecord of label * node * IdSet.t * Types.t
let rec compare r1 r2 = match r1,r2 with
| RFail, RFail -> 0
| RFail, _ -> -1
| _, RFail -> 1
| RBinds b1, RBinds b2 -> IdMap.compare compare_source b1 b2
| RBinds _, _ -> -1
| _, RBinds _ -> 1
| RCap (r1,r2), RCap (r1',r2')
| RCup (r1,r2), RCup (r1',r2') ->
let c = compare r1 r1' in if c !=0 then c else compare r2 r2'
| RCap _, _ -> -1
| _, RCap _ -> 1
| RCup _, _ -> -1
| _, RCup _ -> 1
| RConstr t1, RConstr t2 -> Types.compare t1 t2
| RConstr _, _ -> -1
| _, RConstr _ -> 1
| RTimes (q1,q2,xs,_), RTimes (q1',q2',xs',_)
| RXml (q1,q2,xs,_), RXml (q1', q2',xs',_) ->
let c = Node.compare q1 q1' in if c != 0 then c
else let c = Node.compare q2 q2' in if c !=0 then c
else IdSet.compare xs xs'
| RTimes _, _ -> -1
| _, RTimes _ -> 1
| RXml _, _ -> -1
| _, RXml _ -> 1
| RRecord (l,q,xs,_), RRecord (l',q',xs',_) ->
let c = LabelPool.compare l l' in if c != 0 then c
else let c = Node.compare q q' in if c != 0 then c
else IdSet.compare xs xs'
let rec acc = function
| RFail -> Types.empty
| RBinds _ -> Types.any
| RCap (r1,r2) -> Types.cap (acc r1) (acc r2)
| RCup (r1,r2) -> Types.cup (acc r1) (acc r2)
| RConstr t | RTimes (_,_,_,t) | RXml (_,_,_,t) | RRecord (_,_,_,t) -> t
let rec vars = function
| RFail | RConstr _ -> IdSet.empty
| RBinds b -> IdMap.domain b
| RCap (r1,r2) -> IdSet.cup (vars r1) (vars r2)
| RCup (r1,r2) -> vars r1
| RTimes (_,_,xs,_) | RXml (_,_,xs,_) | RRecord (_,_,xs,_) -> xs
let rec first_label = function
| RConstr t -> Types.Record.first_label t
| RCap (r1,r2) | RCup (r1,r2) -> min (first_label r1) (first_label r2)
| RRecord (l,_,_,_) -> l
| _ -> LabelPool.dummy_max
let accpat (t,_,_) = t
let rec make t (tp,vp,d) xs =
if Types.disjoint t tp then RFail
else if IdSet.disjoint xs vp
then if Types.subtype t tp then RBinds IdMap.empty
else RConstr tp
else match d with
| Constr t -> assert false
| Cup (p1,p2) ->
(match make t p1 xs with
| RFail -> make t p2 xs
| RBinds _ as r1 -> r1
| r1 -> match make t p2 xs with
| RFail -> r1
| r2 -> RCup (r1,r2))
| Cap (p1,p2) ->
(match make t p1 xs, make t p2 xs with
| RBinds b1, RBinds b2 -> RBinds (IdMap.union_disj b1 b2)
| r1,r2 -> RCap (r1,r2))
| Times (q1,q2) ->
RTimes (q1,q2, IdSet.cap xs vp, tp)
| Xml (q1,q2) ->
RXml (q1,q2, IdSet.cap xs vp, tp)
| Record (l,q) ->
RRecord (l,q, IdSet.cap xs vp, tp)
| Capture x ->
RBinds (IdMap.singleton x Catch)
| Constant (x,c) ->
RBinds (IdMap.singleton x (Const c))
| Dummy -> assert false
let rec simplify t = function
| (RFail | RBinds _) as r -> r
| RConstr s as r ->
if Types.subtype t s then RBinds IdMap.empty
else if Types.disjoint t s then RFail
else r
| RCup (r1,r2) ->
(match simplify t r1 with
| RBinds _ as r -> r
| RFail -> simplify t r2
| r1 -> match simplify t r2 with
| RFail -> r1
| r2 -> RCup (r1,r2))
| RCap (r1,r2) ->
(match simplify t r1 with
| RFail -> RFail
| r1 ->
match simplify t r2 with
| RFail -> RFail
| RBinds b2 ->
(match r1 with
| RBinds b1 -> RBinds (IdMap.union_disj b1 b2)
| _ -> RCap (r1,r2))
| r2 -> RCap (r1,r2))
| (RTimes (_,_,_,s) | RXml (_,_,_,s) | RRecord (_,_,_,s)) as r ->
if Types.disjoint t s then RFail
else r
end
type actions =
| AIgnore of result
| AKind of actions_kind
and actions_kind = {
basic: (Types.t * result) list;
atoms: result Atoms.map;
chars: result Chars.map;
prod: result dispatch dispatch;
xml: result dispatch dispatch;
record: record option;
}
and record =
| RecLabel of label * result dispatch dispatch
| RecNolabel of result option * result option
and 'a dispatch =
| Dispatch of dispatcher * 'a array
| TailCall of dispatcher
| Ignore of 'a
| Impossible
and result = int * source array * int
and return_code =
Types.t * int * (* accepted type, arity *)
int id_map option array
and interface =
[ `Result of int
| `Switch of interface * interface
| `None ]
and dispatcher = {
id : int;
t : Types.t;
pl : Req.t array;
label : label option;
interface : interface;
codes : return_code array;
mutable actions : actions option;
mutable printed : bool
}
let types_of_codes d = Array.map (fun (t,ar,_) -> t) d.codes
let equal_array f a1 a2 =
let rec aux i = (i < 0) || ((f a1.(i) a2.(i)) && (aux (i - 1))) in
let l1 = Array.length a1 and l2 = Array.length a2 in
(l1 == l2) && (aux (l1 - 1))
let array_for_all f a =
let rec aux f a i = (i < 0) || (f a.(i) && (aux f a (pred i))) in
aux f a (Array.length a - 1)
let array_for_all_i f a =
let rec aux f a i = (i < 0) || (f i a.(i) && (aux f a (pred i))) in
aux f a (Array.length a - 1)
let equal_source s1 s2 =
(s1 == s2) || match (s1,s2) with
| Const x, Const y -> Types.Const.equal x y
| Stack x, Stack y -> x == y
| Recompose (x1,x2), Recompose (y1,y2) -> (x1 == y1) && (x2 == y2)
| _ -> false
let equal_result (r1,s1,l1) (r2,s2,l2) =
(r1 == r2) && (equal_array equal_source s1 s2) && (l1 == l2)
let equal_result_dispatch d1 d2 = (d1 == d2) || match (d1,d2) with
| Dispatch (d1,a1), Dispatch (d2,a2) ->
(d1 == d2) && (equal_array equal_result a1 a2)
| TailCall d1, TailCall d2 -> d1 == d2
| Ignore a1, Ignore a2 -> equal_result a1 a2
| _ -> false
let immediate_res basic prod xml record =
let res : result option ref = ref None in
let chk = function Catch | Const _ -> true | _ -> false in
let f ((_,ret,_) as r) =
match !res with
| Some r0 when equal_result r r0 -> ()
| None when array_for_all chk ret -> res := Some r
| _ -> raise Exit in
(match basic with [_,r] -> f r | [] -> () | _ -> raise Exit);
(match prod with Ignore (Ignore r) -> f r |Impossible ->()| _->raise Exit);
(match xml with Ignore (Ignore r) -> f r |Impossible ->()| _->raise Exit);
(match record with
| None -> ()
| Some (RecLabel (_,Ignore (Ignore r))) -> f r
| Some (RecNolabel (Some r1, Some r2)) -> f r1; f r2
| _ -> raise Exit);
match !res with Some r -> r | None -> raise Exit
let split_kind basic prod xml record = {
basic = basic;
atoms = Atoms.mk_map (List.map (fun (t,r) -> Types.Atom.get t, r) basic);
chars = Chars.mk_map (List.map (fun (t,r) -> Types.Char.get t, r) basic);
prod = prod;
xml = xml;
record = record
}
let combine_kind basic prod xml record =
try AIgnore (immediate_res basic prod xml record)
with Exit -> AKind (split_kind basic prod xml record)
let combine f (disp,act) =
if Array.length act == 0 then Impossible
else
if (array_for_all (fun (_,ar,_) -> ar == 0) disp.codes)
&& (array_for_all ( f act.(0) ) act) then
Ignore act.(0)
else
Dispatch (disp, act)
let detect_tail_call f = function
| Dispatch (disp,branches) when array_for_all_i f branches -> TailCall disp
| x -> x
let detect_right_tail_call =
detect_tail_call
(fun i (code,ret,_) ->
(i == code) &&
let ar = Array.length ret in
(array_for_all_i
(fun pos ->
function Stack j when pos + j == ar -> true | _ -> false)
ret
)
)
let detect_left_tail_call =
detect_tail_call
(fun i ->
function
| Ignore (code,ret,_) when (i == code) ->
let ar = Array.length ret in
array_for_all_i
(fun pos ->
function Stack j when pos + j == ar -> true | _ -> false)
ret
| _ -> false
)
let cur_id = State.ref "Patterns.cur_id" 0
(* TODO: save dispatchers ? *)
module NfMap = Map.Make(Normal)
module NfSet = Set.Make(Normal)
module DispMap = Map.Make(Custom.Pair(Types)(Custom.Array(Req)))
(* Try with a hash-table ! *)
let dispatchers = ref DispMap.empty
let generated = ref 0
let to_generate = ref []
let timer_disp = Stats.Timer.create "Patterns.dispatcher loop"
let rec print_iface ppf = function
| `Result i -> Format.fprintf ppf "Result(%i)" i
| `Switch (yes,no) -> Format.fprintf ppf "Switch(%a,%a)"
print_iface yes print_iface no
| `None -> Format.fprintf ppf "None"
let first_lab t pl =
let aux l r = min l (Req.first_label r) in
let lab = Array.fold_left aux (Types.Record.first_label t) pl in
if lab == LabelPool.dummy_max then None else Some lab
let dispatcher t pl : dispatcher =
try DispMap.find (t,pl) !dispatchers
with Not_found ->
let lab = first_lab t pl in
let nb = ref 0 in
let codes = ref [] in
let rec aux t arity i accu =
if i == Array.length pl
then (incr nb; let r = Array.of_list (List.rev accu) in
codes := (t,arity,r)::!codes; `Result (!nb - 1))
else
let r = pl.(i) in
let tp = Req.acc r in
let v = Req.vars r 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 a2 = Types.diff t tp in
let accu' = Some (IdMap.num arity v) :: accu in
if Types.is_empty a2 then
`Switch (aux t (arity + (IdSet.length v)) (i+1) accu',`None)
else
`Switch (aux a1 (arity + (IdSet.length v)) (i+1) accu',
aux a2 arity (i+1) (None::accu))
(* Unopt version:
`Switch
(
aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
aux (Types.diff t tp) arity (i+1) accu
)
*)
in
Stats.Timer.start timer_disp;
let iface = if Types.is_empty t then `None else aux t 0 0 [] in
Stats.Timer.stop timer_disp ();
let res = {
id = !cur_id;
t = t;
label = lab;
pl = pl;
interface = iface;
codes = Array.of_list (List.rev !codes);
actions = None; printed = false
} in
incr cur_id;
dispatchers := DispMap.add (t,pl) res !dispatchers;
res
let find_code d a =
let rec aux i = function
| `Result code -> code
| `Switch (yes,no) -> aux (i + 1) (if a.(i) == None then no else yes)
| `None -> assert false in
aux 0 d.interface
let create_result pl =
let aux x accu = match x with
| Some b -> (List.map snd (IdMap.get b)) @ accu
| None -> accu in
Array.of_list (Array.fold_right aux pl [])
let rec basic_tests t0 d tests = match d with
| Req.RBinds b -> (fun () -> Some b)
| Req.RCup (p1,p2) ->
let f1 = basic_tests t0 p1 tests and f2 = basic_tests t0 p2 tests in
(fun () -> match f1 () with
| None -> f2 ()
| Some _ as r -> r)
| Req.RCap (p1,p2) ->
let f1 = basic_tests t0 p1 tests and f2 = basic_tests t0 p2 tests in
(fun () -> match f1 () with
| None -> None
| Some b1 -> match f2 () with
| None -> None
| Some b2 -> Some (IdMap.union_disj b1 b2))
| Req.RConstr s ->
let test = ref false in
tests := (test,Types.cap any_basic s) :: !tests;
(fun () -> if !test then Some IdMap.empty else None)
| _ -> (fun () -> None)
let reg_test tests t0 q xs : int Ident.id_map option ref =
let test = ref None in
tests := (test, Req.make t0 q.descr xs) :: !tests;
test
let reg_test_type tests t : int Ident.id_map option ref =
let test = ref None in
tests := (test, Req.RConstr t) :: !tests;
test
let rec map_filter f = function
| [] -> []
| hd::tl ->
match f hd with
| None -> map_filter f tl
| Some x -> x :: (map_filter f tl)
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,_) ->
let t0 = Types.Product.get ~kind:`Normal t0 in
let test1 = reg_test tests1 (Types.Product.pi1 t0) q1 xs in
(fun t1 ar1 tests2 -> match !test1 with
| None -> (fun ar2 -> None)
| Some b1 -> let test2 =
reg_test tests2 (Types.Product.pi2_restricted t1 t0) q2 xs in
fun ar2 -> match !test2 with
| None -> None
| Some b2 ->
let b1 = IdMap.map (fun i -> Stack (ar1 + ar2 - i)) b1
and b2 = IdMap.map (fun i -> Stack (ar2 - i)) b2 in
Some
(IdMap.merge
(fun l r -> match l,r with
| Stack i, Stack j -> Recompose (i,j)
| _ -> assert false) b1 b2))
| Req.RCup (p1,p2) ->
let f1 = prod_tests t0 p1 tests1
and f2 = prod_tests t0 p2 tests1 in
(fun t1 ar1 tests2 ->
let f1 = f1 t1 ar1 tests2 and f2 = f2 t1 ar1 tests2 in
fun ar2 -> match f1 ar2 with
| None -> f2 ar2
| Some _ as r -> r)
| Req.RCap (p2,p1) ->
let f1 = prod_tests t0 p1 tests1 and f2 = prod_tests t0 p2 tests1 in
(fun t1 ar1 tests2 ->
let f1 = f1 t1 ar1 tests2 in
let f2 = f2 t1 ar1 tests2 in
fun ar2 -> match f1 ar2 with
| None -> None
| Some b1 -> match f2 ar2 with
| None -> None
| Some b2 -> Some (IdMap.union_disj b1 b2))
| Req.RConstr s ->
(* TODO: don't compute intersection, only filter rectangles *)
let rects = Types.Product.get ~kind:`Normal (Types.cap s t0) in
let rects = List.map (fun (s1,s2) -> reg_test_type tests1 s1, s2) rects in
(fun t1 ar1 tests2 ->
let rects = map_filter
(function
| ({ contents = Some _},s2) -> Some (reg_test_type tests2 s2)
| _ -> None)
rects in
fun ar2 ->
if List.exists (function { contents = Some _ } -> true | _ -> false)
rects then Some IdMap.empty else None)
| _ -> (fun t1 ar1 tests2 ar2 -> None)
let collect f t disp =
let pl = Array.map (Req.simplify t) disp.pl in
let tests = ref [] in
let conts = Array.map (fun r -> f t r tests) pl in
!tests,conts
let dispatch_basic disp : (Types.t * result) list =
let t = Types.cap any_basic disp.t in
let tests,conts = collect basic_tests t disp in
let rec aux t l accu =
if Types.is_empty t then accu
else match l with
| [] ->
let r = Array.map (fun f -> f ()) conts in
let code = find_code disp r in
(t, (code, create_result r, 0)) :: accu
| (tst,ty) :: rem ->
let accu = tst := true; aux (Types.cap t ty) rem accu in
let accu = tst := false; aux (Types.diff t ty) rem accu in
accu
in
aux t tests []
module ReqMap = Map.Make(Req)
let get_tests
(t0 : Types.t)
(tests : (int id_map option ref * Req.t) list)
(f : Types.t -> int -> 'a) : 'a dispatch =
if Types.is_empty t0 then Impossible
else
let tests =
List.filter (fun (slot,r) ->
if IdSet.is_empty (Req.vars r) &&
Types.subtype t0 (Req.acc r) then
(slot := Some IdMap.empty; false)
else true) tests in
if tests == [] then Ignore (f Types.any 0)
else
(* Build a map (req)->(result slots) *)
let slots_map =
List.fold_left
(fun accu (slot,r) ->
let slots = slot :: (try ReqMap.find r accu with Not_found -> []) in
ReqMap.add r slots accu)
ReqMap.empty tests in
(* Collect subrequests *)
let reqs =
Array.of_list (ReqMap.fold (fun r _ accu -> r :: accu) slots_map []) in
(* Build dispatcher *)
let disp = dispatcher t0 reqs in
(* Continuation *)
let result (t,ar,b) : 'a =
Array.iteri
(fun i r ->
let slots = ReqMap.find r slots_map in
List.iter (fun slot -> slot := b.(i)) slots)
reqs;
f t ar in
Dispatch (disp, Array.map result disp.codes)
let rec dispatch_prod disp =
let t = Type