[r2002-11-02 19:24:08 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-02 19:24:09+00:00

driver/cduce.ml

@@ -85,7 +85,52 @@ let debug = function
 		 (List.map (fun p -> Patterns.Compile.normal 
 			      (Patterns.descr p)) pl) in
       Patterns.Compile.show ppf (Types.descr t) pl
-  | _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"
+  | `Normal_record t ->
+      Format.fprintf ppf "[DEBUG:normal_record]@\n";
+      let t = Types.descr (Typer.typ t) in
+      let count = ref 0 and seen = ref [] in
+      match Types.Record.first_label t with
+	    | `Empty -> Format.fprintf ppf "Empty"
+	    | `Any -> Format.fprintf ppf "Any"
+	    | `Label l ->
+		let (pr,ab) = Types.Record.normal' t l in
+		Format.fprintf ppf "Label (%s,@[" (Types.label_name l);
+		List.iter (fun (d,n) ->
+			     Format.fprintf ppf "%a => @[%a@];@\n"
+			     Types.Print.print_descr d
+			     Types.Print.print_descr n
+			  ) pr;
+		Format.fprintf ppf "@] Absent: @[%a@])@\n" 
+		  Types.Print.print_descr 
+		  (match ab with Some x -> x | None -> Types.empty)
+(*
+  | `Normal_record t ->
+      Format.fprintf ppf "[DEBUG:normal_record]@\n";
+      let t = Types.descr (Typer.typ t) in
+      let r = Types.Record.normal t in
+      let count = ref 0 and seen = ref [] in
+      let rec aux ppf x =
+	try 
+	  let no = List.assq x !seen in
+	  Format.fprintf ppf "[[%i]]" no
+	with Not_found ->
+	  incr count;
+	  seen := (x, !count) :: !seen;
+	  Format.fprintf ppf "[[%i]]:" !count;
+	  match x with
+	    | `Success -> Format.fprintf ppf "Success"
+	    | `Fail -> Format.fprintf ppf "Fail"
+	    | `Label (l,pr,ab) ->
+		Format.fprintf ppf "Label (%s,@[" (Types.label_name l);
+		List.iter (fun (d,n) ->
+			     Format.fprintf ppf "%a => @[%a@];@\n"
+			     Types.Print.print_descr d
+			     aux n
+			  ) pr;
+		Format.fprintf ppf "@] Absent: @[%a@])" aux ab
+      in
+      Format.fprintf ppf "%a@\n" aux r
+*)
 
 let typing_env = ref Typer.Env.empty
 let eval_env = ref Eval.Env.empty

parser/ast.ml

@@ -15,7 +15,9 @@ and pmodule_item' =
 and debug_directive =
   [ `Filter of ppat * ppat
   | `Accept of ppat
-  | `Compile of ppat * ppat list ]
+  | `Compile of ppat * ppat list 
+  | `Normal_record of ppat
+  ]
 
 
 and pexpr = pexpr' located

parser/parser.ml

@@ -58,8 +58,9 @@ EXTEND
 
   debug_directive: [
     [ LIDENT "filter"; t = pat; p = pat -> `Filter(t,p)
-    | LIDENT "accept"; p = pat -> `Accept p;
+    | LIDENT "accept"; p = pat -> `Accept p
     | LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
+    | LIDENT "normal_record"; t = pat -> `Normal_record t
     ]
   ];
 

runtime/run_dispatch.ml

@@ -93,23 +93,24 @@ and run_disp_prod2 v1 r1 v v2 x =
 	    
 and run_disp_record f v bindings fields = function
   | None -> assert false
-  | Some record -> run_disp_record' f v bindings fields record
+  | Some record -> run_disp_record' f v bindings None fields record
 
-and run_disp_record' f v bindings fields = function
+and run_disp_record' f v bindings abs fields = function
   | `Result r -> make_result_record f v bindings r
+  | `Absent -> run_disp_record f v bindings fields abs
   | `Label (l, present, absent) ->
       let rec aux = function
 	| (l1,_) :: rem when l1 < l -> aux rem
 	| (l1,vl) :: rem when l1 = l -> 
-	    run_disp_field f v bindings rem l vl present
+	    run_disp_field f v bindings abs rem l vl present
 	| _ -> run_disp_record f v bindings fields absent
       in
       aux fields
 
-and run_disp_field f v bindings fields l vl = function
+and run_disp_field f v bindings abs fields l vl = function
   | `None -> assert false
-  | `Ignore r -> run_disp_record' f v bindings fields r
+  | `Ignore r -> run_disp_record' f v bindings abs fields r
   | `TailCall d -> run_dispatcher d vl
   | `Dispatch (dl,bl) ->
       let (codel,rl) = run_dispatcher dl vl in
-      run_disp_record' f v ((l,rl)::bindings) fields bl.(codel)
+      run_disp_record' f v ((l,rl)::bindings) abs fields bl.(codel)

tests/stress_opt_arg.cd

+type T = 
+      { a =? `A; b =? `A; c =? `A;
+	d =? `A; e =? `A; f =? `A;
+	g =? `A; h =? `A; i =? `A;
+	j =? `A; k =? `A; l =? `A;
+	m =? `A; n =? `A; o =? `A;
+	p =? `A; q =? `A; r =? `A };;	
+
+
+debug compile Any T;;
+
+debug compile T 
+   ({ a = x } | ( x:= `B)) &
+   ({ b = y } | ( y:= `B)) &
+   ({ c = z } | ( z:= `B))
+;;
+     		 
+      

tests/stress_opt_seq.cd

+type T = [ `A? `B? `C? `D? `E? `F? `G? `H? `I? `J?
+           `K? `L? `M? `N? `O? `P? `Q? `R?  ];;
+
+
+debug compile Any T;;
+
+(*
+debug compile T
+P1 where
+  P1 = (`A & (a := 1), P2) | (a := 2) & P2 and
+  P2 = (`B & (b := 1), P3) | (b := 2) & P3 and
+  P3 = (`C & (c := 1), P4) | (c := 2) & P4 and
+  P4 = (`D & (d := 1), P5) | (d := 2) & P5 and
+  P5 = `nil;;
+
+match [ `A `B `C ] with (P1 where
+  P1 = (`A & (a := 1), P2) | (a := 2) & P2 and
+  P2 = (`B & (b := 1), P3) | (b := 2) & P3 and
+  P3 = (`C & (c := 1), P4) | (c := 2) & P4 and
+  P4 = (`D & (d := 1), P5) | (d := 2) & P5 and
+  P5 = `nil) -> (a,b,c,d);;
+*)

types/patterns.ml

@@ -317,9 +317,14 @@ struct
 		List.map (fun (t,x) -> (restrict t p, aux x fields)) pr in
 	      `Label (l1, pr, `Fail)
 	  | (`Label (l1, pr, ab),_) ->
+	      let aux_ab = aux ab fields in
 	      let pr = 
-		List.map (fun (t,x) -> (constr t, aux x fields)) pr in
-	      `Label (l1, pr, aux ab fields)
+		List.map (fun (t,x) -> (constr t, 
+(* Types.Record.normal enforce physical equility
+   in case of a ? field *)
+					if x==ab then aux_ab else
+					aux x fields)) pr in
+	      `Label (l1, pr, aux_ab)
       in
 
       let line accu ((res,fields),acc) =
@@ -355,7 +360,8 @@ struct
   }
   and record = 
       [ `Label of Types.label * record dispatch * record option
-      | `Result of result ]
+      | `Result of result
+      | `Absent ]
       
   and 'a dispatch =
       [ `Dispatch of dispatcher * 'a array
@@ -439,6 +445,7 @@ struct
   let combine_record l present absent = 
     match (present,absent) with
       | (`Ignore r1, Some r2) when r1 = r2 -> r1
