Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

[RFC] a completely encapsulated interface for unsafe batList accumulators #529

Open
wants to merge 4 commits into from

2 participants

@gasche
Owner

encapsulate unsafe list-accumulators in an abstract module

This patch is still incomplete, in particular it lacks tests for most
of the functions changed, but it demonstrates the possibility to
capture all the accumulator usage under a common abstraction. I think
the code is provably safe (equivalent to another imperative implementation
with (type 'a mut_list = 'a list ref) and no Obj.magic at all).

The only function that gave me trouble is 'transpose', as it creates
an unbounded number of intermediate accumulators. The resulting
implementation, using continuation-passing to not break
tail-recursivity, is admittedly much less readable than the previous
one. Is it a fair cost to pay for safety by encapsulation?

This patch is not proposed for inclusion (it fails the testing requirement) but for discussion in relation to #527.

@UnixJunkie
Collaborator

How does it compare in terms of performance to the current trick used in BatList?
Some code is significantly shorter using your proposal, which is nice.

This was referenced
Gabriel Scherer added some commits
Gabriel Scherer encapsulate unsafe list-accumulators in an abstract module
This patch is still incomplete, in particular it lacks tests for most
of the functions changed, but it demonstrates the possibility to
capture all the accumulator usage under a common abstraction. The code
is provably safe (equivalent to another imperative implementation with
(type 'a mut_list = 'a list ref) and no Obj.magic at all).

The only function that gave me trouble is 'transpose', as it creates
an unbounded number of intermediate accumulators. The resulting
implementation, using continuation-passing to not break
tail-recursivity, is admittedly much less readable than the previous
one. Is it a fair cost to pay for safety by encapsulation?
75eab57
Gabriel Scherer Acc: specialize 'run' and 'result' to improve performances on short-l…
…ist processing
aeaf8e6
Gabriel Scherer BatList: a safe version of the Acc module, as a proof of soundness
I checked that using SafeAcc insteaf of Acc makes the unit-test
pass. If we assume this means they are observationally equivalent
(which is a long shot given the poor test coverage in batList.ml),
this proves soundness of the unsafe implementation -- note that some
mutability-informed compiler optimizations may still break this.
4766293
@gasche
Owner

I made experiments with the following benchmark:

let usage () =
  prerr_endline
    "./list_bench.native (partition|transpose) (short|long) coeff?"

let bench_partition ~len ~n_iter =
  let li = BatList.init len (fun i -> i) in
  for i = 1 to n_iter do
    ignore (BatList.partition (fun n -> n mod 2 = 0) li)
  done

let bench_transpose ~lenin ~lenout ~n_iter =
  let row = BatList.init lenin (fun i -> i) in
  let li = BatList.make lenout row in
  for i = 1 to n_iter do
    ignore (BatList.transpose li)
  done

let () =
  if Array.length Sys.argv < 3 then (usage (); exit 1)
  else
    let coeff =
      if Array.length Sys.argv = 3 then 1.
      else try float_of_string Sys.argv.(3)
           with _ -> (usage (); exit 1) in
    let weight n = int_of_float (float_of_int n *. coeff) in
    match Sys.argv.(1), Sys.argv.(2) with
    | "partition", "short" ->
      bench_partition ~len:4 ~n_iter:(weight 100_000_000)
    | "partition", "long" ->
      bench_partition ~len:2_000_000 ~n_iter:(weight 40)
    | "transpose", "short" ->
      bench_transpose ~lenin:2 ~lenout:2 ~n_iter:(weight 40_000_000)
    | "transpose", "long" ->
      bench_transpose ~lenin:500_000 ~lenout:10 ~n_iter:(weight 5);
      bench_transpose ~lenin:10 ~lenout:500_000 ~n_iter:(weight 5);
      bench_transpose ~lenin:2000 ~lenout:2000 ~n_iter:(weight 5);
    | _, _ -> usage (); exit 1

