[r2002-11-20 23:20:10 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-20 23:20:11+00:00

driver/cduce.ml

@@ -89,16 +89,14 @@ let debug ppf = function
       List.iter (fun (x,t) ->
 		   Format.fprintf ppf " %s:%a@\n" x
 		     print_norm (Types.descr t)) f
-  | `Restrict (p,t) -> 
-      Format.fprintf ppf "[DEBUG:restrict]@\n";
+  | `Compile2 (t,pl) -> 
+      Format.fprintf ppf "[DEBUG:compile2]@\n";
       let t = Typer.typ !glb_env t
-      and p = Typer.pat !glb_env p in
-(*      let f = Patterns.restrict (Patterns.descr p) (Types.descr t) in
-      (match f with 
-	| `Pat q -> Format.fprintf ppf "Pat: %a@\n" Patterns.print q
-	| `Accept -> Format.fprintf ppf "Accept@\n"
-	| `Reject -> Format.fprintf ppf "Reject@\n") *)
-      Patterns.demo ppf (Patterns.descr p) (Types.descr t)
+      and pl = List.map (fun p -> (`Pat (Typer.pat !glb_env p), Types.any)) pl in
+      let d = Patterns.Compiler.make_dispatcher
+		(Types.descr t) pl in
+      Patterns.Compiler.print_disp ppf d
+
   | `Accept p ->
       Format.fprintf ppf "[DEBUG:accept]@\n";
       let p = Typer.pat !glb_env p in

parser/ast.ml

@@ -17,7 +17,7 @@ and debug_directive =
   | `Accept of ppat
   | `Compile of ppat * ppat list 
   | `Normal_record of ppat
-  | `Restrict of ppat * ppat
+  | `Compile2 of ppat * ppat list
   ]
 
 

parser/parser.ml

@@ -75,7 +75,7 @@ EXTEND
     | LIDENT "accept"; p = pat -> `Accept p
     | LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
     | LIDENT "normal_record"; t = pat -> `Normal_record t
-    | LIDENT "restrict"; p = pat; t = pat -> `Restrict (p,t)
+    | LIDENT "compile2"; t = pat; p = LIST1 pat -> `Compile2 (t,p)
     ]
   ];
 

types/patterns.ml

@@ -178,16 +178,32 @@ let filter t p =
 
 module Compiler = 
 struct
+  type p = [ `Pat of node | `Typ of Types.descr ]
 
