[r2005-06-13 21:56:19 by afrisch] Simplifications

Original author: afrisch
Date: 2005-06-13 21:56:19+00:00

types/patterns.ml

@@ -563,25 +563,17 @@ let rec first_label (acc,fv,d) =
 
 module Normal = struct
 
-  type source = 
-    | SCatch | SConst of Types.const 
-    | SLeft | SRight | SRecompose 
+  type source = SCatch | SConst of Types.const 
   type result = source id_map
 
   let compare_source s1 s2 =
     if s1 == s2 then 0 
     else match (s1,s2) with
       | SCatch, _ -> -1 | _, SCatch -> 1
-      | SLeft, _ -> -1 | _, SLeft -> 1
-      | SRight, _ -> -1 | _, SRight -> 1
-      | SRecompose, _ -> -1 | _, SRecompose -> 1
       | SConst c1, SConst c2 -> Types.Const.compare c1 c2
 
   let hash_source = function
     | SCatch -> 1
-    | SLeft -> 2
-    | SRight -> 3
-    | SRecompose -> 4
     | SConst c -> Types.Const.hash c
     
   let compare_result r1 r2 =
@@ -730,20 +722,14 @@ module Normal = struct
 
   let ntimes lab acc p q xs = 
     let xsp = IdSet.cap xs p.fv and xsq = IdSet.cap xs q.fv in
-    let src_p = IdMap.constant SLeft xsp
-    and src_q = IdMap.constant SRight xsq in
-    let src = IdMap.merge_elem SRecompose src_p src_q in 
     { (nempty lab) with 
-	nprod = single_prod src (nnode p xsp) (nnode q xsq)
+	nprod = single_prod empty_res (nnode p xsp) (nnode q xsq)
     }
 
   let nxml lab acc p q xs = 
     let xsp = IdSet.cap xs p.fv and xsq = IdSet.cap xs q.fv in
-    let src_p = IdMap.constant SLeft xsp
-    and src_q = IdMap.constant SRight xsq in
-    let src = IdMap.merge_elem SRecompose src_p src_q in 
     { (nempty lab) with 
-	nxml =  single_prod src (nnode p xsp) (nnode q xsq)
+	nxml =  single_prod empty_res (nnode p xsp) (nnode q xsq)
     }
     
   let nrecord lab acc l p xs =
@@ -751,14 +737,13 @@ module Normal = struct
       | None -> assert false
       | Some label ->
 	  assert (label <= l);
-	  let src,lft,rgt =
+	  let lft,rgt =
 	    if l == label
-	    then SLeft, nnode p xs, ncany
-	    else SRight, ncany_abs, nnode (cons p.fv (record l p)) xs
+	    then nnode p xs, ncany
+	    else ncany_abs, nnode (cons p.fv (record l p)) xs
 	  in
-	  let src = IdMap.constant src xs in
 	  { (nempty lab) with
-	      nrecord = RecLabel(label, single_prod src lft rgt) }
+	      nrecord = RecLabel(label, single_prod empty_res lft rgt) }
 
   let nconstr lab t =
     let aux l =
@@ -772,11 +757,10 @@ module Normal = struct
 		      (if y then Some empty_res else None))
       | Some l ->
 	  RecLabel (l,aux (Types.Record.split_normal t l)) in
-    { (nempty lab) with
-	nbasic = single_basic empty_res (Types.cap t any_basic);
-	nprod = aux (Types.Product.normal t);
-	nxml  = aux (Types.Product.normal ~kind:`XML t);
-	nrecord = record
+    {  nbasic = single_basic empty_res (Types.cap t any_basic);
+       nprod = aux (Types.Product.normal t);
+       nxml  = aux (Types.Product.normal ~kind:`XML t);
+       nrecord = record
     }
 
   let nany lab res =
@@ -824,6 +808,7 @@ module Normal = struct
     let vs_var = facto Factorize.var t0 xs pl in
     let xs = IdSet.diff xs vs_var in
     let vs_nil = facto Factorize.nil t0 xs pl in
+    let xs = IdSet.diff xs vs_nil in
     (vs_var,vs_nil,(pl,t,xs))
 
   let normal l t pl xs =
@@ -1080,40 +1065,48 @@ struct
       | _ -> dump_disp disp; assert false in
     let final = Array.map aux pl in
     (find_code disp final, create_result final, ar)
