Commits

Sébastien Ferré committed 3c81254

Optimization of fold_mu by not projecting the relation.
Profiling.

Comments (0)

Files changed (1)

     val union_r : t list -> t
     val inter_r : t list -> t
     val fold : ('a -> int list -> 'a) -> 'a -> t -> 'a
+    val fold_mu : (string * int) list -> string list -> ('a -> (string * int) list -> 'a) -> 'a -> t -> 'a
     val fold_restr : (string * int) list -> string list -> ('a -> (string * int) list -> 'a) -> 'a -> t -> 'a
     val filter_restr : (string * int) list -> string list -> ((string * int) list -> bool) -> t -> t
     val iter : (int list -> unit) -> t -> unit
       | R1 s -> M.is_empty s
       | Rn (n,m) -> M.is_empty m
 	
-    let rec cardinal r =
-      cardinal_obj (obj r.dim r.data)
+    let rec cardinal r = Common.prof "Intreln.cardinal" (fun () ->
+      cardinal_obj (obj r.dim r.data))
     and cardinal_obj = function
       | R0 b -> if b then 1 else 0
       | R1 s -> M.cardinal s
       | Rn (n, m) -> M.fold (fun res x d1 -> res + cardinal_obj (obj (n-1) d1)) 0 m
 	    
-    let rec mem xs r =
+    let rec mem xs r = Common.prof "Intreln.mem" (fun () ->
       if List.length xs = r.dim
       then mem_obj xs (obj r.dim r.data)
-      else raise Invalid_dimension
+      else raise Invalid_dimension)
     and mem_obj xs = function
       | R0 b -> b
       | R1 s -> M.mem (List.hd xs) s
 	  try mem_obj xs1 (obj (n-1) (M.get x m))
 	  with Not_found -> false
 
-    let rec singleton xs =
+    let rec singleton xs = Common.prof "Intreln.singleton" (fun () ->
       let n = List.length xs in
-      {dim = n; data = repr (singleton_obj n xs)}
+      {dim = n; data = repr (singleton_obj n xs)})
     and singleton_obj n = function
       | [] -> R0 true
       | [x] -> R1 (M.singleton x)
       | x::xs1 -> Rn (n, M.set x (repr (singleton_obj (n-1) xs1)) M.empty)
 	      
-    let rec add xs r =
+    let rec add xs r = Common.prof "Intreln.add" (fun () ->
       if List.length xs = r.dim
       then {r with data = repr (add_obj xs (obj r.dim r.data))}
-      else raise Invalid_dimension
+      else raise Invalid_dimension)
     and add_obj xs = function
       | R0 _ -> R0 true
       | R1 s -> R1 (M.add (List.hd xs) s)
 	  let d1 = try obj n1 (M.get x m) with Not_found -> empty_obj n1 in
 	  Rn (n, M.set x (repr (add_obj xs1 d1)) m)
 
-    let rec remove xs r =
+    let rec remove xs r = Common.prof "Intreln.remove" (fun () ->
       if List.length xs = r.dim
       then {r with data = repr (remove_obj xs (obj r.dim r.data))}
-      else raise Invalid_dimension
+      else raise Invalid_dimension)
     and remove_obj xs = function
       | R0 _ -> R0 false
       | R1 s -> R1 (M.remove (List.hd xs) s)
 	  with Not_found ->
 	    Rn (n,m)
 
-    let rec union r1 r2 =
+    let rec union r1 r2 = Common.prof "Intreln.union" (fun () ->
       if r1.dim = r2.dim
       then {dim = r1.dim; data = repr (union_obj (obj r1.dim r1.data) (obj r2.dim r2.data))}
-      else raise Invalid_dimension
+      else raise Invalid_dimension)
     and union_obj d1 d2 =
       match d1, d2 with
       | R0 b1, R0 b2 -> R0 (b1 || b2)
 		m1 m2)
       | _, _ -> assert false
 
-    let rec inter r1 r2 =
+    let rec inter r1 r2 = Common.prof "Intreln.inter" (fun () ->
       if r1.dim = r2.dim
       then {dim = r1.dim; data = repr (inter_obj (obj r1.dim r1.data) (obj r2.dim r2.data))}
-      else raise Invalid_dimension
+      else raise Invalid_dimension)
     and inter_obj d1 d2 =
       match d1, d2 with
       | R0 b1, R0 b2 -> R0 (b1 && b2)
 		m1 m2)
       | _, _ -> assert false
 
-    let rec diff r1 r2 =
+    let rec diff r1 r2 = Common.prof "Intreln.diff" (fun () ->
       if r1.dim = r2.dim
       then {dim = r1.dim; data = repr (diff_obj (obj r1.dim r1.data) (obj r2.dim r2.data))}
-      else raise Invalid_dimension
+      else raise Invalid_dimension)
     and diff_obj d1 d2 =
       match d1, d2 with
       | R0 b1, R0 b2 -> R0 (b1 && not b2)
       | [] -> invalid_arg "Intreln.Intmap.inter_r : empty list of relations"
       | r::rs -> List.fold_left inter r rs
 
