Merge pull request #5682 from GabrielBuica/private/dbuica/CP-49129

CP-49129: Drop global lock around sexpr parsing

Author: edwintorok

dune-project

@@ -1,5 +1,6 @@
 (lang dune 3.0)
 (formatting (enabled_for ocaml))
+(using menhir 2.0)
 
 (generate_opam_files true)
 

ocaml/database/dune

@@ -1,6 +1,6 @@
 (ocamllex db_filter_lex)
 
-(ocamlyacc db_filter_parse)
+(menhir (modules db_filter_parse))
 
 (library
   (name xapi_schema)

ocaml/libs/sexpr/dune

@@ -1,4 +1,4 @@
-(ocamlyacc sExprParser)
+(menhir (modules sExprParser))
 
 (ocamllex sExprLexer)
 
@@ -17,9 +17,10 @@
 (executable
   (modes exe)
   (name sexprpp)
+  (public_name sexprpp)
+  (package sexpr)
   (modules sexprpp)
   (libraries
     sexpr
   )
 )
-

ocaml/libs/sexpr/sExpr_TS.ml

@@ -12,11 +12,6 @@
  * GNU Lesser General Public License for more details.
  *)
 
-let lock = Mutex.create ()
-
-let of_string s =
-  Xapi_stdext_threads.Threadext.Mutex.execute lock (fun () ->
-      SExprParser.expr SExprLexer.token (Lexing.from_string s)
-  )
+let of_string s = SExprParser.expr SExprLexer.token (Lexing.from_string s)
 
 let string_of = SExpr.string_of

ocaml/libs/sexpr/test/dune

@@ -0,0 +1,4 @@
+(test
+ (name test_sexpr)
+ (modules test_sexpr)
+ (libraries sexpr astring rresult qcheck alcotest threads))

ocaml/libs/sexpr/test/test_sexpr.ml

@@ -0,0 +1,103 @@
+(*
+ * Copyright (C) 2024 Cloud Software Group
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+module Tree = struct
+  type 'a t = Node of 'a * 'a t list
+
+  let rec show pv = function
+    | Node (l, []) ->
+        pv l
+    | Node (l, xs) ->
+        let xs = String.concat " " List.(map (show pv) xs) in
+        Printf.sprintf "(%s %s)" (pv l) xs
+end
+
+module Test = struct
+  let labels = [|"foo"; "bar"; "baz"|]
+
+  let label_gen =
+    QCheck.Gen.(map (Array.get labels) (int_bound (Array.length labels - 1)))
+
+  let tree_gen =
+    (*Alternatively, this can use QCheck.Gen.fix.*)
+    let open QCheck.Gen in
+    let node l xs = Tree.Node (l, xs) in
+    let lo, hi = (2, 6) in
+    let go recur = function
+      | 0 ->
+          map2 node label_gen (return [])
+      | depth ->
+          let xs_gen = list_size (int_range 2 4) (recur (depth - 1)) in
+          map2 node label_gen xs_gen
+    in
+    sized_size (int_range lo hi) (fix go)
+
+  type 'a outcome =
+    | Unfinished
+    | Finished of 'a
+    | Excepted of exn * Printexc.raw_backtrace
+
+  let is_exceptional = function Excepted _ -> true | _ -> false
+
+  let assert_exceptional outcomes =
+    outcomes
+    |> Array.iter (fun outcome ->
+           let exceptional = is_exceptional outcome in
+           let msg =
+             match (exceptional, outcome) with
+             | true, Excepted (_, trace) ->
+                 Printf.sprintf "Exception found when parsing Sexpr: %s"
+                   (Printexc.raw_backtrace_to_string trace)
+             | _ ->
+                 ""
+           in
+           Alcotest.(check bool) msg false exceptional
+       )
+
+  let go n =
+    Printexc.record_backtrace true ;
+    let outcomes = Array.init n (Fun.const Unfinished) in
+    let trees = QCheck.Gen.generate ~n tree_gen in
+    let parse (i, input) =
+      (* Continually parse input until ~200ms has elapsed. *)
+      let go () =
+        let start = Unix.gettimeofday () in
+        while Unix.gettimeofday () -. start < 0.2 do
+          ignore (SExpr_TS.of_string input)
+        done
+      in
+      (* Trap any exception and populate outcomes with it. *)
+      let open Rresult.R in
+      match trap_exn go () with
+      | Ok () ->
+          outcomes.(i) <- Finished ()
+      | Error (`Exn_trap (exn, trace)) ->
+          outcomes.(i) <- Excepted (exn, trace)
+    in
+    let tids =
+      let launch (tids, i) tree =
+        let tid = Thread.create parse (i, Tree.show Fun.id tree) in
+        (tid :: tids, i + 1)
+      in
+      fst (List.fold_left launch ([], 0) trees)
+    in
+    List.iter Thread.join tids ;
+    assert_exceptional outcomes
+end
+
+let test_parsing () = Test.go 10
+
+let test = [("Parallel Parsing", `Quick, test_parsing)]
+
+let () = Alcotest.run "Sexpr parser" [("parallel parsing", test)]

ocaml/libs/sexpr/test/test_sexpr.mli

@@ -1,4 +1,4 @@
-(ocamlyacc xn_cfg_parser)
+(menhir (modules xn_cfg_parser))
 (ocamllex xn_cfg_lexer)
 
 (executable

ocaml/xenopsd/cli/dune

@@ -82,10 +82,22 @@ vtpm-fields () {
   esac
 }
 
+ocamlyacc () {
+  N=0
+  OCAMLYACC=$(git grep -r -o --count "ocamlyacc" '**/dune' | wc -l)
+  if [ "$OCAMLYACC" -eq "$N" ]; then
+    echo "OK found $OCAMLYACC usages of ocamlyacc usages in dune files."
+  else
+    echo "ERROR expected $N usages of ocamlyacc in dune files, got $OCAMLYACC." 1>&2
+    exit 1
+  fi
+}
+
 list-hd
 verify-cert
 mli-files
 structural-equality
 vtpm-unimplemented
 vtpm-fields
+ocamlyacc