The expectation is that the new interface adds an overhead (due to the
additional closures and stuff) that is felt on short lists, but
neglectible on large lists.

transpose is a "reasonable worst-case" for the new accumulator
interface: it has two accumulators and therefore pays the
constant-time overhead twice. We can assume that other list functions
would see at most the same level of overhead. Except transpose,
which is an outlier, expected to be much slower with the new interface
on short lists -- but is the only function in this situation.

The results are as follow, all from my 32bits machine.

On the abstract-accum branch:

partition short 21.92s user 0.01s system 99% cpu 21.982 total

partition long 14.69s user 0.09s system 99% cpu 14.806 total

transpose short 20.14s user 0.00s system 99% cpu 20.293 total

transpose long 24.52s user 0.35s system 99% cpu 24.834 total

Still on abstract-accum, after specializing 'run' and 'result' to
avoid one (constant) indirection:

partition short 18.12s user 0.05s system 99% cpu 18.228 tota

partition long 15.14s user 0.12s system 98% cpu 15.435 total

transpose short 18.60s user 0.03s system 99% cpu 18.658 total

transpose long 18.96s user 0.20s system 99% cpu 19.221 total

transpose long 24.39s user 0.35s system 99% cpu 24.792 total

On master:

partition short 15.64s user 0.00s system 99% cpu 15.674 to

partition long 15.08s user 0.09s system 99% cpu 15.250 tot

transpose short 4.77s user 0.00s system 99% cpu 4.784 tota

Fatal error: exception Stack_overflow

transpose long 0.45s user 0.05s system 98% cpu 0.501 total

After fixing the Stack_overflow bug in transpose:

transpose short 6.32s user 0.01s system 99% cpu 6.342 total
transpose long 22.88s user 0.26s system 99% cpu 23.181 total

Finally, a reference time for naive tail-rec implementations without
using any kind of mutable accumulators (impl below)

partition short 12.81s user 0.00s system 99% cpu 12.824 tota

partition long 34.84s user 0.18s system 99% cpu 35.088 total

transpose short 8.16s user 0.00s system 99% cpu 8.204 total

transpose long 35.45s user 0.34s system 99% cpu 35.886 total

let partition p lst =
  let rec loop yesacc noacc = function
    | [] -> List.rev yesacc, List.rev noacc
    | h :: t ->
      if p h
      then loop (h::yesacc) noacc t
      else loop yesacc (h::noacc) t
 in loop [] [] lst

let transpose = function
  | [] -> []
  | heads::lli ->
    let rec loop acc = function
      | [] -> map rev acc
      | li::lli -> loop (map2 cons li acc) lli in
    loop (map singleton heads) lli

The conclusions are that the costs are important on short lists, and
indeed neglectible on large lists (transpose long still sees some
overhead, which comes from the part of the testing with a small outer
list, and only a large inner list). It is interesting to note that in
the partition case accumulator-style with dummies already pays
a non-neglectible cost on short lists, when compared to naive
direct-style version.

The question is: which price are we ready to pay for increased
interface safety? I would suggest to keep the functions as they are
for now, and revisit the conversation if/when better optimization in
the OCaml compiler decrease the cost of closures when inlining kicks
in. I would guess that this would make the two versions using
accumulators comparable.

@UnixJunkie
Collaborator

I agree with your conclusion (keep the functions as they are
for now).

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Feb 3, 2014
  1. fix minor warning in Enum test

    Gabriel Scherer authored