-  type disp = {
-    did   : int;
+  type dispatcher = {
+    did      : int;
     nb_codes : int;
-    results : res;
+    results  : res;
+    t        : Types.descr;
+    pats     : (p,Types.descr) SortedMap.t;
+    mutable actions  : actions option;
   }
   and bind = (capture, int) SortedMap.t
-  and res = [ `Return of int | `Fail | `Branch of (bind * res * res) ]
+  and res = [ `Return of Types.descr * int 
+	    | `Fail 
+	    | `Branch of (bind * res * res) ]
+  and 'a dispatch = dispatcher * 'a array
+  and actions = { 
+    act_basic: basic_actions;
+    act_prod : prod_actions 
+  }
+  and prod_actions = (int * prod_src list) dispatch dispatch
+  and basic_actions = (Types.descr * (int * basic_src list)) SortedList.t
+  and prod_src = [ `Capture |  `Const of Types.const 
+		 | `Combine of int * int | `Left of int | `Right of int ]
+  and basic_src = [ `Capture |  `Const of Types.const ]
+
 
-  type p = [ `Pat of node | `Typ of Types.descr ]
 
   module DispMap = Map.Make(
     struct
@@ -202,7 +218,8 @@ struct
   let rec make_res codes pos t l =
     if Types.is_empty t then `Fail
     else match l with
-      | [] -> incr codes; `Return (!codes - 1)
+      | [] -> 
+	  incr codes; `Return (t, !codes - 1)
       | (p,restr)::rem ->
 	  let (pos,bind,a) = match p with
 	    | `Pat p -> 
@@ -212,23 +229,40 @@ struct
 	    | `Typ a -> (pos,[],a)
 	  in
 	  let oth = Types.diff t restr in
-	  
+(*	  Format.fprintf Format.std_formatter
+	    "<<<%a>>>@\n" Types.Print.print_descr (Types.cap t a);
+*)
 (*	  assert (Types.subtype restr t);*)
 	  let yes = make_res codes pos (Types.cup (Types.cap t a) oth) rem
 	  and no = make_res codes pos (Types.cup (Types.diff t a) oth) rem in
 	  `Branch (bind,yes,no)
 	    
     
-  let make_dispatcher t pats : disp =
+  let make_dispatcher t pats =
     try DispMap.find (t,pats) !dispatchers
     with Not_found ->
       incr nb_disp;
       let nbc = ref 0 in
       let res = make_res nbc 0 t pats in
-      let d = { did = !nb_disp; results = res; nb_codes = !nbc } in
+      let d = { did = !nb_disp; 
+		pats = pats;
+		t = t;
+		results = res; 
+		nb_codes = !nbc; 
+		actions = None } in
       dispatchers := DispMap.add (t,pats) d !dispatchers;
       d
 
+  let rec find_code accu = function
+    | (`Return (_,c),[]) -> 
+	(c,List.rev accu)
+    | (`Branch (_,_,no),None::rem) -> 
+	find_code accu (no,rem)
+    | (`Branch (_,yes,_),Some x::rem) -> 
+	find_code (List.rev_append x accu) (yes,rem)
+    | _ -> assert false 
+
+
   let dispatcher t (args : (p * Types.descr * bind option ref) list) f =
     let args = 
       List.map 
@@ -242,7 +276,7 @@ struct
     let res = Array.create d.nb_codes (Obj.magic 0) in
     let rec aux = function
       | (`Fail,_) -> ()
-      | (`Return c, []) -> res.(c) <- f ()
+      | (`Return (t,c), []) -> res.(c) <- f t
       | (`Branch (bind,yes,no), (_,(_,fl))::rem) ->
 	  List.iter (fun r -> r := Some bind) fl; aux (yes,rem);
 	  List.iter (fun r -> r := None) fl; aux (no,rem)
@@ -283,18 +317,20 @@ struct
     | (One,p) | (p,One) -> p
     | (p1,p2) -> And (p1,p2)
 
+(*
   let atom s a p =
     if Types.is_empty (Types.cap s a) then Zero else
       Atom (s, p)
+*)
 
   let rec map f = function
     | One -> One
     | Zero -> Zero
     | Capt x -> Capt x
     | Const (x,c) -> Const (x,c)
-    | Alt (p1,p2) -> Alt (map f p1, map f p2)
-    | And (p1,p2) -> And (map f p1, map f p2)
-    | Atom a -> Atom (f a)
+    | Alt (p1,p2) -> alt (map f p1, map f p2)
+    | And (p1,p2) -> and_ (map f p1, map f p2)
+    | Atom a -> f a
 
   let rec get f (a,_,d) s =
     if Types.is_empty (Types.cap s a) then Zero 
@@ -315,49 +351,239 @@ struct
 	  Const (x,c)
       | d -> f d s
 
-
-  let prepare_prod =
+  let rec get_final f = function
+    | Atom x -> f x
+    | One -> Some []
+    | Zero -> None
+    | Capt x -> Some [x, `Capture]
+    | Const (x,c) -> Some [x, `Const c]
+    | Alt (p1,p2) ->
+	(match get_final f p1 with
+	  | Some _ as x -> x
+	  | None -> get_final f p2)
+    | And (p1,p2) ->
+	(match get_final f p1 with
+	  | Some x -> 
+	      (match get_final f p2 with
+		 | Some y -> Some (SortedMap.union_disj x y)
+		 | None -> None)
+	  | None -> None)
+
+  let get_final f p =
+    match get_final f p with
+      | None -> None
+      | Some l -> Some (List.map snd l)
+
+
+  let map_list f =
+    List.map (map f)
+
+  let pi1 d = Types.Product.pi1 (Types.Product.get d)
+  let pi2 d d1 = Types.Product.pi2 (Types.Product.restrict_1
+				      (Types.Product.get d) d1)
+
+  let prepare_prod' =
     get (fun d r ->
 	   match d with
 	     | Times (n1,n2) ->
-		 let r = Types.Product.normal r in
 		 Atom (`Pat (n1,n2,r))
 	     | Constr t ->
-		 Atom (`Typ (t,r))
+		 Atom (`Typ (Types.cap t r,r))
 	     | _ -> Zero
 	)
 
-  let dispatch_record t pats =
-    let pats = List.map (fun (p,restr) ->
-			   match p with
-			     | `Pat p -> prepare_prod (descr p) restr
-			     | `Typ s -> Atom (`Typ (s,restr))
-				   (* TODO: special case here ... restr<=t...*)
-			) pats in
-    (* Make dispatcher on first component *)
+  let prepare_prod (p,restr) =
+    match p with
+      | `Pat p -> prepare_prod' (descr p) restr
+      | `Typ s -> Atom (`Typ (s,restr))
+	  (* TODO: special case here ... restr<=t...*)
+
+  let map_prod1 collect = function
+    | `Pat (n1,n2,r) ->
+	let fl = ref None in
+	collect := (`Pat n1,pi1 r,fl) :: !collect;
+	Atom (`Pat (fl, n2, r))
+    | `Typ (s,r) ->
+	let r1 = pi1 r in
+	let l =
+	  List.map 
+	    (fun (s1,s2) ->
+	       let fl = ref None in
+	       collect := (`Typ s1,r1,fl) :: !collect;
+	       (fl, s2)
+	    ) (Types.Product.normal s) in
+	(* would be ok with Types.Product.get ... *)
+	Atom (`Typ (l,r))
+
+  let map_prod2 t1 collect = function
+    | `Pat (fl1,n2,r) ->
+	(match !fl1 with
+	   | None -> Zero
+	   | Some bind -> 
+	       let fl2 = ref None in
+	       collect := (`Pat n2, pi2 r t1,fl2) :: !collect;
+	       Atom (`Pat (bind,fl2))
+	)
+    | `Typ (l,r) ->
+	let r2 = pi2 r t1 in
+	let l = 
+	  List.fold_left
+	    (fun accu (fl1,s2) ->
+	       match !fl1 with
+		 | None -> accu
+		 | Some bind ->
+		     assert(bind = []);
+		     let fl2 = ref None in
+		     collect := (`Typ s2, r2, fl2) :: !collect;
+		     fl2::accu
+	    ) [] l in
+	Atom (`Typ l)
+
+  let prod_final = 
+    get_final (
+      function
+	| `Pat (bind1,{ contents = Some bind2 }) -> 
+	    let x = 
+	      SortedMap.combine	
+		(fun x -> `Left x) (fun x -> `Right x)
+		(fun x y -> `Combine (x,y))
+		bind1 bind2
+	    in
+	    Some x
+	| `Typ l when List.exists (fun fl -> !fl <> None) l -> Some [] 
+	| _ -> None
+    )
+	     
+  let dispatch_prod (res:res) t (pats:(p*Types.descr) list) : prod_actions =
+    let pats = List.map prepare_prod pats in
     let lefts = ref [] in
-    let pats =
-      List.map (map (
-		  function
-		    | `Pat (n1,n2,r) ->
-			let pat =
-			  List.map (fun (r1,r2) ->
-				      let fl = ref None in
-				      lefts := (`Pat n1,r1,fl) :: !lefts;
-				      (fl, n2, r2)
-				   ) r in
-			`Pat pat
-		    | `Typ (s,r) ->
-			(*...*)
-			assert false
-		)) pats in
-    let (disp1,f1) = dispatcher 
-		       (Types.Product.pi1 (Types.Product.get t)) 
-		       !lefts
-		       (fun () -> 0)
+    let pats =  map_list (map_prod1 lefts) pats in
+    dispatcher (pi1 t) !lefts
+      (fun t1 ->
+	 let rights = ref [] in
+	 let pats = map_list (map_prod2 t1 rights) pats in
+	 dispatcher (pi2 t t1) !rights
+	   (fun t2 ->
+	    let pats = List.map prod_final pats in
+	    find_code [] (res,pats)
+	   )
+      )
+
+  let any_basic = Types.neg (List.fold_left Types.cup Types.empty
+			       [Types.Product.any_xml;
+				Types.Product.any;
+				Types.Record.any])
+
+  let prepare_basic' =
+    get (fun d r ->
+	   match d with
+	     | Constr t -> Atom t
+	     | _ -> Zero)
+
+  let prepare_basic (p,restr) =
+    match p with
+      | `Pat p -> prepare_basic' (descr p) restr
+      | `Typ s -> Atom s
+      
+  let basic_final t =
+    get_final (
+      fun s ->
+	if Types.subtype t s then Some []
+	else (assert (Types.is_empty (Types.cap t s)); None)
+    )
+
+  let dispatch_basic res t pats : basic_actions =
+    let types = ref [] in
+    let rec aux = function
+      | `Fail -> ()
+      | `Branch (bind,yes,no) -> aux yes; aux no
+      | `Return (t,_) -> 
+	  let t = Types.cap t any_basic in
+	  if not (Types.is_empty t) then types := t :: !types in
+    aux res;
+    let pats = List.map prepare_basic pats in
+    List.map
+      (fun t ->
+	 let pats = List.map (basic_final t) pats in
+	 (t, find_code [] (res,pats))
+      ) !types
+
+
+  let get_actions disp =
+    match disp.actions with
+      | Some a -> a
+      | None ->
+	  let a = {
+	    act_basic = dispatch_basic disp.results disp.t disp.pats;
+	    act_prod = dispatch_prod disp.results disp.t disp.pats
+	  } in
+	  disp.actions <- Some a;
+	  a
+
+  let to_print = ref ([] : dispatcher list)
+  let printed = ref ([] : dispatcher list)
+
+
+  let print_act_basic ppf b =
+    List.iter 
+      (fun (d,(code,bind)) ->
+	 Format.fprintf ppf "| %a -> %i( " 
+	 Types.Print.print_descr d
+	 code;
+	 List.iter 
+	   (function
+	      | `Capture -> 
+		  Format.fprintf ppf "v "
+	      | `Const c -> 
+		  Format.fprintf ppf "%a " Types.Print.print_const c)
+	   bind;
+	 Format.fprintf ppf ")@\n" 
+      ) b
+
+  let print_act_prod ppf (disp1,b1) =
+    Format.fprintf ppf "| (v1,v2) -> match v1 with disp%i@\n" disp1.did;
+    to_print := disp1 :: !to_print;
+    for i = 0 to Array.length b1 - 1 do
+     let (disp2,b2) = b1.(i) in
+     to_print := disp2 :: !to_print;
+      Format.fprintf ppf " | %i(l) -> match v2 with disp%i@\n" i disp2.did;
+      for j = 0 to Array.length b2 - 1 do
+	let (code,bind) = b2.(j) in
+	Format.fprintf ppf "  | %i(r) -> %i(" j code;
+	List.iter 
+	  (function
+	     | `Capture -> 
+		 Format.fprintf ppf "v "
+	     | `Const c -> 
+		 Format.fprintf ppf "%a " Types.Print.print_const c
+	     | `Left x ->
+		 Format.fprintf ppf "l%i " x
+	     | `Right x ->
+		 Format.fprintf ppf "r%i " x
+	     | `Combine (x,y) ->
+		 Format.fprintf ppf "(l%i,r%i) " x y
+	  )
+	  bind;
+	Format.fprintf ppf ")@\n" 
+      done;
+    done
+		 
+  let rec print_disp ppf disp =
+    Format.fprintf ppf "Dispatcher [%i]: 0..%i@\n" disp.did (disp.nb_codes - 1);
+    let a = get_actions disp in
+    print_act_basic ppf a.act_basic;
+    print_act_prod ppf a.act_prod;
+
+    let rec loop () = 
+      match !to_print with
+	| [] -> ()
+	| d::q -> 
+	    to_print := q;
+	    if List.memq d !printed then loop ()
+	    else (printed := d :: !printed; print_disp ppf d)
     in
