Merge branch 'main' into delete-old-ctypes

Author: emillon

bin/dune_init.ml

@@ -265,63 +265,64 @@ module Component = struct
     open Dune_lang
 
     module Field = struct
-      let atoms : Atom.t list -> Dune_lang.t list =
-        List.map ~f:(fun x -> Atom x)
+      let inline_tests = Encoder.field_b "inline_tests"
 
-      let public_name name = List [ atom "public_name"; Atom name ]
+      let pps_encoder pps = Encoder.list Encoder.string ("pps" :: pps)
 
-      let name name = List [ atom "name"; Atom name ]
-
-      let inline_tests = List [ atom "inline_tests" ]
-
-      let libraries libs = List (atom "libraries" :: atoms libs)
-
-      let pps pps = List [ atom "preprocess"; List (atom "pps" :: atoms pps) ]
-
-      let optional_field ~f = function
+      let preprocess_field = function
         | [] -> []
-        | args -> [ f args ]
+        | pps -> [ Encoder.field "preprocess" pps_encoder pps ]
 
       let common (options : Options.Common.t) =
-        name options.name
-        :: (optional_field ~f:libraries options.libraries
-           @ optional_field ~f:pps options.pps)
+        [ Encoder.field "name" Encoder.string (Atom.to_string options.name)
+        ; Encoder.field_l "libraries" Encoder.string
+            (List.map ~f:Atom.to_string options.libraries)
+        ]
+        @ preprocess_field (List.map ~f:Atom.to_string options.pps)
     end
 
     (* Make CST representation of a stanza for the given `kind` *)
     let make kind common_options fields =
-      (* Form the AST *)
-      List ((atom kind :: fields) @ Field.common common_options)
+      Encoder.named_record_fields kind (fields @ Field.common common_options)
       (* Convert to a CST *)
       |> Dune_lang.Ast.add_loc ~loc:Loc.none
       |> Cst.concrete (* Package as a list CSTs *) |> List.singleton
 
     let add_to_list_set elem set =
       if List.mem ~equal:Dune_lang.Atom.equal set elem then set else elem :: set
 
-    let public_name_field ~default = function
-      | (None : Options.public_name option) -> []
-      | Some Use_name -> [ Field.public_name default ]
-      | Some (Public_name name) -> [ Field.public_name name ]
+    let public_name_encoder ~default (p : Options.public_name) =
+      let atom =
+        match p with
+        | Use_name -> default
+        | Public_name x -> x
+      in
+      Atom atom
+
+    let public_name_field ~default =
+      Encoder.field_o "public_name" (public_name_encoder ~default)
 
     let executable (common : Options.Common.t) (options : Options.Executable.t)
         =
-      let public_name = public_name_field ~default:common.name options.public in
-      make "executable" common public_name
+      make "executable" common
+        [ public_name_field ~default:common.name options.public ]
 
-    let library (common : Options.Common.t) (options : Options.Library.t) =
-      let common, inline_tests =
-        if not options.inline_tests then (common, [])
-        else
+    let library (common : Options.Common.t)
+        { Options.Library.inline_tests; public } =
+      let common =
+        if inline_tests then
           let pps =
             add_to_list_set
               (Dune_lang.Atom.of_string "ppx_inline_test")
               common.pps
           in
-          ({ common with pps }, [ Field.inline_tests ])
+          { common with pps }
+        else common
       in
-      let public_name = public_name_field ~default:common.name options.public in
-      make "library" common (public_name @ inline_tests)
+      make "library" common
+        [ public_name_field ~default:common.name public
+        ; Field.inline_tests inline_tests
+        ]
 
     let test common (() : Options.Test.t) = make "test" common []
 

otherlibs/stdune/src/option.ml

@@ -119,3 +119,38 @@ let first_some x y =
   match x with
   | None -> y
   | Some _ -> x
