A possible static and exportable reverse binding of decompress

bench/dune

@@ -6,12 +6,20 @@
   (names mclock bs))
  (preprocess
   (pps ppx_deriving_yojson))
- (libraries unix fmt decompress.zl cmdliner yojson ppx_deriving_yojson))
+ (libraries
+  bigarray-compat
+  unix
+  fmt
+  decompress.de
+  decompress.zl
+  cmdliner
+  yojson
+  ppx_deriving_yojson))
 
 (executable
  (name run)
  (modules run)
- (libraries cmdliner rresult bos))
+ (libraries cmdliner fpath rresult bos))
 
 (rule
  (targets zpipe)
@@ -35,7 +43,7 @@
  (name lz_landmarks)
  (optional)
  (modules lz_landmarks)
- (libraries landmarks de)
+ (libraries bigarray-compat checkseum optint landmarks de)
  (preprocess
   (pps landmarks.ppx --auto)))
 
@@ -48,4 +56,4 @@
 (executable
  (name lzld)
  (modules lzld)
- (libraries lz_landmarks))
+ (libraries decompress.de lz_landmarks))

bin/dune

@@ -1,10 +1,12 @@
 (executable
  (name pipe)
  (modules pipe)
- (libraries checkseum.c bigstringaf fmt rresult mtime mtime.clock.os
-   decompress.de decompress.zl decompress.gz cmdliner))
-
-(executable
- (name lz)
- (modules lz)
- (libraries checkseum.c decompress.lz))
+ (package decompress)
+ (public_name decompress.pipe)
+ (libraries
+  checkseum.c
+  unix
+  decompress.de
+  decompress.zl
+  decompress.gz
+  cmdliner))

bin/pipe.ml

@@ -3,16 +3,23 @@ let l = De.Lz77.make_window ~bits:15
 let o = De.bigstring_create De.io_buffer_size
 let i = De.bigstring_create De.io_buffer_size
 let q = De.Queue.create 4096
