Commits

Sébastien Ferré  committed 9e037c7

Removal of profiling on very quick functions.

  • Participants
  • Parent commits e256763

Comments (0)

Files changed (4)

 let get_trace () = !trace
 let set_trace b = trace := b
 
-let union_msgs msgs1 msgs2 = Common.prof "Dcg.union_msgs" (fun () -> LSet.union msgs1 msgs2)
+let union_msgs msgs1 msgs2 = LSet.union msgs1 msgs2
 
 
 type ('cursor, 'ctx, 'res, 'msg) result = Parsed of 'ctx * 'res * 'cursor | Failed of 'msg LSet.t

File dcg/matcher.ml

 
   end
 
-let string_match regexp s pos = Common.prof "Matcher.string_match" (fun () ->
+let string_match regexp s pos =
   if Str.string_match regexp s pos
   then Some (Str.matched_string s)
-  else None)
+  else None
 
 class virtual str =
   object
     val mutable len = String.length s0
     val mutable eof = eof0
 
-    method private expand = Common.prof "Matcher.str_channel#expand" (fun () ->
+    method private expand =
       try
 	s <- s ^ input_line ch ^ "\n";
 	len <- String.length s
       with End_of_file ->
-	eof <- true)
+	eof <- true
 
     method get regexp p =
       let pos = p-offset in
   object (self)
     method coord = coord
 
-    method get (regexp : Str.regexp) : string option = 
-      Common.prof "Matcher.cursor#get" (fun () -> str#get regexp p)
+    method get (regexp : Str.regexp) : string option = str#get regexp p
 
-    method look (m : string) : bool =
-      Common.prof "Matcher.cursor#look" (fun () -> str#look m p)
+    method look (m : string) : bool = str#look m p
 
     method eof : bool = str#eof p
 
       | _ -> (self :> cursor))
 *)
 
-    method shift (m : string) : cursor = Common.prof "Matcher.cursor#shift" (fun () ->
+    method shift (m : string) : cursor =
       let len = String.length m in
       let p' = p + len in
       let coord' = shiftPos coord m 0 len in
-      new cursor (*skip*) str p' coord')
+      new cursor (*skip*) str p' coord'
 
     method init : unit =
 (*      print_endline (Token.toString ("init", coord)); *)
   done;
   !res)
 *)
-let log_base x = Common.prof "Intmap.log_base" (fun () ->
+let log_base x =
   let res = ref 1 in
   while !res <= max_pow && x >= exp_base.(!res) do
     incr res
   done;
-  !res - 1)
+  !res - 1
 
 let split x l =
   let bound = exp_base.(l) in
 
     let diff bmp1 bmp2 = bmp1 land (lnot bmp2)
 
-    let fold f init bmp = Common.prof "Intmap.Bitmap_base.fold" (fun () ->
+    let fold f init bmp =
       let res = ref init in
       let bmp1 = ref bmp in
       let x1 = ref 0 in
 	bmp1 := !bmp1 lsr 1;
 	incr x1
       done;
-      !res)
+      !res
 
     let iter f bmp =
       for x1 = 0 to base - 1 do
 	val mutable bmp1 = bmp
 	val mutable x1 = 0
 	method init = bmp1 <- bmp; x1 <- 0
-	method next = Common.prof "Intmap.Bitmap.iterator#next" (fun () ->
+	method next =
 	  if bmp1 <> 0
 	  then
 	    let ok = bmp1 land 1 <> 0 in
 	    if ok
 	    then Some elt
 	    else self#next
-	  else None)
+	  else None
       end
     let iterator bmp = new iterator bmp
 
 	Obj.set_field block' i (Obj.repr v');
 	block' end
 