-    let rec fold f init r =
-      fold_obj f init [] (obj r.dim r.data)
+    let rec fold f init r = Common.prof "Intreln.fold" (fun () ->
+      fold_obj f init [] (obj r.dim r.data))
     and fold_obj f acc xs = function
       | R0 b -> if b then f acc [] else acc
       | R1 s -> M.fold (fun res x _ -> f res (List.rev (x::xs))) acc s
 	      fold_obj f res (x::xs) (obj n1 d1))
 	    acc m
 
-    let rec project ps r =
+    let rec fold_mu mu vs f init r = Common.prof "Intreln.fold_mu" (fun () ->
+         (* "" variables must be ignored in generated mappings *)
+      let rec aux = function ""::l -> aux l | l -> l in
+      let vs_prefix = List.rev (aux (List.rev vs)) in
+      fold_mu_obj f init mu vs_prefix (obj r.dim r.data))
+    and fold_mu_obj f acc mu vs = function
+      | R0 b ->
+	  if b then f acc mu else acc
+      | R1 s ->
+	  ( match vs with
+	  | [] -> f acc mu
+	  | v::_ ->
+	      (try
+		let x = List.assoc v mu in
+		if M.mem x s
+		then f acc mu
+		else acc
+	      with Not_found ->
+		M.fold
+		  (fun res x _ ->
+		    let mu' = if v="" then mu else (v,x)::mu in
+		    f res mu')
+		  acc s))
+      | Rn (n,m) ->
+	  let n1 = n-1 in
+	  ( match vs with
+	  | [] -> f acc mu
+	  | v::vs1 ->
+	      (try
+		let x = List.assoc v mu in
+		try
+		  let d1 = M.get x m in
+		  fold_mu_obj f acc mu vs1 (obj n1 d1)
+		with Not_found ->
+		  acc
+	      with Not_found ->
+		M.fold
+		  (fun res x d1 ->
+		    let mu' = if v="" then mu else (v,x)::mu in
+		    fold_mu_obj f res mu' vs1 (obj n1 d1))
+		  acc m))
+
+    let rec project ps r = Common.prof "Intreln.project" (fun () ->
       if Mask.dim ps = r.dim
       then
 	if Mask.size ps = r.dim
 	then r
 	else{dim = Mask.size ps;
 	     data = repr (project_obj ps (obj r.dim r.data))}
-      else raise Invalid_dimension
+      else raise Invalid_dimension)
     and project_obj ps = function
       | R0 b -> R0 b
       | R1 s ->
 	    then R0 (not (M.is_empty m))
 	    else M.fold (fun res x d1 -> union_obj res (project_obj ps1 (obj n1 d1))) (empty_obj n1') m
 
-    let rec fold_restr mu vs f init r =
+    let rec fold_restr mu vs f init r = Common.prof "Intreln.fold_restr" (fun () ->
          (* "" variables must be ignored in generated mappings *)
       let r' = project (List.map ((<>) "") vs) r in (* done to avoid doublons when folding *)
       let vs' = List.filter ((<>) "") vs in
-      fold_restr_obj f init mu vs' (obj r'.dim r'.data)
+      fold_restr_obj f init mu vs' (obj r'.dim r'.data))
     and fold_restr_obj f acc mu vs = function
       | R0 b -> if b then f acc mu else acc
       | R1 s ->
 		fold_restr_obj f res ((v,x)::mu) (List.tl vs) (obj n1 d1))
 	      acc m)
 
-    let rec filter_restr mu vs f r =
+    let rec filter_restr mu vs f r = Common.prof "Intreln.filter_restr" (fun () ->
          (* "" variables must be ignored in generated mappings *)
       let r' = project (List.map ((<>) "") vs) r in (* done to avoid doublons when folding *)
       let vs' = List.filter ((<>) "") vs in
-      {dim = List.length vs'; data = repr (filter_restr_obj f mu vs' (obj r'.dim r'.data))}
+      {dim = List.length vs'; data = repr (filter_restr_obj f mu vs' (obj r'.dim r'.data))})
     and filter_restr_obj f mu vs = function
       | R0 b -> R0 (b && f mu)
       | R1 s ->
 		    else Some (repr d1'))
 		  m))
 
-    let rec iter f r =
-      iter_obj f [] (obj r.dim r.data)
+    let rec iter f r = Common.prof "Intreln.iter" (fun () ->
+      iter_obj f [] (obj r.dim r.data))
     and iter_obj f xs = function
       | R0 b -> if b then f [] else ()
       | R1 s -> M.iter (fun x _ -> f (List.rev (x::xs))) s
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.