Commits on Feb 4, 2014
  1. encapsulate unsafe list-accumulators in an abstract module

    Gabriel Scherer authored
    This patch is still incomplete, in particular it lacks tests for most
    of the functions changed, but it demonstrates the possibility to
    capture all the accumulator usage under a common abstraction. The code
    is provably safe (equivalent to another imperative implementation with
    (type 'a mut_list = 'a list ref) and no Obj.magic at all).
    
    The only function that gave me trouble is 'transpose', as it creates
    an unbounded number of intermediate accumulators. The resulting
    implementation, using continuation-passing to not break
    tail-recursivity, is admittedly much less readable than the previous
    one. Is it a fair cost to pay for safety by encapsulation?
  2. Acc: specialize 'run' and 'result' to improve performances on short-l…

    Gabriel Scherer authored
    …ist processing
  3. BatList: a safe version of the Acc module, as a proof of soundness

    Gabriel Scherer authored
    I checked that using SafeAcc insteaf of Acc makes the unit-test
    pass. If we assume this means they are observationally equivalent
    (which is a long shot given the poor test coverage in batList.ml),
    this proves soundness of the unsafe implementation -- note that some
    mutability-informed compiler optimizations may still break this.
This page is out of date. Refresh to see the latest.
Showing with 208 additions and 182 deletions.
  1. +3 −3 Makefile
  2. +1 −1  src/batEnum.ml
  3. +204 −178 src/batList.ml
View
6 Makefile
@@ -13,7 +13,7 @@ export DOCROOT
BROWSER_COMMAND ?= x-www-browser
export BROWSER_COMMAND
-OCAMLBUILD ?= ocamlbuild
+OCAMLBUILD ?= ocamlbuild -use-ocamlfind
OCAMLBUILDFLAGS ?= -no-links
ifeq ($(uname_S),Darwin)
@@ -193,9 +193,9 @@ test-native: prefilter _build/testsuite/main.native _build/$(QTESTDIR)/all_tests
full-test: $(TEST_TARGET)
test-compat: prefilter src/batteries_compattest.ml
- ocamlbuild src/batteries_compattest.byte -no-links
+ ocamlbuild -use-ocamlfind src/batteries_compattest.byte -no-links
-test: test-byte test-compat
+test: test-native test-compat
###############################################################################
# BENCHMARK SUITE
View
2  src/batEnum.ml
@@ -516,7 +516,7 @@ let find f t =
(*$T
find ((=) 5) (1 -- 10) = 5
- try find ((=) 11) (1 -- 10) = 5; false with Not_found -> true
+ try ignore (find ((=) 11) (1 -- 10) = 5); false with Not_found -> true
*)
let find_map f t =
View
382 src/batList.ml
@@ -47,27 +47,95 @@ let mem_assoc = List.mem_assoc
let rev_map2 = List.rev_map2
(* ::VH:: END GLUE *)
-(* Thanks to Jacques Garrigue for suggesting the following structure *)
-type 'a mut_list = {
- hd: 'a;
- mutable tl: 'a list
-}
-
type 'a t = 'a list
type 'a enumerable = 'a t
type 'a mappable = 'a t
-external inj : 'a mut_list -> 'a list = "%identity"
+(* A signature that lets us write list-producing function in
+ tail-recursive, destination-passing style *)
+module type MUTABLE_ACCUMULATOR = sig
+ type 'a mut_list
+
+ (* in [run], [result] and [cont],
+ the ('a mut_list) argument must not escape the callback *)
+ val run : ('a mut_list -> unit) -> 'a list
+ val result : ('a mut_list -> 'b) -> 'a list * 'b
+
+ (* adds an element and returns the tail of the list*)
+ val accum : 'a mut_list -> 'a -> 'a mut_list
+
+ (* adds a full list but doesn't return anything;
+ the ['a mut_list] argument must not be used again after this *)
+ val set_tail : 'a mut_list -> 'a list -> unit
+
+ (* continuation-passing-style generalization of [run] and [result],
+ useful if you need to create a fresh list accumulator in each
+ call of a recursive function, preserving tail-calls.
+
+ The continuation argument of type [('a list -> 'b)] must be
+ called exactly once by the user; no less, no more. *)
+ val cont : ('a mut_list -> (('a list -> 'b) -> 'b) -> 'c) -> 'c
+end
+
+(* a safe implementation of mutable accumulators *)
+module SafeAcc : MUTABLE_ACCUMULATOR = struct
+ type 'a mut_list = { mutable rev : 'a list;
+ mutable tail : 'a list }
+ let accum li x = li.rev <- x::li.rev; li
+ let set_tail li tail =
+ if li.tail <> [] then invalid_arg "Acc.set_tail";
+ li.tail <- tail
+
+ let cont f =
+ let dummy = { rev = []; tail = [] } in
+ f dummy (fun consumer ->
+ let li = List.rev_append dummy.rev dummy.tail in
+ consumer li)
+
+ let result f =
+ cont (fun dst return ->
+ let res = f dst in
+ return (fun li -> li, res))
+
+ let run f =
+ cont (fun dst return ->
+ f dst;
+ return (fun li -> li))
+end
+
+(* a fast implementation of mutable accumulators *)
+module Acc : MUTABLE_ACCUMULATOR = struct
+ (* Thanks to Jacques Garrigue for suggesting the following structure *)
+ type 'a mut_list = {
+ hd: 'a;
+ mutable tl: 'a list
+ }
+ external inj : 'a mut_list -> 'a list = "%identity"
+
+ type 'b return = 'b
+ let cont f =
+ let dummy = { hd = Obj.magic (); tl = [] } in
+ f dummy (fun consumer -> consumer dummy.tl)
+
+ (* specialize [run] and [result] for efficiency, instead of
+ reusing [cont] as in SafeAcc *)
+ let run f =
+ let dummy = { hd = Obj.magic (); tl = [] } in
+ f dummy;
+ dummy.tl
+
+ let result f =
+ let dummy = { hd = Obj.magic (); tl = [] } in
+ let res = f dummy in
+ dummy.tl, res
-module Acc = struct
- let dummy () =
- { hd = Obj.magic (); tl = [] }
- let create x =
- { hd = x; tl = [] }
let accum acc x =
- let cell = create x in
+ let cell = { hd = x; tl = [] } in
acc.tl <- inj cell;
cell
+
+ let set_tail acc li =
+ acc.tl <- li
end
let cons h t = h::t
@@ -109,18 +177,20 @@ let mem_cmp cmp x l =
*)
let append l1 l2 =
- match l1 with
- | [] -> l2
- | h :: t ->
- let rec loop dst = function
- | [] ->
- dst.tl <- l2
- | h :: t ->
- loop (Acc.accum dst h) t
- in
- let r = Acc.create h in
- loop r t;
- inj r
+ let rec loop dst = function
+ | [] ->
+ Acc.set_tail dst l2
+ | h :: t ->
+ loop (Acc.accum dst h) t
+ in
+ Acc.run (fun dst -> loop dst l1)
+
+(*$T append
+ append [] [] = []
+ append [1; 2] [] = [1; 2]
+ append [] [3; 4] = [3; 4]
+ append [1; 2] [3; 4] = [1; 2; 3; 4]
+*)
let flatten l =
let rec inner dst = function
@@ -132,9 +202,7 @@ let flatten l =
| [] -> ()
| h :: t -> outer (inner dst h) t
in
- let r = Acc.dummy () in
- outer r l;
- r.tl
+ Acc.run (fun dst -> outer dst l)
let concat = flatten
@@ -148,17 +216,13 @@ let singleton x = [x]
Q.int (fun x -> let s = singleton x in hd s = x && length s = 1)
*)
-let map f = function
- | [] -> []
- | h :: t ->
- let rec loop dst = function
- | [] -> ()
- | h :: t ->
- loop (Acc.accum dst (f h)) t
- in
- let r = Acc.create (f h) in
- loop r t;
- inj r
+let map f li =
+ let rec loop dst = function
+ | [] -> ()
+ | h :: t ->
+ loop (Acc.accum dst (f h)) t
+ in
+ Acc.run (fun dst -> loop dst li)
(*$Q map
(Q.pair (Q.fun1 Q.int Q.int) (Q.list Q.small_int)) \
(fun (f,l) -> map f l = List.map f l)
@@ -182,9 +246,7 @@ let take n l =
| _ ->
()
in
- let dummy = Acc.dummy () in
- loop n dummy l;
- dummy.tl
+ Acc.run (fun dst -> loop n dst l)
(*$= take & ~printer:(IO.to_string (List.print Int.print))
(take 0 [1;2;3]) []
@@ -198,9 +260,7 @@ let takedrop n l =
| h :: t when n > 0 -> loop (n - 1) (Acc.accum dst h) t
| rest -> rest
in
- let dummy = Acc.dummy () in
- let rest = loop n dummy l in
- (dummy.tl, rest)
+ Acc.result (fun dst -> loop n dst l)
(*$T takedrop
takedrop 0 [1; 2; 3] = ([], [1; 2; 3])
@@ -211,14 +271,15 @@ let takedrop n l =
let ntake n l =
if n < 1 then invalid_arg "BatList.ntake";
- let took, left = takedrop n l in
- let acc = Acc.create took in
- let rec loop dst = function
- | [] -> inj acc
- | li -> let taken, rest = takedrop n li in
- loop (Acc.accum dst taken) rest
- in
- loop acc left
+ match l with
+ | [] -> [[]] (* TODO discuss whether returning [] would also respect the spec. *)
+ | _ ->
+ let rec loop dst = function
+ | [] -> ()
+ | li -> let taken, rest = takedrop n li in
+ loop (Acc.accum dst taken) rest
+ in
+ Acc.run (fun dst -> loop dst l)
(*$T ntake
ntake 2 [] = [[]]
@@ -234,9 +295,7 @@ let take_while p li =
| x :: xs ->
if p x then
loop (Acc.accum dst x) xs in
- let dummy = Acc.dummy () in
- loop dummy li;
- dummy.tl
+ Acc.run (fun dst -> loop dst li)
(*$= take_while & ~printer:(IO.to_string (List.print Int.print))
(take_while ((=) 3) [3;3;4;3;3]) [3;3]
@@ -264,9 +323,7 @@ let span p li =
loop (Acc.accum dst x) xs
else l
in
- let dummy = Acc.dummy () in
- let xs = loop dummy li in
- (dummy.tl , xs)
+ Acc.result (fun dst -> loop dst li)
(*$= span
(span ((=) 3) [3;3;4;3;3]) ([3;3],[4;3;3])
@@ -298,9 +355,7 @@ let nsplit p = function
| [] -> ()
| x :: xs -> loop r xs
in
- let dummy = Acc.dummy () in
- loop dummy li;
- dummy.tl
+ Acc.run (fun dst -> loop dst li)
(*$T nsplit
nsplit ((=) 0) [] = []
@@ -334,9 +389,7 @@ let group_consecutive p l =
let xs, rest = span (p x) rest in
loop (Acc.accum dst (x :: xs)) rest
in
- let dummy = Acc.dummy () in
- loop dummy l;
- dummy.tl
+ Acc.run (fun dst -> loop dst l)
(*$= group_consecutive & ~printer:(IO.to_string (List.print (List.print Int.print)))
(group_consecutive (=) [3; 3; 4; 3; 3]) [[3; 3]; [4]; [3; 3]]
@@ -391,9 +444,7 @@ let unique ?(eq = ( = )) l =
| false ->
loop (Acc.accum dst h) t
in
- let dummy = Acc.dummy () in
- loop dummy l;
- dummy.tl
+ Acc.run (fun dst -> loop dst l)
(* FIXME BAD TESTS: RESULT IS SPECIFIC TO IMPLEMENTATION *)
(*$= unique & ~printer:(IO.to_string (List.print Int.print))
@@ -431,9 +482,7 @@ let unique_hash (type et) ?(hash = Hashtbl.hash) ?(eq = (=)) (l : et list) =
loop dst t
| [] -> ()
in
- let dummy = Acc.dummy () in
- loop dummy l;
- dummy.tl
+ Acc.run (fun dst -> loop dst l)
(*$= unique_hash & ~printer:(IO.to_string (List.print Int.print))
[1;2;3;4;5;6] (unique_hash [1;1;2;2;3;3;4;5;6;4;5;6])
@@ -450,9 +499,7 @@ let filter_map f l =
| Some x ->
loop (Acc.accum dst x) t
in
- let dummy = Acc.dummy () in
- loop dummy l;
- dummy.tl
+ Acc.run (fun dst -> loop dst l)
let filteri_map f l =
let rec loop i dst = function
@@ -463,9 +510,7 @@ let filteri_map f l =
| Some x ->
loop (succ i) (Acc.accum dst x) t
in
- let dummy = Acc.dummy () in
- loop 0 dummy l;
- dummy.tl
+ Acc.run (fun dst -> loop 0 dst l)
(*$T filteri_map
(let r = ref (-1) in filteri_map (fun i _ -> incr r; if i = !r then Some i else None) [5; 4; 8] = [0; 1; 2])
filteri_map (fun _ x -> if x > 4 then Some (x, string_of_int x) else None) [5; 4; 8] = [(5, "5"); (8, "8")]
@@ -505,9 +550,7 @@ let map2 f l1 l2 =
loop (Acc.accum dst (f h1 h2)) t1 t2
| _ -> invalid_arg "map2: Different_list_size"
in
- let dummy = Acc.dummy () in
- loop dummy l1 l2;
- dummy.tl
+ Acc.run (fun dst -> loop dst l1 l2)
let rec iter2 f l1 l2 =
match l1, l2 with
@@ -563,26 +606,22 @@ let remove_assoc x lst =
| [] -> ()
| (a, _ as pair) :: t ->
if a = x then
- dst.tl <- t
+ Acc.set_tail dst t
else
loop (Acc.accum dst pair) t
in
- let dummy = Acc.dummy () in
- loop dummy lst;
- dummy.tl
+ Acc.run (fun dst -> loop dst lst)
let remove_assq x lst =
let rec loop dst = function
| [] -> ()
| (a, _ as pair) :: t ->
if a == x then
- dst.tl <- t
+ Acc.set_tail dst t
else
loop (Acc.accum dst pair) t
in
- let dummy = Acc.dummy () in
- loop dummy lst;
- dummy.tl
+ Acc.run (fun dst -> loop dst lst)
let rfind p l = find p (rev l)
@@ -595,9 +634,7 @@ let find_all p l =
else
findnext dst t
in
- let dummy = Acc.dummy () in
- findnext dummy l;
- dummy.tl
+ Acc.run (fun dst -> findnext dst l)
let rec findi p l =
let rec loop n = function
@@ -659,11 +696,11 @@ let partition p lst =
else
loop yesdst (Acc.accum nodst h) t
in
- let yesdummy = Acc.dummy ()
- and nodummy = Acc.dummy ()
- in
- loop yesdummy nodummy lst;
- (yesdummy.tl, nodummy.tl)
+ (* the outer 'result' will return the list produced by the inner
+ 'run' as second element of the tuple *)
+ Acc.result (fun yesdst ->
+ Acc.run (fun nodst ->
+ loop yesdst nodst lst))
let split lst =
let rec loop adst bdst = function
@@ -671,25 +708,19 @@ let split lst =
| (a, b) :: t ->
loop (Acc.accum adst a) (Acc.accum bdst b) t
in
- let adummy = Acc.dummy ()
- and bdummy = Acc.dummy ()
- in
- loop adummy bdummy lst;
- adummy.tl, bdummy.tl
+ (* the outer 'result' will return the list produced by the inner
+ 'run' as second element of the tuple *)
+ Acc.result (fun adst ->
+ Acc.run (fun bdst ->
+ loop adst bdst lst))
let combine l1 l2 =
- let list_sizes_differ = Invalid_argument "combine: Different_list_size" in
- match l1, l2 with
- | [], [] -> []
- | x :: xs, y :: ys ->
- let acc = Acc.create (x, y) in
- let rec loop dst l1 l2 = match l1, l2 with
- | [], [] -> inj acc
- | h1 :: t1, h2 :: t2 -> loop (Acc.accum dst (h1, h2)) t1 t2
- | _, _ -> raise list_sizes_differ
- in loop acc xs ys
- | _, _ -> raise list_sizes_differ
-
+ let rec loop dst l1 l2 = match l1, l2 with
+ | [], [] -> ()
+ | h1 :: t1, h2 :: t2 -> loop (Acc.accum dst (h1, h2)) t1 t2
+ | _, _ -> invalid_arg "combine: Different_list_size"
+ in
+ Acc.run (fun dst -> loop dst l1 l2)
(*$T combine
combine [] [] = []
combine [1] [2] = [(1, 2)]
@@ -697,25 +728,19 @@ let combine l1 l2 =
*)
let init size f =
- if size = 0 then []
- else if size < 0 then invalid_arg "BatList.init"
+ if size < 0 then invalid_arg "BatList.init"
else
let rec loop dst n =
if n < size then
loop (Acc.accum dst (f n)) (n+1)
in
- let r = Acc.create (f 0) in
- loop r 1;
- inj r
+ Acc.run (fun dst -> loop dst 0)
let unfold_exc f =
let rec loop dst =
loop (Acc.accum dst (f ()))
in
- let acc = Acc.dummy () in
- try
- loop acc
- with exn -> (acc.tl, exn)
+ Acc.result (fun dst -> try loop dst with exn -> exn)
(*$T unfold_exc
let exc () = raise End_of_file in \
@@ -764,17 +789,13 @@ let range i dir j =
try ignore(range 1 `Downto 2); true with Invalid_argument _ -> true
*)
-let mapi f = function
- | [] -> []
- | h :: t ->
- let rec loop dst n = function
- | [] -> ()
- | h :: t ->
- loop (Acc.accum dst (f n h)) (n + 1) t
- in
- let r = Acc.create (f 0 h) in
- loop r 1 t;
- inj r
+let mapi f li =
+ let rec loop dst n = function
+ | [] -> ()
+ | h :: t ->
+ loop (Acc.accum dst (f n h)) (n + 1) t
+ in
+ Acc.run (fun dst -> loop dst 0 li)
let iteri f l =
let rec loop n = function
@@ -792,21 +813,17 @@ let rec last = function
| h :: [] -> h
| _ :: t -> last t
-let split_nth index = function
- | [] -> if index = 0 then [],[] else invalid_arg "Index past end of list"
- | (h :: t as l) ->
- if index = 0 then [],l
- else if index < 0 then invalid_arg "Negative index not allowed"
- else
- let rec loop n dst l =
- if n = 0 then l else
- match l with
- | [] -> invalid_arg "Index past end of list"
- | h :: t ->
- loop (n - 1) (Acc.accum dst h) t
- in
- let r = Acc.create h in
- inj r, loop (index-1) r t
+let split_nth index li =
+ if index < 0 then invalid_arg "Negative index not allowed"
+ else
+ let rec loop n dst l =
+ if n = 0 then l else
+ match l with
+ | [] -> invalid_arg "Index past end of list"
+ | h :: t ->
+ loop (n - 1) (Acc.accum dst h) t
+ in
+ Acc.result (fun dst -> loop index dst li)
let split_at = split_nth
@@ -821,26 +838,22 @@ let remove l x =
| [] -> ()
| h :: t ->
if x = h then
- dst.tl <- t
+ Acc.set_tail dst t
else
loop (Acc.accum dst h) t
in
- let dummy = Acc.dummy () in
- loop dummy l;
- dummy.tl
+ Acc.run (fun dst -> loop dst l)
let remove_if f lst =
let rec loop dst = function
| [] -> ()
| x :: l ->
if f x then
- dst.tl <- l
+ Acc.set_tail dst l
else
loop (Acc.accum dst x) l
in
- let dummy = Acc.dummy () in
- loop dummy lst;
- dummy.tl
+ Acc.run (fun dst -> loop dst lst)
let remove_all l x =
let rec loop dst = function
@@ -851,28 +864,46 @@ let remove_all l x =
else
loop (Acc.accum dst h) t
in
- let dummy = Acc.dummy () in
- loop dummy l;
- dummy.tl
+ Acc.run (fun dst -> loop dst l)
let transpose = function
| [] -> []
- | [x] -> List.map (fun x -> [x]) x
- | x::xs ->
- let heads = List.map Acc.create x in
- ignore ( List.fold_left
- (fun acc x ->
- List.map2
- (fun x xs -> Acc.accum xs x)
- x acc)
- heads xs);
- Obj.magic heads (* equivalent to List.map inj heads, but without creating a new list *)
-
+ | heads::lli ->
+ Acc.cont (fun dsts get_dsts ->
+ Acc.cont (fun returns get_returns ->
+ let rec runs dsts returns = function
+ | x::xs ->
+ Acc.cont (fun dst_x return ->
+ let dsts = Acc.accum dsts (Acc.accum dst_x x) in
+ let returns = Acc.accum returns return in
+ runs dsts returns xs)
+ | [] ->
+ get_dsts (fun dsts ->
+ let accum_li dsts li = map2 Acc.accum dsts li in
+ ignore (fold_left accum_li dsts lli);
+ get_returns (fun returns ->
+ map (fun return -> return (fun li -> li)) returns
+ ))
+ in runs dsts returns heads))
(*$T transpose
+ transpose [ [1; 2; 3] ] = [[1]; [2]; [3]]
+ transpose [ [1; 2; 3]; [4; 5; 6;] ] = [[1;4];[2;5];[3;6]]
transpose [ [1; 2; 3;]; [4; 5; 6;]; [7; 8; 9;] ] = [[1;4;7];[2;5;8];[3;6;9]]
transpose [] = []
transpose [ [1] ] = [ [1] ]
+ transpose [ [1]; [2] ] = [ [1; 2] ]
+ transpose [ [1]; [2]; [3] ] = [ [1; 2; 3] ]
+
+ try ignore (transpose [ [1; 2]; [3] ]); false with _ -> true \
+ (* TODO specify the exception *)
+
+ let long = init 1_000_000 (fun i -> i) in (transpose [long] |> flatten) = long \
+ (* test that we are tail-recursive in the inner list *)
+
+ let long = init 1_000_000 (fun i -> [i]) in transpose long = [long |> flatten] \
+ (* test that we are tail-recursive in the outer list *)
+
*)
let enum l =
@@ -897,11 +928,7 @@ let enum l =
make (ref l) (ref (-1))
let of_enum e =
- let h = Acc.dummy () in
- let _ = BatEnum.fold Acc.accum h e in
- h.tl
-
-
+ Acc.run (fun dst -> ignore (BatEnum.fold Acc.accum dst e))
let backwards l = enum (rev l) (*TODO: should we make it more efficient?*)
(*let backwards l = (*This version only needs one pass but is actually less lazy*)
@@ -1130,12 +1157,11 @@ let min_max ?cmp:(cmp = Pervasives.compare) = function
*)
let unfold b f =
- let acc = Acc.dummy () in
let rec loop dst v =
match f v with
- | None -> acc.tl
+ | None -> ()
| Some (a, v) -> loop (Acc.accum dst a) v
- in loop acc b
+ in Acc.run (fun dst -> loop dst b)
(*$T unfold
unfold 1 (fun x -> None) = []
Something went wrong with that request. Please try again.