-    ()
-    
+    loop ()
+
 
 (*
 let rec collect typ f (a,_,d) s =

types/patterns.mli

@@ -37,6 +37,14 @@ val demo: Format.formatter -> descr -> Types.descr -> unit
 val accept : node -> Types.node
 val filter : Types.descr -> node -> (capture,Types.node) SortedMap.t
 
+
+module Compiler: sig
+  type p = [ `Pat of node | `Typ of Types.descr ]
+  type dispatcher
+  val make_dispatcher : Types.descr -> (p,Types.descr) SortedMap.t -> dispatcher
+  val print_disp: Format.formatter -> dispatcher -> unit
+end
+
 (* Pattern matching: compilation *)
 
 module Compile: sig

types/sortedMap.ml

@@ -30,6 +30,15 @@ let rec union_disj l1 l2 =
     | ([],l2) -> l2
     | (l1,[]) -> l1
   
+let rec combine f1 f2 f12 l1 l2 =
+  match (l1,l2) with
+    | (x1,y1)::q1, (x2,y2)::q2 ->
+        let c = compare x1 x2 in
+        if c = 0 then (x1,(f12 y1 y2))::(combine f1 f2 f12 q1 q2)
+        else if c < 0 then (x1, f1 y1)::(combine f1 f2 f12 q1 l2)
+        else (x2, f2 y2)::(combine f1 f2 f12 l1 q2)
+    | ([],q2) -> List.map (fun (x2,y2) -> (x2,f2 y2)) l2
+    | (l1,[]) -> List.map (fun (x1,y1) -> (x1,f1 y1)) l1
 
 let rec map f = function
   | [] -> []

types/sortedMap.mli

@@ -3,6 +3,9 @@ val union: ('b -> 'b -> 'b) -> ('a,'b) t -> ('a,'b) t -> ('a,'b) t
 val unioni: ('a -> 'b -> 'b -> 'b) -> ('a,'b) t -> ('a,'b) t -> ('a,'b) t
 val union_disj: ('a,'b) t -> ('a,'b) t -> ('a,'b) t
 
+val combine: ('b -> 'd) -> ('c -> 'd) -> ('b -> 'c -> 'd) -> 
+  ('a,'b) t -> ('a,'c) t -> ('a,'d) t
+
 val map: ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
 
 val add: ('b -> 'b -> 'b) -> 'a -> 'b -> ('a,'b) t -> ('a,'b) t