[r2003-06-26 09:10:05 by cvscast] Optim dispatch on atoms

Original author: cvscast
Date: 2003-06-26 09:10:05+00:00

benchmarks/bench.ml

@@ -47,13 +47,16 @@ let args =  List.map int_of_string (split ',' args)
 let sp = sprintf
 let langs = 
   [
-    "CDuce PXP", ".cd",
+(*    "CDuce PXP", ".cd",
     (fun script xml -> 
-       sp "%s --pxp --quiet %s --arg %s" cduce_cmd script xml); 
+       sp "%s --pxp --quiet %s --arg %s" cduce_cmd script xml);  *)
 
-    "CDuce expat", ".cd",
+    "CDuce", ".cd",
     (fun script xml -> 
-       sp "%s --expat --quiet %s --arg %s" cduce_cmd script xml);
+       sp "%s --quiet %s --arg %s" cduce_cmd script xml);
+    "CDuce.old", ".cd",
+    (fun script xml -> 
+       sp "%s --quiet %s --arg %s" (cduce_cmd^".old") script xml);
 
     "XDuce 0.4.0", ".q",
     (fun script xml -> 

types/atoms.ml

 open Encodings
 
-(* TODO:
-   - pretty-printing
-   - efficient dispatch
-*)
-
 module Ns = struct
   include Pool.Make(Utf8)
 
@@ -294,21 +289,42 @@ module IMap = struct
     | Leaf of int * 'a
     | Branch of int * int * 'a t * 'a t
 
+  type 'a s =
+    | DError
+    | DReturn of 'a
+    | DLeaf of int * 'a * 'a
+    | DBranch of int * int * 'a s * 'a s
+	
   let zero_bit k m = (k land m) == 0
   let lowest_bit x = x land (-x)
   let branching_bit p0 p1 = lowest_bit (p0 lxor p1)
   let mask p m = p land (m-1)
   let match_prefix k p m = (mask k m) == p
 
-  let rec find_def def k = function
-    | Empty -> def
-    | Leaf (j,x) -> if k == j then x else def
-    | Branch (_, m, l, r) -> find_def def k (if zero_bit k m then l else r)
+  let rec prepare_def y = function
+    | Empty -> DReturn y
+    | Leaf (k,x) -> DLeaf (k,x,y)
+    | Branch (p,m,t0,t1) -> 
+	DBranch (p,m,prepare_def y t0, prepare_def y t1)
+
+  let rec prepare_nodef = function
+    | Empty -> DError
+    | Leaf (k,x) -> DReturn x
+    | Branch (p,m,t0,t1) ->
+	match (prepare_nodef t0, prepare_nodef t1) with
+	  | (DReturn x0, DReturn x1) when x0 == x1 -> DReturn x0
+	  | (t0,t1) -> DBranch (p,m,t0,t1)
+
+  let prepare def y =
+    match def with 
+      | None -> prepare_nodef y
+      | Some def -> prepare_def def y
 
   let rec find k = function
-    | Empty -> assert false
-    | Leaf (j,x) -> x
-    | Branch (_, m, l, r) -> find k (if zero_bit k m then l else r)
+    | DError -> assert false
+    | DReturn y -> y
+    | DLeaf (j,x,y) -> if k == j then x else y
+    | DBranch (_, m, l, r) -> find k (if zero_bit k m then l else r)
 
   let join p0 t0 p1 t1 =
     let m = branching_bit p0 p1 in
@@ -328,59 +344,69 @@ module IMap = struct
 	  else Branch (p, m, t0, add k x t1)
 	else
 	  join k (Leaf (k,x)) p t
-end
 
-(* TODO: avoid option (using functional types instead ?) *)
+  let rec dump f ppf = function
+    | DError -> Format.fprintf ppf "Error" 
+    | DReturn x -> Format.fprintf ppf "Return %a" f x 
+    | DLeaf(j,x,y) -> Format.fprintf ppf "Leaf(%i,%a,%a)" j f x f y
+    | DBranch (p,m,t0,t1) -> 
+	Format.fprintf ppf "B(%i,%i,%a,%a)" p m (dump f) t0 (dump f) t1
 	
-type 'a map = 
-    { min_ns : int;
-      table  : 'a IMap.t array;
-      table_def : 'a option array;
-      def    : 'a option }
+end
 
-let get_map (ns,x) m =
-  let i = ns - m.min_ns in
-  if (i < 0) || (i >= Array.length m.table)
-  then (match m.def with Some y -> y | None -> assert false)
-  else 
-    match m.table_def.(i) with
-      | Some def -> IMap.find_def def x m.table.(i)
-      | None -> IMap.find x m.table.(i)
+type 'a map = 'a IMap.s IMap.s
 
-let rec get_max = function
-  | [ (ns,_) ] -> ns
-  | _ :: l -> get_max l
-  | [] -> assert false
+let get_map (ns,x) m = IMap.find x (IMap.find ns m)
+
+module IntSet = 
+  Set.Make(struct type t = int let compare (x:int) y = Pervasives.compare x y end)
 
 let mk_map l =
-  let min_ns = ref max_int and max_ns = ref min_int in
+  let all_ns = ref IntSet.empty in
   let def = ref None in
   List.iter 
     (function
        | (Finite s, _) -> 
-	   (match T.get s with
-	     | [] -> ()
-	     | (ns,_)::_ as l ->
-		 min_ns := min !min_ns ns;
-		 max_ns := max !max_ns (get_max l))
-       | (Cofinite _, y) -> def := Some y) l;
-
-  let n = !max_ns - !min_ns + 1 in
-  let table = Array.make n IMap.Empty in
-  let table_def = Array.make n None in
-
-  let ofs = !min_ns in
-  for ns = ofs to !max_ns do
-    table.(ns - ofs) <-
+	   List.iter (fun (ns,_) -> all_ns := IntSet.add ns !all_ns) (T.get s)
+       | (Cofinite _, y) -> def := Some (IMap.DReturn y)) l;
+
+  let one_ns ns =
+    let def = ref None in
+    let t = 
       List.fold_left
         (fun accu (s, y) -> 
 	   match (symbol_set ns s) with
 	     | SymbolSet.Finite syms ->
 		 List.fold_left (fun accu x -> IMap.add x y accu) accu syms
 	     | SymbolSet.Cofinite syms ->
-		 table_def.(ns - ofs) <- Some y; accu)
+		 def := Some y; accu)
+        IMap.Empty 
+        l in
+    IMap.prepare !def t
+  in
+
+  let t = 
+    List.fold_left (fun accu ns -> IMap.add ns (one_ns ns) accu)
       IMap.Empty 
-        l;
-  done;
-  { min_ns = ofs; table = table; table_def = table_def; def = !def }
+      (IntSet.elements !all_ns) in
+  let t = IMap.prepare !def t in
+
+(*
+  let rec rank y i = function
+    | (_,x)::_ when x == y -> i
+    | _::r -> rank y (succ i) r
+    | [] -> assert false in
+
+  let dump_ns =
+    IMap.dump (fun ppf y -> Format.fprintf ppf "[%i]" (rank y 0 l)) in
+
+  Format.fprintf Format.std_formatter "table: %a@." 
+    (IMap.dump (fun ppf y -> Format.fprintf ppf "[%a]" dump_ns y)) t;
+*)
+
+  t
+
+
+
+