+
+module Unboxed = struct
+  module T : sig
+    type 'a t
+
+    val get_exn : 'a t -> 'a
+
+    val some : 'a -> 'a t
+
+    val none : 'a t
+
+    val is_none : 'a t -> bool
+  end = struct
+    type 'a t = 'a
+
+    let none : 'a. 'a t = Obj.magic 0
+
+    let is_none x = x == none
+
+    let get_exn x =
+      if is_none x then Code_error.raise "Option.Unboxed.get_exn: x is none" [];
+      x
+
+    let some x =
+      if Obj.is_int (Obj.repr x) then
+        Code_error.raise "Option.Unboxed.some: x must not be immediate" [];
+      x
+  end
+
+  include T
+
+  let to_dyn f x =
+    if is_none x then Dyn.variant "None" []
+    else Dyn.variant "Some" [ f (get_exn x) ]
+end

otherlibs/stdune/src/option.mli

@@ -60,3 +60,22 @@ module List : sig
 end
 
 val merge : 'a t -> 'a t -> f:('a -> 'a -> 'a) -> 'a t
+
+module Unboxed : sig
+  (** Poor man's unboxed option types. The value stored must not be immediate. A
+      consequence of that is that such option types cannot be nested *)
+
+  type 'a t
+
+  val get_exn : 'a t -> 'a
+
+  (** [some a] will construct the present value. If [a] is immediate, this
+      function will raise *)
+  val some : 'a -> 'a t
+
+  val none : 'a t
+
+  val is_none : 'a t -> bool
+
+  val to_dyn : ('a -> Dyn.t) -> 'a t -> Dyn.t
+end

src/dag/dag.ml

@@ -18,7 +18,7 @@ module Make (Value : Value) () : S with type value := Value.t = struct
       ; mutable level : int
       ; mutable deps : node list
       ; mutable rev_deps : node list
-      ; mutable parent : node option
+      ; mutable parent : node Option.Unboxed.t
       ; value : Value.t
       }
 
@@ -51,12 +51,9 @@ module Make (Value : Value) () : S with type value := Value.t = struct
 
     let get_outgoing _ v = v.deps
 
-    let get_parent _ v =
-      match v.parent with
-      | None -> assert false
-      | Some v -> v
+    let get_parent _ v = Option.Unboxed.get_exn v.parent
 
-    let set_parent _ v p = v.parent <- Some p
+    let set_parent _ v p = v.parent <- Option.Unboxed.some p
 
     let raw_add_edge _ v w = v.deps <- w :: v.deps
 
@@ -70,7 +67,14 @@ module Make (Value : Value) () : S with type value := Value.t = struct
 
   let create_node value =
     let id = Id.gen () in
-    { id; mark = -1; level = 1; deps = []; rev_deps = []; parent = None; value }
+    { id
+    ; mark = -1
+    ; level = 1
+    ; deps = []
+    ; rev_deps = []
+    ; parent = Option.Unboxed.none
+    ; value
+    }
 
   let value t = t.value
 

src/dune_engine/action_runner.ml

@@ -10,7 +10,7 @@
 #include <AvailabilityMacros.h>
 #endif
 
-#if defined(__APPLE__) && __MAC_OS_X_VERSION_MAX_ALLOWED >= 100700
+#if defined(__APPLE__) && __MAC_OS_X_VERSION_MAX_ALLOWED >= 101000
 
 #include <CoreFoundation/CoreFoundation.h>
 #include <CoreServices/CoreServices.h>

src/dune_engine/action_runner.mli

@@ -314,7 +314,13 @@ module Cache_lookup = struct
      outcome would have been [Out_of_date {old_value = None}] instead. *)
   module Failure = struct
     type 'a t =
