[r2006-05-29 12:31:49 by afrisch] Empty log message

Original author: afrisch
Date: 2006-05-29 12:31:50+00:00

compile/auto_pat.ml

@@ -30,7 +30,7 @@ and 'a dispatch =
 
 and state = {
   uid : int;
-  arity : int array;
+  arity : int array; 
   mutable actions: actions;
   mutable fail_code: int;
   mutable expected_type: string;

types/atoms.ml

@@ -63,6 +63,10 @@ let print s = match get s with
 
 type 'a map = 'a Imap.t * 'a Imap.t * 'a option
 
+let map_map f (m1,m2,o) =
+  Imap.map f m1, Imap.map f m2, 
+  (match o with Some x -> Some (f x) | None -> None)
+
 (* TODO: optimize this get_map *)
 let get_map q (mtags,mns,def) =   
   try Imap.find mtags (Upool.int q)

types/atoms.mli

@@ -39,4 +39,4 @@ val contains_sample: sample -> t -> bool
 type 'a map
 val mk_map: (t * 'a) list -> 'a map
 val get_map: V.t -> 'a map -> 'a
-
+val map_map: ('a -> 'b) -> 'a map -> 'b map

types/chars.ml

@@ -131,6 +131,9 @@ let dump ppf t =
   
 
 type 'a map = (int * 'a) list
+
+let map_map f l = List.map (fun (i,x) -> (i, f x)) l
+
 (* Optimize lookup:
    - decision tree
    - merge adjacent segment with same result

types/chars.mli

@@ -34,3 +34,4 @@ val single : t -> V.t
 type 'a map
 val mk_map: (t * 'a) list -> 'a map
 val get_map: V.t-> 'a map -> 'a
+val map_map: ('a -> 'b) -> 'a map -> 'b map

types/patterns.ml

@@ -1112,7 +1112,9 @@ module Compile = struct
     (* Build continuation *)
     let result (t,ar,m) =
       let get (req,info) a =
-	let (var,nil,r') = NfMap.find req !factorized in
+	let (var,nil,r') = 
+	  try NfMap.find req !factorized 
+	  with Not_found -> assert false in
 	try
 	  let i = NfMap.find r' idx in
 	  match m.(i) with Some res -> ((var,nil,res),info)::a | _ -> a 
@@ -1125,6 +1127,61 @@ module Compile = struct
     let res = Array.map result disp.codes in
     post (disp,res)
 
+   let add_factorized disp rhs =
+     let result ((code,srcs,pop) as r) =
+       match rhs.(code) with
+	 | Fail -> r
+	 | Match (_,(var,nil,xs,_)) ->
+	     let pos = ref (-1) in
+	     let var x =
+	       if IdSet.mem var x then Catch
+	       else if IdSet.mem nil x then Nil
+	       else (incr pos; srcs.(!pos)) in
+	     let srcs' = Array.of_list (List.map var (IdSet.get xs)) in
+	     assert(succ !pos = Array.length srcs);
+	     (code,srcs',pop) in
+     let dispatch1 = function
+       | Dispatch (s,a) -> Dispatch (s, Array.map result a)
+       | TailCall s -> 
+	   let f code (_,ar,_) =
+	     let srcs = Array.init ar (fun i -> Stack (ar - i)) in
+	     result (code,srcs,ar) in
+	   Dispatch (s, Array.mapi f disp.codes)
+       | Ignore r -> Ignore (result r)
+       | Impossible -> Impossible in
+     let dispatch2 = function
+       | Dispatch (s,a) -> Dispatch (s, Array.map dispatch1 a)
+       | TailCall s -> 
+	   let f code (_,ar,_) =
+	     let srcs = Array.init ar (fun i -> Stack (ar - i)) in
+	     Ignore (result (code,srcs,ar)) in
+	   Dispatch (s, Array.mapi f disp.codes)
+       | Ignore r -> Ignore (dispatch1 r)
+       | Impossible -> Impossible in
+     let state = disp.state in
+     let actions = match state.actions with
+       | AIgnore r -> AIgnore (result r)
+       | AKind k -> 
+	   AKind  {
+	     basic = List.map (fun (t,r) -> (t,result r)) k.basic;
+	     atoms = Atoms.map_map result k.atoms;
+	     chars = Chars.map_map result k.chars;
+	     prod = dispatch2 k.prod;
+	     xml = dispatch2 k.xml;
+	     record = 
+	       (match k.record with
+		  | None -> None
+		  | Some (RecLabel (l,x)) -> Some (RecLabel (l,dispatch2 x))
+		  | Some (RecNolabel (x,y)) ->
+		      Some (RecNolabel (
+			      (match x with None -> None 
+				 | Some r -> Some (result r)),
+			      (match y with None -> None 
+				 | Some r -> Some (result r)))))
+	   }
+     in
+     { state with actions = actions }
+
   let make_branches t brs =
     let t0 = ref t in
     let aux (p,e) = 
@@ -1135,16 +1192,22 @@ module Compile = struct
       [(nnf, (xs, e))] in
     let res _ _ pl =
       let aux r = function 
-	| [(([],[],res), (xs,e))] -> assert (r == Fail); 
+	| [((var,nil,res), (xs,e))] -> assert (r == Fail); 
 	    let i = ref 0 in
-	    List.iter (fun x -> assert (IdMap.assoc x res = !i); incr i) xs;
-	    Match (List.length xs, e)
+	    List.iter (fun x -> 
+			 if IdSet.mem var x || IdSet.mem nil x then ()
+			 else (assert (IdMap.assoc x res = !i); incr i)) xs;
+	    Match (List.length xs, (var,nil,xs,e))
 	| [] -> r | _ -> assert false in
       Array.fold_left aux Fail pl in
 (*    Format.fprintf Format.std_formatter
       "make_branches t=%a   #branches=%i@." Types.Print.print t (List.length brs);  *)
     let pl = Array.map aux (Array.of_list brs) in
-    get_tests false pl (fun x -> x) t res (fun (disp,rhs) -> disp.state,rhs)
+    let disp,rhs = get_tests true pl (fun x -> x) t res (fun x -> x) in
+    let state = add_factorized disp rhs in
+    state, 
+    (Array.map 
+       (function Match (n,(_,_,_,e)) -> Match (n,e) | Fail -> Fail) rhs)
 
 
   let rec dispatch_prod0 disp t pl =
@@ -1299,7 +1362,7 @@ module Compile = struct
     let (d,rhs) = make_branches t0 [ (p,()) ] in
     let code = ref (-1) in
     Array.iteri 
-      (fun (i : int) (rhs : unit rhs) -> 
+      (fun (i : int) rhs -> 
 	 match rhs with
 	   | Fail -> assert (!code < 0); code := i | _ -> ()) rhs;
     if (!code >= 0) then prepare_checker !code d;