diff --git a/src/printf.ml b/src/printf.ml index 835f1ce..2f33e66 100644 --- a/src/printf.ml +++ b/src/printf.ml @@ -3,5 +3,10 @@ include Stdlib.Printf (** failwith, invalid_arg, and exit accepting printf's format. *) -let[@inline never] failwithf fmt = ksprintf (fun s () -> failwith s) fmt -let[@inline never] invalid_argf fmt = ksprintf (fun s () -> invalid_arg s) fmt +let[@inline never] [@zero_alloc assume never_returns_normally] failwithf fmt = + ksprintf (fun s () -> failwith s) fmt +;; + +let[@inline never] [@zero_alloc assume never_returns_normally] invalid_argf fmt = + ksprintf (fun s () -> invalid_arg s) fmt +;; diff --git a/src/printf.mli b/src/printf.mli index 27601fe..8193030 100644 --- a/src/printf.mli +++ b/src/printf.mli @@ -128,8 +128,12 @@ val kbprintf in a useful way) so they serve as an effective signpost for "end of formatting arguments". *) -(** Raises [Failure]. *) +(** Raises [Failure]. + + *) val failwithf : ('r, unit, string, unit -> _) format4 -> 'r -(** Raises [Invalid_arg]. *) +(** Raises [Invalid_arg]. + + *) val invalid_argf : ('r, unit, string, unit -> _) format4 -> 'r diff --git a/src/sequence.ml b/src/sequence.ml index 8c8a28d..572abaa 100644 --- a/src/sequence.ml +++ b/src/sequence.ml @@ -162,17 +162,13 @@ let fold t ~init ~f = let to_list_rev t = fold t ~init:[] ~f:(fun l x -> x :: l) let to_list (Sequence { state = s; next }) = - let safe_to_list t = List.rev (to_list_rev t) in - let rec to_list s next i = - if i = 0 - then safe_to_list (Sequence { state = s; next }) - else ( - match next s with - | Done -> [] - | Skip { state = s } -> to_list s next i - | Yield { value = a; state = s } -> a :: to_list s next (i - 1)) + let[@tail_mod_cons] rec to_list s next = + match next s with + | Done -> [] + | Skip { state = s } -> (to_list [@tailcall]) s next + | Yield { value = a; state = s } -> a :: (to_list [@tailcall]) s next in - to_list s next 500 + to_list s next ;; let sexp_of_t sexp_of_a t = sexp_of_list sexp_of_a (to_list t) diff --git a/test/allocation/test_zero_alloc.ml b/test/allocation/test_zero_alloc.ml new file mode 100644 index 0000000..7e65bd1 --- /dev/null +++ b/test/allocation/test_zero_alloc.ml @@ -0,0 +1,22 @@ +[@@@zero_alloc check] + +let[@zero_alloc] foo x = Base.Printf.failwithf "%d" x () +let[@zero_alloc] bar x y = Base.Printf.invalid_argf "%d" (x + y) () + +let%expect_test "foo" = + let x = Sys.opaque_identity 5 in + (try foo x with + | Failure s -> + print_string s; + print_newline ()); + [%expect {| 5 |}] +;; + +let%expect_test "bar" = + let x = Sys.opaque_identity 5 in + (try bar x x with + | Invalid_argument s -> + print_string s; + print_newline ()); + [%expect {| 10 |}] +;; diff --git a/test/allocation/test_zero_alloc.mli b/test/allocation/test_zero_alloc.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/allocation/test_zero_alloc.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *)