simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-07 11:45:31 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge pull request #4 from Drup/master

Browse source 
Change the representation of optimized list of operation and add folding.
This commit is contained in:
Simon Cruanes 2014-06-12 10:59:47 +02:00
commit 2a27ebdf6d
2 changed files with 97 additions and 108 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

191
core/CCBatch.ml
View file

@ -30,6 +30,7 @@ module type COLLECTION = sig
type 'a t type 'a t
val empty : 'a t val empty : 'a t
val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
val map : ('a -> 'b) -> 'a t -> 'b t val map : ('a -> 'b) -> 'a t -> 'b t
val filter : ('a -> bool) -> 'a t -> 'a t val filter : ('a -> bool) -> 'a t -> 'a t
val filter_map : ('a -> 'b option) -> 'a t -> 'b t val filter_map : ('a -> 'b option) -> 'a t -> 'b t
@ -45,15 +46,7 @@ module type S = sig
val length : (_,_) op -> int val length : (_,_) op -> int
(** Number of intermediate structures needed to compute this operation *) (** Number of intermediate structures needed to compute this operation *)
type optimization_level = val apply : ('a,'b) op -> 'a t -> 'b t
| OptimNone
| OptimBase
| OptimMergeFlatMap
val optimize : ?level:optimization_level -> ('a,'b) op -> ('a,'b) op
(** Try to minimize the length of the operation *)
val apply : ?level:optimization_level -> ('a,'b) op -> 'a t -> 'b t
(** Apply the operation to the collection. (** Apply the operation to the collection.
@param level the optimization level, default is [OptimBase] *) @param level the optimization level, default is [OptimBase] *)
@ -79,9 +72,10 @@ end
module Make(C : COLLECTION) = struct module Make(C : COLLECTION) = struct
type 'a t = 'a C.t type 'a t = 'a C.t
type (_,_) op = type (_,_) op =
| Id : ('a,'a) op | Nil : ('a,'a) op
| Compose : ('a,'b) base_op * ('b, 'c) op -> ('a, 'c) op | Compose : ('a,'b) base_op * ('b, 'c) op -> ('a, 'c) op
and (_,_) base_op = and (_,_) base_op =
| Id : ('a, 'a) base_op
| Map : ('a -> 'b) -> ('a, 'b) base_op | Map : ('a -> 'b) -> ('a, 'b) base_op
| Filter : ('a -> bool) -> ('a, 'a) base_op | Filter : ('a -> bool) -> ('a, 'a) base_op
| FilterMap : ('a -> 'b option) -> ('a,'b) base_op | FilterMap : ('a -> 'b option) -> ('a,'b) base_op
@ -91,134 +85,135 @@ module Make(C : COLLECTION) = struct
(* associativity: put parenthesis on the right *) (* associativity: put parenthesis on the right *)
let rec _compose : type a b c. (a,b) op -> (b,c) op -> (a,c) op let rec _compose : type a b c. (a,b) op -> (b,c) op -> (a,c) op
= fun f g -> match f with = fun f g -> match f with
| Compose (f1, Id) -> Compose (f1, g) | Compose (f1, Nil) -> Compose (f1, g)
| Compose (f1, f2) -> Compose (f1, _compose f2 g) | Compose (f1, f2) -> Compose (f1, _compose f2 g)
| Id -> g | Nil -> g
(* result of one step of optimization, indicates whether the object did
change or not *)
type 'a optim_result =
| Same of 'a
| New of 'a
type optimization_level = (* After optimization, the op is a list of flatmaps, with maybe something else at the end *)
| OptimNone type (_,_) optimized_op =
| OptimBase | Base : ('a,'b) base_op -> ('a,'b) optimized_op
| OptimMergeFlatMap | FlatMapPlus : ('a -> 'b t) * ('b, 'c) optimized_op -> ('a, 'c) optimized_op
let _new_compose a b = New (Compose (a,b))
(* optimize a batch operation by fusion *) (* As compose, but optimize recursively on the way. *)
let rec _optimize : type a b. level:optimization_level -> (a,b) op -> (a,b) op let rec optimize_compose
= fun ~level op -> match op with : type a b c. (a,b) base_op -> (b,c) op -> (a,c) optimized_op
| _ when level = OptimNone -> op = fun base_op op -> match base_op, op with
| Compose (a, b) -> | f, Nil -> Base f
let b' = _optimize ~level b in | Id, Compose (f, cont) -> optimize_compose f cont
_optimize_rec ~level (Compose (a, b')) | f, Compose (Id, cont) -> optimize_compose f cont
| Id -> Id | Map f, Compose (Map g, cont) ->
(* repeat optimization until a fixpoint is reached *) optimize_compose (Map (fun x -> g (f x))) cont
and _optimize_rec : type a b. level:optimization_level -> (a,b) op -> (a,b) op | Map f, Compose (Filter p, cont) ->
= fun ~level op -> match _optimize_head ~level op with optimize_compose
| Same _ -> op
| New op' -> _optimize_rec ~level op'
and _optimize_head
: type a b. level:optimization_level -> (a,b) op -> (a,b) op optim_result
= fun ~level op -> match op with
| Id -> Same Id
| Compose (Map f, Compose (Map g, cont)) ->
_new_compose (Map (fun x -> g (f x))) cont
| Compose (Map f, Compose (Filter p, cont)) ->
_new_compose
(FilterMap (fun x -> let y = f x in if p y then Some y else None)) cont (FilterMap (fun x -> let y = f x in if p y then Some y else None)) cont
| Compose (Map f, Compose (FilterMap f', cont)) -> | Map f, Compose (FilterMap f', cont) ->
_new_compose optimize_compose
(FilterMap (fun x -> f' (f x))) cont (FilterMap (fun x -> f' (f x))) cont
| Compose (Map f, Compose (FlatMap f', cont)) -> | Map f, Compose (FlatMap f', cont) ->
_new_compose optimize_compose
(FlatMap (fun x -> f' (f x))) cont (FlatMap (fun x -> f' (f x))) cont
| Compose (Filter p, Compose (Filter p', cont)) -> | Filter p, Compose (Filter p', cont) ->
_new_compose (Filter (fun x -> p x && p' x)) cont optimize_compose (Filter (fun x -> p x && p' x)) cont
| Compose (Filter p, Compose (Map g, cont)) -> | Filter p, Compose (Map g, cont) ->
_new_compose optimize_compose
(FilterMap (fun x -> if p x then Some (g x) else None)) cont (FilterMap (fun x -> if p x then Some (g x) else None)) cont
| Compose (Filter p, Compose (FilterMap f', cont)) -> | Filter p, Compose (FilterMap f', cont) ->
_new_compose optimize_compose
(FilterMap (fun x -> if p x then f' x else None)) cont (FilterMap (fun x -> if p x then f' x else None)) cont
| Compose (Filter p, Compose (FlatMap f', cont)) -> | Filter p, Compose (FlatMap f', cont) ->
_new_compose optimize_compose
(FlatMap (fun x -> if p x then f' x else C.empty)) cont (FlatMap (fun x -> if p x then f' x else C.empty)) cont
| Compose (FilterMap f, Compose (FilterMap f', cont)) -> | FilterMap f, Compose (FilterMap f', cont) ->
_new_compose optimize_compose
(FilterMap (FilterMap
(fun x -> match f x with None -> None | Some y -> f' y)) (fun x -> match f x with None -> None | Some y -> f' y))
cont cont
| Compose (FilterMap f, Compose (Filter p, cont)) -> | FilterMap f, Compose (Filter p, cont) ->
_new_compose optimize_compose
(FilterMap (FilterMap
(fun x -> match f x with (fun x -> match f x with
| (Some y) as res when p y -> res | (Some y) as res when p y -> res
| _ -> None)) | _ -> None))
cont cont
| Compose (FilterMap f, Compose (Map f', cont)) -> | FilterMap f, Compose (Map f', cont) ->
_new_compose optimize_compose
(FilterMap (FilterMap
(fun x -> match f x with (fun x -> match f x with
| None -> None | None -> None
| Some y -> Some (f' y))) | Some y -> Some (f' y)))
cont cont
| Compose (FilterMap f, Compose (FlatMap f', cont)) -> | FilterMap f, Compose (FlatMap f', cont) ->
_new_compose optimize_compose
(FlatMap (FlatMap
(fun x -> match f x with (fun x -> match f x with
| None -> C.empty | None -> C.empty
| Some y -> f' y)) | Some y -> f' y))
cont cont
| Compose (FlatMap f, Compose (FlatMap f', cont)) ->
_new_compose (* flatmap doesn't compose with anything *)
(FlatMap | FlatMap f, Compose (f', cont) ->
(fun x -> FlatMapPlus (f, optimize_compose f' cont)
let a = f x in
C.flat_map f' a))
cont
| (Compose _) as op ->
Same op (* cannot optimize *)
let rec length : type a b. (a,b) op -> int = function let rec length : type a b. (a,b) op -> int = function
| Id -> 0 | Nil -> 0
| Compose (_, Id) -> 0
| Compose (_, cont) -> 1 + length cont | Compose (_, cont) -> 1 + length cont
let optimize ?(level=OptimBase) = _optimize ~level
let apply ?level op a = (* optimize a batch operation by fusion *)
let rec _apply : type a b. (a,b) op -> a t -> b t let optimize : type a b. (a,b) op -> (a,b) optimized_op
= fun op a -> match op with = fun op -> match op with
| Compose (op1, op2) -> | Compose (a, b) -> optimize_compose a b
let a' = _apply_base op1 a in | Nil -> Base Id
_apply op2 a'
| Id -> a let rec apply_optimized : type a b. (a,b) optimized_op -> a t -> b t
and _apply_base : type a b. (a,b) base_op -> a t -> b t = fun op a -> match op with
= fun op a -> match op with | Base f -> apply_base f a
| Map f -> C.map f a | FlatMapPlus (f,c) -> apply_optimized c @@ C.flat_map f a
| Filter p -> C.filter p a and apply_base : type a b. (a,b) base_op -> a t -> b t
| FlatMap f -> C.flat_map f a = fun op a -> match op with
| FilterMap f -> C.filter_map f a | Map f -> C.map f a
in | Filter p -> C.filter p a
(* optimize and run *) | FlatMap f -> C.flat_map f a
let op' = optimize ?level op in | FilterMap f -> C.filter_map f a
_apply op' a | Id -> a
let fusion_fold : type a b c. (a,b) base_op -> (c -> b -> c) -> c -> a -> c
= fun op f' -> match op with
| Map f -> (fun z x -> f' z (f x))
| Filter p -> (fun z x -> if p x then f' z x else z)
| FlatMap f -> (fun z x -> C.fold f' z (f x))
| FilterMap f -> (fun z x -> match f x with Some x' -> f' z x' | None -> z)
| Id -> f'
let rec apply_optimized_with_fold : type a b c. (a,b) optimized_op -> (c -> b -> c) -> c -> a t -> c
= fun op fold z a -> match op with
| Base f -> C.fold (fusion_fold f fold) z a
| FlatMapPlus (f,c) -> apply_optimized_with_fold c fold z @@ C.flat_map f a
(* optimize and run *)
let apply op a =
let op' = optimize op in
apply_optimized op' a
let apply_fold op fold z a =
let op' = optimize op in
apply_optimized_with_fold op' fold z a
let apply' a op = apply op a let apply' a op = apply op a
(** {6 Combinators} *) (** {6 Combinators} *)
let id = Id let id = Nil
let map f = Compose (Map f, Id) let map f = Compose (Map f, Nil)
let filter p = Compose (Filter p, Id) let filter p = Compose (Filter p, Nil)
let filter_map f = Compose (FilterMap f, Id) let filter_map f = Compose (FilterMap f, Nil)
let flat_map f = Compose (FlatMap f, Id) let flat_map f = Compose (FlatMap f, Nil)
let compose f g = _compose g f let compose f g = _compose g f
let (>>>) f g = _compose f g let (>>>) f g = _compose f g
end end

14
core/CCBatch.mli
View file

@ -51,17 +51,11 @@ module type S = sig
val length : (_,_) op -> int val length : (_,_) op -> int
(** Number of intermediate structures needed to compute this operation *) (** Number of intermediate structures needed to compute this operation *)
type optimization_level = val apply : ('a,'b) op -> 'a t -> 'b t
| OptimNone (** Apply the operation to the collection. *)
| OptimBase
| OptimMergeFlatMap
val optimize : ?level:optimization_level -> ('a,'b) op -> ('a,'b) op val apply_width_fold : ('a, 'b) op -> ('c -> 'b -> 'c) -> 'c -> 'a t -> 'c
(** Try to minimize the length of the operation *) (** Apply the operation plus a fold to the collection. *)
val apply : ?level:optimization_level -> ('a,'b) op -> 'a t -> 'b t
(** Apply the operation to the collection.
@param level the optimization level, default is [OptimBase] *)
val apply' : 'a t -> ('a,'b) op -> 'b t val apply' : 'a t -> ('a,'b) op -> 'b t
(** Flip of {!apply} *) (** Flip of {!apply} *)