+let str fmt = Format.asprintf fmt
+let error_msgf fmt = Format.kasprintf (fun err -> Error (`Msg err)) fmt
 
 let bigstring_input ic buf off len =
   let tmp = Bytes.create len in
   let len = input ic tmp 0 len in
-  Bigstringaf.blit_from_bytes tmp ~src_off:0 buf ~dst_off:off ~len
+  for i = 0 to len - 1 do
+    buf.{off + i} <- Bytes.get tmp i
+  done
   ; len
 
 let bigstring_output oc buf off len =
-  let tmp = Bigstringaf.substring buf ~off ~len in
-  output_string oc tmp
+  let res = Bytes.create len in
+  for i = 0 to len - 1 do
+    Bytes.set res i buf.{off + i}
+  done
+  ; output_string oc (Bytes.unsafe_to_string res)
 
 let run_inflate () =
   let open De in
@@ -27,11 +34,11 @@ let run_inflate () =
       bigstring_output stdout o 0 len
       ; Inf.flush decoder
       ; go ()
-    | `Malformed err -> Fmt.epr "%s\n%!" err ; `Error err
+    | `Malformed err -> `Error (false, str "%s." err)
     | `End ->
       let len = io_buffer_size - Inf.dst_rem decoder in
       if len > 0 then bigstring_output stdout o 0 len
-      ; `Ok () in
+      ; `Ok 0 in
   go ()
 
 let run_deflate () =
@@ -62,7 +69,7 @@ let run_deflate () =
     | `Ok | `Block -> compress () in
   Def.dst encoder o 0 io_buffer_size
   ; compress ()
-  ; `Ok ()
+  ; `Ok 0
 
 let run_zlib_inflate () =
   let open Zl in
@@ -78,13 +85,11 @@ let run_zlib_inflate () =
       let len = De.io_buffer_size - Inf.dst_rem decoder in
       bigstring_output stdout o 0 len
       ; Inf.flush decoder |> go
-    | `Malformed err ->
-      Fmt.epr "%si (remaining byte(s): %d)\n%!" err (Inf.dst_rem decoder)
-      ; `Error err
+    | `Malformed err -> `Error (false, str "%s." err)
     | `End decoder ->
       let len = De.io_buffer_size - Inf.dst_rem decoder in
       if len > 0 then bigstring_output stdout o 0 len
-      ; `Ok () in
+      ; `Ok 0 in
   go decoder
 
 let run_zlib_deflate () =
@@ -103,7 +108,7 @@ let run_zlib_deflate () =
     | `End encoder ->
       let len = De.io_buffer_size - Def.dst_rem encoder in
       if len > 0 then bigstring_output stdout o 0 len
-      ; `Ok () in
+      ; `Ok 0 in
   Def.dst encoder o 0 De.io_buffer_size |> go
 
 let run_gzip_inflate () =
@@ -119,19 +124,14 @@ let run_gzip_inflate () =
       let len = io_buffer_size - Inf.dst_rem decoder in
       bigstring_output stdout o 0 len
       ; Inf.flush decoder |> go
-    | `Malformed err ->
-      Fmt.epr "%s (remaining byte(s): %d)\n%!" err (Inf.dst_rem decoder)
-      ; `Error err
+    | `Malformed err -> `Error (false, str "%s." err)
     | `End decoder ->
       let len = io_buffer_size - Inf.dst_rem decoder in
       if len > 0 then bigstring_output stdout o 0 len
-      ; `Ok () in
+      ; `Ok 0 in
   go decoder
 
-(* XXX(dinosaure): UNSAFE! *)
-let now () =
-  let res = Mtime_clock.now () in
-  Int64.to_int32 (Mtime.to_uint64_ns res)
+let now () = Int32.of_float (Unix.gettimeofday ())
 
 let run_gzip_deflate () =
   let open Gz in
@@ -150,14 +150,17 @@ let run_gzip_deflate () =
     | `End encoder ->
       let len = io_buffer_size - Def.dst_rem encoder in
       if len > 0 then bigstring_output stdout o 0 len
-      ; `Ok () in
+      ; `Ok 0 in
   Def.dst encoder o 0 io_buffer_size |> go
 
 let run deflate format =
-  match format with
-  | `Deflate -> if deflate then run_deflate () else run_inflate ()
-  | `Zlib -> if deflate then run_zlib_deflate () else run_zlib_inflate ()
-  | `Gzip -> if deflate then run_gzip_deflate () else run_gzip_inflate ()
+  match deflate, format with
+  | true, `Deflate -> run_deflate ()
+  | false, `Deflate -> run_inflate ()
+  | true, `Zlib -> run_zlib_deflate ()
+  | false, `Zlib -> run_zlib_inflate ()
+  | true, `Gzip -> run_gzip_deflate ()
+  | false, `Gzip -> run_gzip_inflate ()
 
 open Cmdliner
 
@@ -171,11 +174,11 @@ let format =
     | "zlib" -> Ok `Zlib
     | "gzip" -> Ok `Gzip
     | "deflate" -> Ok `Deflate
-    | x -> Rresult.R.error_msgf "Invalid format: %S" x in
+    | x -> error_msgf "Invalid format: %S" x in
   let pp ppf = function
-    | `Zlib -> Fmt.pf ppf "zlib"
-    | `Gzip -> Fmt.pf ppf "gzip"
-    | `Deflate -> Fmt.pf ppf "deflate" in
+    | `Zlib -> Format.pp_print_string ppf "zlib"
+    | `Gzip -> Format.pp_print_string ppf "gzip"
+    | `Deflate -> Format.pp_print_string ppf "deflate" in
   let format = Arg.conv (parser, pp) in
   Arg.(value & opt format `Deflate & info ["f"; "format"])
 
@@ -184,11 +187,11 @@ let command =
   let exits = Term.default_exits in
   let man =
     [
-      `S "Description"
+      `S Manpage.s_description
     ; `P
         "$(tname) reads from standard input and writes the \
          compressed/decompressed data to standard output."
     ] in
-  Term.(pure run $ deflate $ format), Term.info "pipe" ~exits ~doc ~man
+  Term.(ret (const run $ deflate $ format)), Term.info "pipe" ~exits ~doc ~man
 
-let () = Term.(exit @@ eval command)
+let () = Term.(exit_status @@ eval command)

bindings/generator/dune

@@ -0,0 +1,3 @@
+(executable
+ (name generate)
+ (libraries ctypes.stubs gen_decompress_bindings))

bindings/generator/generate.ml

@@ -0,0 +1,33 @@
+let generate dirname =
+  let prefix = "decompress" in
+  let path basename = Filename.concat dirname basename in
+  let ml_fd = open_out (path "decompress_bindings.ml") in
+  let c_fd = open_out (path "gen_decompress.c") in
+  let h_fd = open_out (path "decompress.h") in
+  let stubs =
+    (module Gen_decompress_bindings.Stubs : Cstubs_inverted.BINDINGS) in
+
+  Cstubs_inverted.write_ml (Format.formatter_of_out_channel ml_fd) ~prefix stubs
+  ; Format.fprintf
+      (Format.formatter_of_out_channel c_fd)
+      "#include \"decompress.h\"@\n %a%!"
+      (Cstubs_inverted.write_c ~prefix)
+      stubs
+  ; Format.fprintf
+      (Format.formatter_of_out_channel h_fd)
+      "#if defined(__cplusplus)@\n\
+      \ extern \"C\" {@\n\
+      \ #endif@\n\
+      \ %a@\n\
+      \ #if defined(__cplusplus)@\n\
+      \ }@\n\
+      \ #endif@\n\
+       %!"
+      (Cstubs_inverted.write_c_header ~prefix)
+      stubs
+
+  ; close_out h_fd
+  ; close_out c_fd
+  ; close_out ml_fd
+
+let () = generate Sys.argv.(1)

bindings/stubs/apply_bindings.ml

@@ -0,0 +1 @@
+include Gen_decompress_bindings.Stubs (Decompress_bindings)

bindings/stubs/decompress.ml

@@ -0,0 +1 @@
+module Apply_bindings = Apply_bindings

bindings/stubs/dune

@@ -0,0 +1,31 @@
+(rule
+ (targets decompress_bindings.ml gen_decompress.c decompress.h)
+ (action
+  (run ../generator/generate.exe .)))
+
+(library
+ (name gen_decompress_bindings)
+ (modules gen_decompress_bindings)
+ (wrapped false)
+ (libraries bigarray-compat decompress.de decompress.zl ctypes.stubs))
+
+(executable
+ (name decompress)
+ (modules decompress apply_bindings decompress_bindings)
+ (forbidden_libraries unix)
+ (flags
+  (:standard -w -27))
+ (foreign_stubs
+  (language c)
+  (names init gen_decompress))
+ (ocamlopt_flags -ccopt -static)
+ (modes
+  (native object))
+ (libraries gen_decompress_bindings checkseum.c ctypes.stubs))
+
+(rule
+ (targets libdecompress.a)
+ (package decompress)
+ (deps %{exe:decompress.exe.o})
+ (action
+  (run ar r %{targets} decompress.exe.o)))

bindings/stubs/gen_decompress_bindings.ml

@@ -0,0 +1,61 @@
+open Ctypes
+open Zl
+
+let inflate i i_len o o_len =
+  let i = bigarray_of_ptr array1 i_len Bigarray.char i in
+  let o = bigarray_of_ptr array1 o_len Bigarray.char o in
+  let rec trail decoder res =
+    match Zl.Inf.decode decoder with
+    | `End decoder ->
+      if Zl.Inf.dst_rem decoder = o_len then res
+      else invalid_arg "Too small output buffer"
+    | `Flush _ -> invalid_arg "Too small output buffer"
+    | `Await _ -> assert false
+    | `Malformed err -> invalid_arg err
+  and go decoder =
+    match Zl.Inf.decode decoder with
+    | `Await _ -> assert false
+    | `Flush decoder ->
+      trail (Zl.Inf.flush decoder) (o_len - Zl.Inf.dst_rem decoder)
+    | `Malformed err -> invalid_arg err
+    | `End decoder -> o_len - Zl.Inf.dst_rem decoder in
+  let decoder =
+    Zl.Inf.decoder `Manual ~o ~allocate:(fun bits -> De.make_window ~bits) in
+  let decoder = Zl.Inf.src decoder i 0 i_len in
+  go decoder
+
+let deflate i i_len o o_len level =
+  let i = bigarray_of_ptr array1 i_len Bigarray.char i in
+  let o = bigarray_of_ptr array1 o_len Bigarray.char o in
+  let q = De.Queue.create 0x10000 in
+  let w = De.Lz77.make_window ~bits:15 in
+  let i_pos = ref 0 in
+  let o_pos = ref 0 in
+  let rec go encoder =
+    match Zl.Def.encode encoder with
+    | `Await encoder ->
+      let len = i_len - !i_pos and p = !i_pos in
+      i_pos := !i_pos + len
+      ; go (Zl.Def.src encoder i p len)
+    | `Flush encoder ->
+      let len = o_len - !o_pos - Zl.Def.dst_rem encoder in
+      o_pos := !o_pos + len
+      ; go (Zl.Def.dst encoder o !o_pos (o_len - !o_pos))
+    | `End encoder ->
+      let len = o_len - !o_pos - Zl.Def.dst_rem encoder in
+      !o_pos + len in
+  let encoder = Zl.Def.encoder `Manual `Manual ~q ~w ~level in
+  let encoder = Zl.Def.dst encoder o 0 o_len in
+  go encoder
+
+module Stubs (I : Cstubs_inverted.INTERNAL) = struct
+  let () =
+    I.internal "decompress_inflate"
+      (ptr char @-> int @-> ptr char @-> int @-> returning int)
+      inflate
+
+  let () =
+    I.internal "decompress_deflate"
+      (ptr char @-> int @-> ptr char @-> int @-> int @-> returning int)
+      deflate
+end

bindings/stubs/init.c

@@ -0,0 +1,9 @@
+#include <caml/callback.h>
+
+__attribute__ ((__constructor__))
+void
+init(void)
+{
+	char *caml_argv[1] = { NULL };
+	caml_startup(caml_argv);
+}

decompress.opam

@@ -18,14 +18,16 @@ run-test: [ "dune" "runtest" "-p" name "-j" jobs ]
 
 depends: [
   "ocaml"       {>= "4.07.0"}
-  "dune"        {>= "1.0"}
+  "dune"        {>= "2.8.0"}
   "base-bytes"
   "bigarray-compat"
+  "cmdliner"
   "optint"      {>= "0.0.4"}
   "checkseum"   {>= "0.2.0"}
   "bigstringaf" {with-test}
   "alcotest"    {with-test}
-  "hxd"         {with-test}
+  "ctypes"      {with-test & >= "0.18.0"}
+  "fmt"         {with-test}
   "camlzip"     {>= "1.10" & with-test}
   "base64"      {>= "3.0.0" & with-test}
 ]

dune-project

@@ -1,4 +1,4 @@
-(lang dune 2.0)
+(lang dune 2.8)
 (name decompress)
 (version dev)
-(allow_approximate_merlin)
+(cram enable)