+      | (`Ignore `Absent, Some r) -> r
       | (`Ignore r, None) -> r
       | _ -> `Label (l, present, absent)
 
@@ -587,7 +594,7 @@ struct
 
   let conv_source_record catch (v,s) = match s with
     | (`Catch | `Const _) as x -> x
-    | `Field l -> `Field (l, assoc v (List.assoc l catch))
+    | `Field l -> `Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)
     | _ -> assert false
 
 
@@ -724,14 +731,62 @@ struct
 	 | (res, catch, `Label (l1, _, ab)) when l1 = l -> (res, catch, ab)
 	 | x -> x)
 
+  let memo_dispatch_record = ref []
+  let memo_dr_count = ref 0
+
+  let rec print_normal_record ppf = function
+    | `Success -> Format.fprintf ppf "Success"
+    | `Fail -> Format.fprintf ppf "Fail"
+    | `Label (l,pr,ab) ->
+	Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.label_name l)
+	   print_normal_record_pr pr
+	   print_normal_record ab
+    | _ -> assert false
+  and print_normal_record_pr ppf =
+    List.iter (fun (nf,r) ->
+		 Format.fprintf ppf "[_,%a]"
+		  print_normal_record r) 
+  let dump_dr ppf pl =
+    Array.iteri
+      (fun i x ->
+	 Format.fprintf ppf "[%i:]" i;
+	 List.iter
+	   (fun (res,catch,nr) ->
+	      Format.fprintf ppf "Result:";
+	      List.iter (fun (x,s) -> Format.fprintf ppf "%s," x) res;
+    	      Format.fprintf ppf "Catch:";
+	      List.iter (fun (l,r) -> 
+			   Format.fprintf ppf "%s[" (Types.label_name l);
+			   List.iter (fun (x,i) -> 
+					Format.fprintf ppf "%s->%i" x i) r;
+			   Format.fprintf ppf "]"
+			) catch;
+    	      Format.fprintf ppf "NR:%a" print_normal_record nr
+	   ) x;
+	 Format.fprintf ppf "@\n"
+      ) pl
+
   let rec dispatch_record disp : record option =
     let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
     let pl0 = Array.map prep disp.pl in
     let t = Types.Record.get disp.t in
-    dispatch_record_opt disp t pl0
+    let r = dispatch_record_opt disp t pl0 in
+    memo_dispatch_record := [];
+    r
   and dispatch_record_opt disp t pl =
     if Types.Record.is_empty t then None 
     else Some (dispatch_record_label disp t pl)
+(*  and dispatch_record_label disp t pl =
+    try List.assoc (t,pl) !memo_dispatch_record
+    with Not_found ->
+      (*       Format.fprintf Format.std_formatter "%a@\n" 
+	       Types.Print.print_descr (Types.Record.descr t);
+	       dump_dr Format.std_formatter pl; *)
+      let r = dispatch_record_label' disp t pl in 
+      incr memo_dr_count;
+      let r = !memo_dr_count, r in 
+      memo_dispatch_record := ((t,pl),r) :: !memo_dispatch_record;
+      r *)
   and dispatch_record_label disp t pl =
     match collect_first_label pl with
       | None -> 
@@ -740,6 +795,11 @@ struct
 	    List.map (conv_source_record catch) res in
 	  `Result (return disp pl aux_final)
       | Some l ->
+	  let (plabs,absent) = 
+	    let pl = label_not_found l pl in
+	    let t = Types.Record.restrict_label_absent t l in
+	    pl, dispatch_record_opt disp t pl
+	  in
 	  let present =
 	    let pl = label_found l pl in
 	    let t = Types.Record.restrict_label_present t l in
@@ -749,23 +809,23 @@ struct
 		     List.map (fun (p, r) -> p, (res, catch, r)) d, []
 		 | x -> [],[x])
 	      (Types.Record.project_field t l)
-	      (dispatch_record_field l disp t)
+	      (dispatch_record_field l disp t plabs)
 	      (fun x -> combine x)
 	  in
-	  let absent = 
-	    let pl = label_not_found l pl in
-	    let t = Types.Record.restrict_label_absent t l in
-	    dispatch_record_opt disp t pl
-	  in
 	  combine_record l present absent
-  and dispatch_record_field l disp t tfield pl others =
+  and dispatch_record_field l disp t plabs tfield pl others =
     let t = Types.Record.restrict_field t l tfield in
-    let aux (ret, (res, catch, rem)) = (res, (l,ret) :: catch, rem) in
+    let aux (ret, (res, catch, rem)) = 
+      let catch = if ret = [] then catch else (l,ret) :: catch in
+      (res, catch, rem) in
     let pl = Array.map (List.map aux) pl in
     Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
+    if pl = plabs then `Absent else
+      (* TODO: Check that this is the good condition ....
+	 Need condition on t ? *)
     dispatch_record_label disp t pl
     
-
+      
   let actions disp =
     match disp.actions with
       | Some a -> a
@@ -874,6 +934,7 @@ struct
 	  Format.fprintf ppf "     @[%a@]@\n"  print_record r
     and print_record ppf = function
       | `Result r -> print_ret ppf r
+      | `Absent -> Format.fprintf ppf "Jump to Absent"
       | `Label (l, present, absent) ->
 	  let l = Types.label_name l in
 	  Format.fprintf ppf "check label %s:@\n" l;
@@ -916,8 +977,8 @@ struct
       | [] -> ()
       | d :: rem ->
 	  to_print := rem;
-	  Format.fprintf ppf "Dispatcher %i accepts [%a]@\n" 
-	    d.id Types.Print.print_descr (Types.normalize d.t);
+(*	  Format.fprintf ppf "Dispatcher %i accepts [%a]@\n" 
+	    d.id Types.Print.print_descr (Types.normalize d.t); *)
 	  let print_code code (t, arity, m) =
 	    Format.fprintf ppf "  Returns $%i(arity=%i) for [%a]" 
 	      code arity

types/patterns.mli

@@ -51,7 +51,8 @@ module Compile: sig
   }
   and record = 
       [ `Label of Types.label * record dispatch * record option
-      | `Result of result ]
+      | `Result of result 
+      | `Absent ]
       
   and 'a dispatch =
       [ `Dispatch of dispatcher * 'a array

types/types.ml

@@ -2,6 +2,8 @@ open Recursive
 open Printf
 
 
+let map_sort f l =
+  SortedList.from_list (List.map f l)
 
 type label = int
 type atom  = int
@@ -660,7 +662,6 @@ struct
     let line r = List.for_all (fun (l,(o,d)) -> o || non_empty d) r in
     List.filter line (get_record d.record)
 
-
   let restrict_label_present t l =
     let restr = function 
       | (true, d) -> if non_empty d then (false,d) else raise Exit 