-    
-  let conv_source_basic s = match s with
+
+  let conv_source = function
     | Normal.SCatch -> Catch
     | Normal.SConst c -> Const c
-    | _ -> assert false
-
+    
   let return_basic disp selected =
-    let aux_final res = IdMap.map_to_list conv_source_basic res in
+    let aux_final res = IdMap.map_to_list conv_source res in
     return disp selected aux_final 0
 
-  let assoc v (vars,nils,l) ofs =
-    try ofs - IdMap.assoc v l with Not_found ->
-      if IdSet.mem vars v then -1
-      else if IdSet.mem nils v then -2
-      else assert false
-
-  let conv_source_prod ofs1 ofs2 left right v s = 
-    match s with
-    | Normal.SCatch -> Catch
-    | Normal.SConst c -> Const c
-    | Normal.SLeft -> 
-	(match assoc v left (ofs1 + ofs2) with
-	   | -1 -> Left
-	   | -2 -> Nil
-	   | i -> Stack i)
-    | Normal.SRight -> 
-	(match assoc v right ofs2 with
-	   | -1 -> Right
-	   | -2 -> Nil
-	   | i -> Stack i)
-    | Normal.SRecompose -> 
-	(match (assoc v left (ofs1 + ofs2), assoc v right ofs2) with
-	   | (-1,-1) -> Catch
-	   | (l,r) -> Recompose (l,r))
+(*  let print_idset ppf s =
+    let s = String.concat "," (List.map (fun x -> Ident.to_string x) s) in
+    Format.fprintf ppf "{%s}" s
+  let print_idmap ppf s =
+    print_idset ppf (IdMap.domain s) *)
+
+  let merge_res_prod ofs1 ofs2 (lvars,lnils,lres) (rvars,rnils,rres) extra =
+    let lres =
+      IdMap.union_disj
+	(IdMap.map (fun i -> Stack (ofs1 + ofs2 - i)) lres)
+	(IdMap.union_disj 
+	   (IdMap.constant Left lvars) (IdMap.constant Nil lnils)) in
+    let rres =
+      IdMap.union_disj
+	(IdMap.map (fun i -> Stack (ofs2 - i)) rres)
+	(IdMap.union_disj 
+	   (IdMap.constant Right rvars) (IdMap.constant Nil rnils)) in
+    let sub = 
+      IdMap.merge
+	(fun l r ->
+	   match l,r with
+	     | Left,Right -> Catch
+	     | _ -> 
+		 let l = 
+		   match l with Left -> (-1) | Nil -> (-2) 
+		     | Stack i -> i | _ -> assert false in
+		 let r = 
+		   match r with Right -> (-1) | Nil -> (-2) 
+		     | Stack i -> i | _ -> assert false in
+		 Recompose (l,r)) lres rres in
+    IdMap.map_to_list (fun x -> x)
+      (IdMap.union_disj sub (IdMap.map conv_source extra))
+    
 
   module TypeList = SortedList.Make(Types)
   let dispatch_basic disp pl : (Types.t * result) list =
@@ -1224,8 +1217,7 @@ struct
       (dispatch_prod2 disp ar1)
       (fun x -> detect_right_tail_call (combine equal_result x))
   and dispatch_prod2 disp ar1 t2 ar2 pl =
-    let aux_final (ret2, (ret1, res)) =
-      IdMap.mapi_to_list (conv_source_prod ar1 ar2 ret1 ret2) res in
+    let aux_final (ret2, (ret1, res)) = merge_res_prod ar1 ar2 ret1 ret2 res in
     return disp pl aux_final (ar1 + ar2)
 
 
@@ -1242,7 +1234,7 @@ struct
 				      | Normal.RecNolabel (Some x,_) -> [x]
 				      | Normal.RecNolabel (None,_) -> []
 				      | _ -> assert false) pl in
-		Some (return disp pl (IdMap.map_to_list conv_source_basic) 0)
+		Some (return disp pl (IdMap.map_to_list conv_source) 0)
 	      else None
 	    in
 	    let none =
@@ -1251,7 +1243,7 @@ struct
 				      | Normal.RecNolabel (_,Some x) -> [x]
 				      | Normal.RecNolabel (_,None) -> []
 				      | _ -> assert false) pl in
-		Some (return disp pl (IdMap.map_to_list conv_source_basic) 0)
+		Some (return disp pl (IdMap.map_to_list conv_source) 0)
 	      else None
 	    in	      
 	    Some (RecNolabel (some,none))