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

Original author: afrisch
Date: 2005-06-09 15:28:55+00:00

driver/cduce.ml

@@ -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 "@.";
 
 (*

types/patterns.ml

@@ -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 = Types.cap Types.Product.any disp.t in
+    let tests1,conts1 = collect prod_tests t disp in
+    let t = Types.Product.get t in
+    get_tests (Types.Product.pi1 t) tests1 
+      (fun t1 ar1 ->
+	 let tests2 = ref [] in
+	 let conts2 = Array.map (fun f -> f t1 ar1 tests2) conts1 in