@@ -706,11 +707,16 @@ struct
     match (n, r) with
       | (`Success, _) | (_, []) -> `Success
       | (`Fail, r) ->
-	  let aux (l,(o,t)) n = `Label (l, [t,n], if o then n else `Fail) in
+	  let aux (l,(o,t)) n = 
+	    `Label (l, [t,n], if o then n else `Fail) in
 	  List.fold_right aux r `Success
       | (`Label (l1,present,absent), (l2,(o,t2))::r') ->
 	  if (l1 < l2) then
 	    let pr =  List.map (fun (t,x) -> (t, merge_record x r)) present in
+	    let t = List.fold_left (fun a (t,_) -> diff a t) any present in
+	    let pr = 
+	      if non_empty t then (t, merge_record `Fail r) :: pr
+	      else pr in
 	    `Label (l1,pr,merge_record absent r)
 	  else if (l2 < l1) then
 	    let n' = merge_record n r' in
@@ -731,21 +737,84 @@ struct
 	    let abs = if o then merge_record absent r' else absent in
 	    `Label (l1, !res, abs)
 
+  module Unify = Map.Make(struct type t = normal let compare = compare end)
+
+  let repository = ref Unify.empty
+
+  let rec canonize = function
+    | `Label (l,pr,ab) as x ->
+	(try Unify.find x !repository 
+	 with Not_found -> 
+	   let pr = List.map (fun (t,n) -> canonize n,t) pr in
+	   let pr = SortedMap.from_list cup pr in
+	   let pr = List.map (fun (n,t) -> (t,n)) pr in
+	   let x = `Label (l, pr, canonize ab) in
+	   try Unify.find x !repository
+	   with Not_found -> repository := Unify.add x x !repository; x
+	)
+    | x -> x
 
   let normal d =
-    List.fold_left merge_record `Fail (get d)
+    let r = canonize (List.fold_left merge_record `Fail (get d)) in
+    repository := Unify.empty;
+    r
 
+  type normal' =
+      [ `Success
+      | `Label of label * (descr * descr) list * descr option ] option
+
+(* NOTE: this function relies on the fact that generic order
+         makes smallest labels appear first *)
+
+  let first_label d =
+    let d = d.record in
+    let min = ref None in
+    let lab (l,o,t) = match !min with 
+      | Some l' when l >= l' -> () 
+      | _ -> if o && (descr t = any) then () else min := Some l in
+    let line (p,n) =
+      (match p with f::_ -> lab f | _ -> ());
+      (match n with f::_ -> lab f | _ -> ()) in
+    List.iter line d;
+    match !min with
+      | None -> if d = [] then `Empty else `Any
+      | Some l -> `Label l
+
+  let normal' (d : descr) l =
+    let ab = ref empty in
+    let rec extract f = function
+      | (l',o,t) :: rem when l = l' -> 
+	  f o (descr t); extract f rem
+      | x :: rem -> x :: (extract f rem)
+      | [] -> [] in
+    let line (p,n) =
+      let ao = ref true and ad = ref any in
+      let p = 
+	extract (fun o d -> ao := !ao && o; ad := cap !ad d) p
+      and n = 
+	extract (fun o d -> ao := !ao && not o; ad := diff !ad d) n
+      in
+      (* Note: p and n are still sorted *)
+      let d = { empty with record = [(p,n)] } in
+      if !ao then ab := cup d !ab;
+      (!ad, d) in
+    let pr = List.map line d.record in
+    let pr = Product.normal_aux pr in
+    let ab = if is_empty !ab then None else Some !ab in
+    (pr, ab)
+	    
 
   let any = { empty with record = any.record }
   let is_empty d = d = []
+  let descr l =
+    let line l = map_sort (fun (l,(o,d)) -> (l,o,cons d)) l, [] in 
+    { empty with record = map_sort line l }
 end
 
 
 
 let memo_normalize = ref DescrMap.empty
 
-let map_sort f l =
-  SortedList.from_list (List.map f l)
 
 let rec rec_normalize d =
   try DescrMap.find d !memo_normalize

types/types.mli

@@ -97,8 +97,9 @@ module Record : sig
   val any : descr
 
   (* List of maps label -> (optional, content) *)
-  type t = (label, (bool * descr)) SortedMap.t list
+  type t (* = (label, (bool * descr)) SortedMap.t list *)
   val get: descr -> t
+  val descr: t -> descr
   val is_empty: t -> bool
   val restrict_label_present: t -> label -> t
   val restrict_field: t -> label -> descr -> t
@@ -109,8 +110,12 @@ module Record : sig
       [ `Success
       | `Fail
       | `Label of label * (descr * normal) list * normal ]
+	   
   val normal: descr -> normal
 
+  val normal': descr -> label -> (descr * descr) list * descr option
+  val first_label: descr -> [ `Empty | `Any | `Label of label ]
+
   val project : descr -> label -> descr
     (* Raise Not_found if label is not necessarily present *)
 end