-      | Out_of_date of { old_value : 'a option }
+      | Out_of_date of
+          { (* ['a] is instantiated to ['a Cached_value.t] below but making
+               this explicit would require us to move this type and [Result]
+               into the recursive module of [M]. We leave this comment to
+               explain why using [Option.Unboxed.t] is OK here. *)
+            old_value : 'a Option.Unboxed.t
+          }
       | Cancelled of { dependency_cycle : Cycle_error.t }
   end
 
@@ -325,9 +331,11 @@ module Cache_lookup = struct
 
     let _to_string_hum = function
       | Ok _ -> "Ok"
-      | Failure (Out_of_date { old_value = None }) -> "Failed (no value)"
-      | Failure (Out_of_date { old_value = Some _ }) -> "Failed (old value)"
       | Failure (Cancelled _) -> "Failed (dependency cycle)"
+      | Failure (Out_of_date { old_value }) -> (
+        match Option.Unboxed.is_none old_value with
+        | true -> "Failed (no value)"
+        | false -> "Failed (old value)")
   end
 end
 
@@ -341,25 +349,26 @@ module Dag : Dag.S with type value := Dep_node_without_state.packed =
 (* This is similar to [type t = Dag.node Lazy.t] but avoids creating a closure
    with a [dep_node]; the latter is available when we need to [force] a [t]. *)
 module Lazy_dag_node = struct
-  type t = Dag.node option ref
+  type t = Dag.node Option.Unboxed.t ref
 
-  let create () = ref None
+  let create () = ref Option.Unboxed.none
 
   let force t ~(dep_node : _ Dep_node_without_state.t) =
-    match !t with
-    | Some (dag_node : Dag.node) ->
+    match Option.Unboxed.is_none !t with
+    | false ->
+      let (dag_node : Dag.node) = Option.Unboxed.get_exn !t in
       let (T dep_node_passed_first) = Dag.value dag_node in
       (* CR-someday amokhov: It would be great to restructure the code to rule
          out the potential inconsistency between [dep_node]s passed to
          [force]. *)
       assert (Id.equal dep_node.id dep_node_passed_first.id);
       dag_node
-    | None ->
+    | true ->
       let (dag_node : Dag.node) =
         if !Counters.enabled then incr Counters.nodes_in_cycle_detection_graph;
         Dag.create_node (Dep_node_without_state.T dep_node)
       in
-      t := Some dag_node;
+      t := Option.Unboxed.some dag_node;
       dag_node
 end
 
@@ -525,13 +534,13 @@ module M = struct
   and State : sig
     type 'a t =
       | Cached_value of 'a Cached_value.t
-      | Out_of_date of { old_value : 'a Cached_value.t option }
+      | Out_of_date of { old_value : 'a Cached_value.t Option.Unboxed.t }
       | Restoring of
           { restore_from_cache :
               'a Cached_value.t Cache_lookup.Result.t Computation0.t
           }
       | Computing of
-          { old_value : 'a Cached_value.t option
+          { old_value : 'a Cached_value.t Option.Unboxed.t
           ; compute : 'a Cached_value.t Computation0.t
           }
   end =
@@ -978,7 +987,9 @@ module State = struct
     | Computing _ -> Dyn.variant "Computing" [ Opaque ]
     | Out_of_date { old_value } ->
       Dyn.variant "Out_of_date"
-        [ Dyn.record [ ("old_value", Dyn.option Cached_value.to_dyn old_value) ]
+        [ Dyn.record
+            [ ("old_value", Option.Unboxed.to_dyn Cached_value.to_dyn old_value)
+            ]
         ]
 end
 
@@ -1028,7 +1039,8 @@ end
 let invalidate_dep_node (dep_node : _ Dep_node.t) =
   match dep_node.state with
   | Cached_value cached_value ->
-    dep_node.state <- Out_of_date { old_value = Some cached_value }
+    dep_node.state <-
+      Out_of_date { old_value = Option.Unboxed.some cached_value }
   | Out_of_date { old_value = _ } -> ()
   | Restoring _ ->
     Code_error.raise "invalidate_dep_node called on a node in Restoring state"
@@ -1067,7 +1079,7 @@ let make_dep_node ~spec ~input : _ Dep_node.t =
     { id = Id.gen (); input; spec }
   in
   { without_state = dep_node_without_state
-  ; state = Out_of_date { old_value = None }
+  ; state = Out_of_date { old_value = Option.Unboxed.none }
   ; has_cutoff =
       (match spec.allow_cutoff with
       | Yes _equal -> true
@@ -1112,11 +1124,13 @@ end = struct
          are set to [Deps.empty]), so we can't use [deps_changed] in this
          case. *)
       Fiber.return
-        (Cache_lookup.Result.Failure (Out_of_date { old_value = None }))
+        (Cache_lookup.Result.Failure
+           (Out_of_date { old_value = Option.Unboxed.none }))
     | Error { reproducible = false; _ } ->
       (* We do not cache non-reproducible errors. *)
       Fiber.return
-        (Cache_lookup.Result.Failure (Out_of_date { old_value = None }))
+        (Cache_lookup.Result.Failure
+           (Out_of_date { old_value = Option.Unboxed.none }))
     | Ok _ | Error { reproducible = true; _ } -> (
       (* We cache reproducible errors just like normal values. We assume that
          all [Memo] computations are deterministic, which means if we rerun a
@@ -1174,14 +1188,15 @@ end = struct
       | Unchanged ->
         cached_value.last_validated_at <- Run.current ();
         Cache_lookup.Result.Ok cached_value
-      | Changed -> Failure (Out_of_date { old_value = Some cached_value })
+      | Changed ->
+        Failure (Out_of_date { old_value = Option.Unboxed.some cached_value })
       | Cancelled { dependency_cycle } ->
         Failure (Cancelled { dependency_cycle }))
 
   and compute :
         'i 'o.
            dep_node:('i, 'o) Dep_node.t
-        -> old_value:'o Cached_value.t option
+        -> old_value:'o Cached_value.t Option.Unboxed.t
         -> stack_frame:Stack_frame_with_state.t
         -> 'o Cached_value.t Fiber.t =
    fun ~dep_node ~old_value ~stack_frame ->
@@ -1196,9 +1211,10 @@ end = struct
       | Error errors -> Error errors
     in
     let deps_rev = Stack_frame_with_state.deps_rev stack_frame in
-    match old_value with
-    | None -> Cached_value.create value ~deps_rev
-    | Some old_cv -> (
+    match Option.Unboxed.is_none old_value with
+    | true -> Cached_value.create value ~deps_rev
+    | false -> (
+      let old_cv = Option.Unboxed.get_exn old_value in
       match Cached_value.value_changed dep_node old_cv.value value with
       | true -> Cached_value.create value ~deps_rev
       | false -> Cached_value.confirm_old_value ~deps_rev old_cv)
@@ -1227,7 +1243,7 @@ end = struct
   and start_computing :
         'i 'o.
            dep_node:('i, 'o) Dep_node.t
-        -> old_value:'o Cached_value.t option
+        -> old_value:'o Cached_value.t Option.Unboxed.t
         -> 'o Cached_value.t Fiber.t =
    fun ~dep_node ~old_value ->
     let computation = Computation.create () in

src/fsevents/fsevents_stubs.c

@@ -0,0 +1,10 @@
+#7108: foo-bar is a valid public name, we should accept it.
+
+  $ dune init lib foo_bar --public foo-bar
+  dune: option '--public': invalid component name `foo-bar'
+        Library names must be non-empty and composed only of the
+        following
+        characters: 'A'..'Z', 'a'..'z', '_' or '0'..'9'.
+  Usage: dune init library [OPTION]… NAME [PATH]
+  Try 'dune init library --help' or 'dune --help' for more information.
+  [1]

src/memo/memo.ml

@@ -0,0 +1,6 @@
+01_module is not a valid module name, this should be detected before trying to `dune build`:
+
+  $ dune init project 01_module
+  Entering directory '01_module'
+  Success: initialized project component named 01_module
+  Leaving directory '01_module'