Small improvements in compilation times for the register allocation pass.

Maps.v: add a PTree.fold1 operation that doesn't maintain the key.


git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@2329 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e

2 files changed, 60 insertions, 1 deletions

diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml
index e057771..2415e1d 100644
--- a/lib/Camlcoq.ml
+++ b/lib/Camlcoq.ml
@@ -267,7 +267,7 @@ let camlfloat_of_coqfloat f =
 (* Timing facility *)
 
 (*
-let timers = (Hashtbl.create 9 : (string, float) Hashtbl.t)
+let timers = Hashtbl.create 9
 
 let add_to_timer name time =
   let old = try Hashtbl.find timers name with Not_found -> 0.0 in
@@ -283,6 +283,26 @@ let time name fn arg =
     add_to_timer name (Unix.gettimeofday() -. start);
     raise x
 
+let time2 name fn arg1 arg2 =
+  let start = Unix.gettimeofday() in
+  try
+    let res = fn arg1 arg2 in
+    add_to_timer name (Unix.gettimeofday() -. start);
+    res
+  with x ->
+    add_to_timer name (Unix.gettimeofday() -. start);
+    raise x
+
+let time3 name fn arg1 arg2 arg3 =
+  let start = Unix.gettimeofday() in
+  try
+    let res = fn arg1 arg2 arg3 in
+    add_to_timer name (Unix.gettimeofday() -. start);
+    res
+  with x ->
+    add_to_timer name (Unix.gettimeofday() -. start);
+    raise x
+
 let print_timers () =
   Hashtbl.iter
     (fun name time -> Printf.printf "%-20s %.3f\n" name time)
diff --git a/lib/Maps.v b/lib/Maps.v
index ddb0c33..3574ee2 100644
--- a/lib/Maps.v
+++ b/lib/Maps.v
@@ -141,6 +141,13 @@ Module Type TREE.
     forall (A B: Type) (f: B -> elt -> A -> B) (v: B) (m: t A),
     fold f m v =
     List.fold_left (fun a p => f a (fst p) (snd p)) (elements m) v.
+  (** Same as [fold], but the function does not receive the [elt] argument. *)
+  Variable fold1:
+    forall (A B: Type), (B -> A -> B) -> t A -> B -> B.
+  Hypothesis fold1_spec:
+    forall (A B: Type) (f: B -> A -> B) (v: B) (m: t A),
+    fold1 f m v =
+    List.fold_left (fun a p => f a (snd p)) (elements m) v.
 End TREE.
 
 (** * The abstract signatures of maps *)
@@ -932,6 +939,38 @@ Module PTree <: TREE.
     intros. unfold fold, elements. rewrite <- xfold_xelements. auto. 
   Qed.
 
+  Fixpoint fold1 (A B: Type) (f: B -> A -> B) (m: t A) (v: B) {struct m} : B :=
+    match m with
+    | Leaf => v
+    | Node l None r =>
+        let v1 := fold1 f l v in
+        fold1 f r v1
+    | Node l (Some x) r =>
+        let v1 := fold1 f l v in
+        let v2 := f v1 x in
+        fold1 f r v2
+    end.
+
+  Lemma fold1_xelements:
+    forall (A B: Type) (f: B -> A -> B) m i v l,
+    List.fold_left (fun a p => f a (snd p)) l (fold1 f m v) =
+    List.fold_left (fun a p => f a (snd p)) (xelements m i l) v.
+  Proof.
+    induction m; intros.
+    simpl. auto.
+    destruct o; simpl.
+    rewrite <- IHm1. simpl. rewrite <- IHm2. auto.
+    rewrite <- IHm1. rewrite <- IHm2. auto. 
+  Qed.
+
+  Theorem fold1_spec:
+    forall (A B: Type) (f: B -> A -> B) (v: B) (m: t A),
+    fold1 f m v =
+    List.fold_left (fun a p => f a (snd p)) (elements m) v.
+  Proof.
+    intros. apply fold1_xelements with (l := @nil (positive * A)). 
+  Qed.
+
 End PTree.
 
 (** * An implementation of maps over type [positive] *)