refactor: update Option.Unboxed (ocaml#8332)

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

otherlibs/stdune/src/option.ml

@@ -121,36 +121,37 @@ let first_some x y =
   | Some _ -> x
 
 module Unboxed = struct
-  module T : sig
-    type 'a t
+  type 'a t = Obj.t
 
-    val get_exn : 'a t -> 'a
+  let some x = Obj.repr x
 
-    val some : 'a -> 'a t
+  (* [Sys.opaque_identity] is a paranoid thing to protect against potential compiler
+     optimisations looking through the [none] and seeing the type.
 
-    val none : 'a t
+     The "memory corruption" issue discussed in [option_array.ml] served as an
+     inspiration, but we don't know if it's really necessary. (Empirically, it's not.)
+  *)
+  let none = Obj.repr (Sys.opaque_identity (-1))
 
-    val is_none : 'a t -> bool
-  end = struct
-    type 'a t = 'a
+  (* CR-someday amokhov: Let's expose [phys_equal] somewhere from Stdune? *)
+  let phys_equal = Stdlib.( == )
 
-    let none : 'a. 'a t = Obj.magic 0
+  let is_none t = phys_equal t none
 
-    let is_none x = x == none
+  let is_some t = not (phys_equal t none)
 
-    let get_exn x =
-      if is_none x then Code_error.raise "Option.Unboxed.get_exn: x is none" [];
-      x
+  let value_exn t =
+    if is_none t then
+      Code_error.raise "Option.Unboxed.value_exn called on None" [];
+    Obj.obj t
 
-    let some x =
-      if Obj.is_int (Obj.repr x) then
-        Code_error.raise "Option.Unboxed.some: x must not be immediate" [];
-      x
-  end
+  let to_option t = if is_none t then None else Some (value_exn t)
 
-  include T
+  let iter t ~f = if is_none t then () else f (value_exn t)
+
+  let match_ t ~none ~some = if is_none t then none () else some (value_exn t)
 
   let to_dyn f x =
     if is_none x then Dyn.variant "None" []
-    else Dyn.variant "Some" [ f (get_exn x) ]
+    else Dyn.variant "Some" [ f (value_exn x) ]
 end

otherlibs/stdune/src/option.mli

@@ -61,21 +61,27 @@ end
 
 val merge : 'a t -> 'a t -> f:('a -> 'a -> 'a) -> 'a t
 
+(** A poor man's unboxed option type. The value stored must not be immediate,
+    unless it is a non-negative integer. In particular, unboxed options cannot
+    be nested. *)
 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
+  val none : 'a t
 
-  (** [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 is_some : 'a t -> bool
+
+  val value_exn : 'a t -> 'a
+
+  val to_option : 'a t -> 'a option
+
+  val iter : 'a t -> f:('a -> unit) -> unit
+
+  val match_ : 'a t -> none:(unit -> 'b) -> some:('a -> 'b) -> 'b
+
   val to_dyn : ('a -> Dyn.t) -> 'a t -> Dyn.t
 end

src/dag/dag.ml

@@ -51,7 +51,7 @@ module Make (Value : Value) () : S with type value := Value.t = struct
 
     let get_outgoing _ v = v.deps
 
-    let get_parent _ v = Option.Unboxed.get_exn v.parent
+    let get_parent _ v = Option.Unboxed.value_exn v.parent
 
     let set_parent _ v p = v.parent <- Option.Unboxed.some p
 

src/memo/memo.ml

@@ -356,7 +356,7 @@ module Lazy_dag_node = struct
   let force t ~(dep_node : _ Dep_node_without_state.t) =
     match Option.Unboxed.is_none !t with
     | false ->
-      let (dag_node : Dag.node) = Option.Unboxed.get_exn !t in
+      let (dag_node : Dag.node) = Option.Unboxed.value_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
@@ -1214,7 +1214,7 @@ end = struct
     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
+      let old_cv = Option.Unboxed.value_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)