-    let fields_from_mask level bmp f = Common.prof "Bitmap.Block.fields_from_mask" (fun () ->
+    let fields_from_mask level bmp f =
       let bmp, l =
 	Bitmap_base.fold
 	  (fun (bmp,l) x1 ->
       Obj.set_field block 0 (Obj.repr bmp);
       let i = ref 1 in
       List.iter (fun m -> Obj.set_field block !i m; incr i) l;
-      block)
+      block
 
     let mapfilter_fields f block =
       fields_from_mask (level block) (mask block)
 	(fun x1 -> f x1 (get_field block x1))
 
-    let values_from_mask bmp f = Common.prof "Bitmap.Block.values_from_mask" (fun () ->
+    let values_from_mask bmp f =
       let bmp, l =
 	Bitmap_base.fold
 	  (fun (bmp,l) x -> match f x with None -> (Bitmap_base.remove x bmp), l | Some v -> bmp, (v :: l))
       Obj.set_field block 0 (Obj.repr bmp);
       let i = ref 1 in
       List.iter (fun v -> Obj.set_field block !i (Obj.repr v); incr i) l;
-      block)
+      block
 
     let mapfilter_values f block =
       values_from_mask (mask block)
       then Bitmap_base.cardinal (Block.mask b)
       else Block.fold_fields (fun res m -> res + cardinal_repr m) 0 b
 
-let rec mem (x : int) (m : 'a t) : bool = Common.prof "Intmap.mem" (fun () ->
-  mem_repr x (obj false m))
+let rec mem (x : int) (m : 'a t) : bool =
+  mem_repr x (obj false m)
 and mem_repr x = function
   | Empty -> false
   | Full l -> x < exp_base.(l)
 	else mem_repr x2 (Block.get_field b x1)
       with Not_found -> false
 
-let rec choose (m : 'a t) : int = Common.prof "Intmap.choose" (fun () ->
-  choose_repr 0 (obj false m))
+let rec choose (m : 'a t) : int =
+  choose_repr 0 (obj false m)
 and choose_repr pos = function
   | Empty -> raise Not_found
   | Full l -> pos + 0
 	let bound = exp_base.(level) in
 	choose_repr (pos + x1*bound) (Block.get_field b x1)
 
-let rec get (x : int) (m : 'a t) : 'a = Common.prof "Intmap.get" (fun () ->
-  get_repr x (obj false m))
+let rec get (x : int) (m : 'a t) : 'a =
+  get_repr x (obj false m)
 and get_repr x = function
   | Empty ->
       raise Not_found
 	else get_repr x2 (Block.get_field b x1)
       else raise Not_found
       
-let rec add x m = Common.prof "Intmap.add" (fun () ->
-  repr false (add_repr x (obj false m)))
+let rec add x m =
+  repr false (add_repr x (obj false m))
 and add_repr x = function
   | Empty -> Single x
   | Full l as m ->
 	let x1, x2 = split x l_x in
 	Block (Block.two_fields l_x (0,Block b) (x1,Single x2))
 	
-let rec set x v m = Common.prof "Intmap.set" (fun () ->
-  repr false (set_repr x v (obj false m)))
+let rec set x v m =
+  repr false (set_repr x v (obj false m))
 and set_repr x v = function
   | Empty ->
       let l_x = log_base x in
 	Block (Block.two_fields l_x (0,Block b) (x1, set_repr x2 v Empty))
   | m -> add_repr x m
 
-let rec remove (x : int) (m : 'a t) : 'a t = Common.prof "Intmap.remove" (fun () ->
-  repr false (remove_repr x (obj false m)))
+let rec remove (x : int) (m : 'a t) : 'a t =
+  repr false (remove_repr x (obj false m))
 and remove_repr x = function
   | Empty -> Empty
   | Full l ->
       end
 *)
 
-    let rec fold f init (m : 'a t) = Common.prof "Intmap.fold" (fun () ->
-      fold_repr f init 0 (obj false m))
+    let rec fold f init (m : 'a t) =
+      fold_repr f init 0 (obj false m)
     and fold_repr f acc pos = function
       | Empty -> acc
       | Full l ->
 	      acc
 	      (Block.mask b)
 
-    let iter f (m : 'a t) = Common.prof "Intmap.iter" (fun () ->
+    let iter f (m : 'a t) =
       let rec iter_repr pos = function
 	| Empty -> ()
 	| Full l ->
 		(fun x1 -> iter_repr (pos + x1 * bound) (Block.get_field b x1))
 		(Block.mask b)
       in
-      iter_repr 0 (obj false m))
+      iter_repr 0 (obj false m)
 
     let rec domain ?filter m = Common.prof "Intmap.domain" (fun () ->
       repr false (domain_repr ?filter 0 (obj false m)))
 		     (fun x1 m_x1 -> Some (domain_repr ?filter (pos + x1 * bound) m_x1))
 		     b)
 
-    let rec map f m = Common.prof "Intmap.map" (fun () ->
-      repr false (map_repr f 0 (obj false m)))
+    let rec map f m =
+      repr false (map_repr f 0 (obj false m))
     and map_repr f pos m =
       match m with
       | Empty -> Empty
     val empty : t
     val is_empty : t -> bool
     val cardinal : t -> int
+    val domain_cardinal : t -> int
     val mem : int -> int -> t -> bool
     val singleton : int -> int -> t
     val add : int -> int -> t -> t
 	(fun acc x oids -> acc + Intset.cardinal oids)
 	0 r)
 
-    let mem x y r = Common.prof "Intrel2.mem" (fun () ->
+    let domain_cardinal r = Intmap.cardinal r
+
+    let mem x y r =
       try Intset.mem y (Intmap.get x r)
-      with _ -> false)
+      with _ -> false
 
-    let singleton x y = Common.prof "Intrel2.singleton" (fun () ->
-      Intmap.set x (Intset.singleton y) Intmap.empty)
+    let singleton x y =
+      Intmap.set x (Intset.singleton y) Intmap.empty
 
-    let add x y r = Common.prof "Intrel2.add" (fun () ->
+    let add x y r =
       try
 	let oids = Intmap.get x r in
 	Intmap.set x (Intset.add y oids) r
       with Not_found ->
-	Intmap.set x (Intset.singleton y) r)
+	Intmap.set x (Intset.singleton y) r
 
-    let remove x y r = Common.prof "Intrel2.remove" (fun () ->
+    let remove x y r =
       try
 	let oids = Intmap.get x r in
 	let oids' = Intset.remove y oids in
 	if Intset.is_empty oids'
 	then Intmap.remove x r
 	else Intmap.set x oids' r
-      with _ -> r)
+      with _ -> r
 
     let union r1 r2 = Common.prof "Intrel2.union" (fun () ->
       Intmap.map_union
 	    oids)
 	r)
 	
-    let mem_assoc x r = Common.prof "Intrel2.mem_assoc" (fun () ->
-      Intmap.mem x r)
+    let mem_assoc x r =
+      Intmap.mem x r
 
-    let assoc x r = Common.prof "Intrel2.assoc" (fun () ->
-      Intmap.get x r)
+    let assoc x r =
+      Intmap.get x r
 
     let keys r = Common.prof "Intrel2.keys" (fun () ->
       Intmap.domain r)