Move out new functions from Misc.Stdlib.List (ocaml#524)

.depend

@@ -132,14 +132,11 @@ utils/strongly_connected_components.cmi : \
     utils/identifiable.cmi
 utils/targetint.cmo : \
     utils/misc.cmi \
-    utils/identifiable.cmi \
     utils/targetint.cmi
 utils/targetint.cmx : \
     utils/misc.cmx \
-    utils/identifiable.cmx \
     utils/targetint.cmi
-utils/targetint.cmi : \
-    utils/identifiable.cmi
+utils/targetint.cmi :
 utils/terminfo.cmo : \
     utils/terminfo.cmi
 utils/terminfo.cmx : \
@@ -3873,9 +3870,11 @@ middle_end/flambda/compilenv_deps/compilation_unit.cmi : \
     middle_end/flambda/compilenv_deps/container_types.cmi
 middle_end/flambda/compilenv_deps/container_types.cmo : \
     utils/misc.cmi \
+    middle_end/flambda/compilenv_deps/lmap.cmi \
     middle_end/flambda/compilenv_deps/container_types.cmi
 middle_end/flambda/compilenv_deps/container_types.cmx : \
     utils/misc.cmx \
+    middle_end/flambda/compilenv_deps/lmap.cmx \
     middle_end/flambda/compilenv_deps/container_types.cmi
 middle_end/flambda/compilenv_deps/container_types.cmi :
 middle_end/flambda/compilenv_deps/flambda_colours.cmo : \
@@ -3997,15 +3996,12 @@ middle_end/flambda/compilenv_deps/reg_width_things.cmi : \
 middle_end/flambda/compilenv_deps/strongly_connected_components_flambda2.cmo : \
     utils/numbers.cmi \
     utils/misc.cmi \
-    middle_end/flambda/compilenv_deps/container_types.cmi \
     middle_end/flambda/compilenv_deps/strongly_connected_components_flambda2.cmi
 middle_end/flambda/compilenv_deps/strongly_connected_components_flambda2.cmx : \
     utils/numbers.cmx \
     utils/misc.cmx \
-    middle_end/flambda/compilenv_deps/container_types.cmx \
     middle_end/flambda/compilenv_deps/strongly_connected_components_flambda2.cmi
-middle_end/flambda/compilenv_deps/strongly_connected_components_flambda2.cmi : \
-    middle_end/flambda/compilenv_deps/container_types.cmi
+middle_end/flambda/compilenv_deps/strongly_connected_components_flambda2.cmi :
 middle_end/flambda/compilenv_deps/symbol.cmo : \
     middle_end/flambda/compilenv_deps/reg_width_things.cmi \
     utils/misc.cmi \
@@ -7849,7 +7845,6 @@ middle_end/flambda/terms/bound_symbols.cmo : \
     middle_end/flambda/naming/renaming.cmi \
     middle_end/flambda/naming/name_occurrences.cmi \
     middle_end/flambda/naming/name_mode.cmi \
-    utils/misc.cmi \
     middle_end/flambda/cmx/ids_for_export.cmi \
     middle_end/flambda/basic/code_id_or_symbol.cmi \
     middle_end/flambda/basic/code_id.cmi \
@@ -7860,7 +7855,6 @@ middle_end/flambda/terms/bound_symbols.cmx : \
     middle_end/flambda/naming/renaming.cmx \
     middle_end/flambda/naming/name_occurrences.cmx \
     middle_end/flambda/naming/name_mode.cmx \
-    utils/misc.cmx \
     middle_end/flambda/cmx/ids_for_export.cmx \
     middle_end/flambda/basic/code_id_or_symbol.cmx \
     middle_end/flambda/basic/code_id.cmx \
@@ -10382,7 +10376,6 @@ middle_end/flambda/unboxing/unbox_continuation_params.cmo : \
     middle_end/flambda/simplify/simplify_import.cmi \
     middle_end/flambda/unboxing/optimistic_unboxing_decision.cmi \
     middle_end/flambda/naming/name_mode.cmi \
-    utils/misc.cmi \
     middle_end/flambda/unboxing/is_unboxing_beneficial.cmi \
     middle_end/flambda/simplify/env/continuation_env_and_param_types.cmi \
     middle_end/flambda/unboxing/build_unboxing_denv.cmi \
@@ -10394,7 +10387,6 @@ middle_end/flambda/unboxing/unbox_continuation_params.cmx : \
     middle_end/flambda/simplify/simplify_import.cmx \
     middle_end/flambda/unboxing/optimistic_unboxing_decision.cmx \
     middle_end/flambda/naming/name_mode.cmx \
-    utils/misc.cmx \
     middle_end/flambda/unboxing/is_unboxing_beneficial.cmx \
     middle_end/flambda/simplify/env/continuation_env_and_param_types.cmx \
     middle_end/flambda/unboxing/build_unboxing_denv.cmx \

middle_end/flambda/compilenv_deps/container_types.ml

@@ -169,7 +169,8 @@ module Make_map (T : Thing) (Set : Set with module T := T) = struct
     of_list (List.map (fun (k, v) -> f k, v) (bindings m))
 
   let print print_datum ppf t =
-    Misc.print_assoc T.print print_datum ppf (bindings t)
+    let module Lmap = Lmap.Make (T) in
+    Lmap.print print_datum ppf (Lmap.of_list (bindings t))
 
   let print_debug = print
 

middle_end/flambda/compilenv_deps/lmap.ml

@@ -82,16 +82,39 @@ module Make (T : Thing) : S with type key = T.t = struct
     | _ -> raise Not_found
   let map f m = List.map (fun (k, v) -> k, f v) m
   let mapi f m = List.map (fun (k, v) -> k, f k v) m
-  let map_sharing f m = Misc.Stdlib.List.map_sharing (fun ((k, v) as pair) ->
-    let v' = f v in if v' == v then pair else k, v') m
+
+  let rec map_sharing f l0 =
+    match l0 with
+    | a::l ->
+      let a' = f a in
+      let l' = map_sharing f l in
+      if a' == a && l' == l then l0 else a' :: l'
+    | [] -> []
+
+  let map_sharing f m =
+    map_sharing (fun ((k, v) as pair) ->
+      let v' = f v in if v' == v then pair else k, v') m
+
   let filter_map f m = List.filter_map (fun (k, v) ->
     f k v |> Option.map (fun v' -> k, v')) m
   let to_seq m = List.to_seq m
   let rec add_seq s m = match s () with
     | Seq.Nil -> m
     | Seq.Cons (pair, s') -> pair :: add_seq s' m
   let of_seq m = List.of_seq m
-  let print f fmt m = Misc.print_assoc T.print f fmt m
+
+  let print_assoc print_key print_datum ppf l =
+    if l = [] then
+      Format.fprintf ppf "{}"
+    else
+      Format.fprintf ppf "@[<hov 1>{%a}@]"
+        (Format.pp_print_list ~pp_sep:Format.pp_print_space
+          (fun ppf (key, datum) ->
+            Format.fprintf ppf "@[<hov 1>(%a@ %a)@]"
+              print_key key print_datum datum))
+        l
+
+  let print f fmt m = print_assoc T.print f fmt m
 
   let rec invariant m = match m with
     | [] -> ()

middle_end/flambda/naming/bindable_let_bound.ml

@@ -81,6 +81,14 @@ let free_names t =
   | Symbols { bound_symbols; scoping_rule = _; } ->
     Bound_symbols.free_names bound_symbols
 
+let rec map_sharing f l0 =
+  match l0 with
+  | a::l ->
+    let a' = f a in
+    let l' = map_sharing f l in
+    if a' == a && l' == l then l0 else a' :: l'
+  | [] -> []
+
 let apply_renaming t perm =
   match t with
   | Singleton var ->
@@ -89,7 +97,7 @@ let apply_renaming t perm =
     else Singleton var'
   | Set_of_closures { name_mode; closure_vars; } ->
     let closure_vars' =
-      Misc.Stdlib.List.map_sharing (fun var ->
+      map_sharing (fun var ->
           Var_in_binding_pos.apply_renaming var perm)
         closure_vars
     in

middle_end/flambda/parser/fexpr_to_flambda.ml

@@ -1,5 +1,10 @@
 [@@@ocaml.warning "+a-4-30-40-41-42"]
 
+let map_accum_left f env l =
+  let next (acc, env) x = let (y, env) = f env x in (y :: acc, env) in
+  let (acc, env) = List.fold_left next ([], env) l in
+  (List.rev acc, env)
+
 (* Continuation variables *)
 module C = struct
   type t = string
@@ -513,7 +518,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t =
           let var = Var_in_binding_pos.create var Name_mode.normal in
           var, env
         in
-        Misc.Stdlib.List.map_accum_left convert_binding env
+        map_accum_left convert_binding env
           vars_and_closure_bindings
       in
       let bound = Bindable_let_bound.set_of_closures ~closure_vars in
@@ -671,14 +676,14 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t =
             (closure_id, symbol), env
           in
           let closure_symbols, env =
-            Misc.Stdlib.List.map_accum_left closure_binding env soc.bindings
+            map_accum_left closure_binding env soc.bindings
           in
           Bound_symbols.Pattern.set_of_closures
             (closure_symbols |> Closure_id.Lmap.of_list),
           env
         | Closure _ -> assert false (* should have been filtered out above *)
       in
-      Misc.Stdlib.List.map_accum_left process_binding env bindings
+      map_accum_left process_binding env bindings
     in
     let bound_symbols = bound_symbols |> Bound_symbols.create in
     let static_const env (b : Fexpr.symbol_binding) : Flambda.Static_const.t =
@@ -748,7 +753,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t =
           | Deleted -> Deleted
           | Present { params; closure_var; ret_cont; exn_cont; body } ->
             let params, env =
-              Misc.Stdlib.List.map_accum_left
+              map_accum_left
                 (fun env ({ param; kind }:Fexpr.kinded_parameter) ->
                   let var, env = fresh_var env param in
                   let param =

middle_end/flambda/parser/flambda_to_fexpr.ml

@@ -1,5 +1,11 @@
 [@@@ocaml.warning "+a-4-30-40-41-42"]
 
+(* CR-someday mshinwell: share with Fexpr_to_flambda / move to Stdlib *)
+let map_accum_left f env l =
+  let next (acc, env) x = let (y, env) = f env x in (y :: acc, env) in
+  let (acc, env) = List.fold_left next ([], env) l in
+  (List.rev acc, env)
+
 module type Convertible_id = sig
   type t
   type fexpr_id
@@ -546,7 +552,7 @@ and let_expr env le =
 and dynamic_let_expr env vars (defining_expr : Flambda.Named.t) body
       : Fexpr.expr =
   let vars, body_env =
-    Misc.Stdlib.List.map_accum_left Env.bind_var_in_binding_pos env vars
+    map_accum_left Env.bind_var_in_binding_pos env vars
   in
   let body = expr body_env body in
   let defining_exprs, closure_elements =
@@ -669,7 +675,7 @@ and static_let_expr env bound_symbols scoping_rule defining_expr body
                     (Exn_continuation.exn_handler exn_continuation)
                 in
                 let params, env =
-                  Misc.Stdlib.List.map_accum_left kinded_parameter
+                  map_accum_left kinded_parameter
                     env params
                 in
                 let closure_var, env = Env.bind_var env my_closure in
@@ -786,7 +792,7 @@ and cont_handler env cont_id (sort : Continuation.Sort.t) h =
   Flambda.Continuation_handler.pattern_match h
     ~f:(fun params ~handler : Fexpr.continuation_binding ->
       let params, env =
-        Misc.Stdlib.List.map_accum_left kinded_parameter env params
+        map_accum_left kinded_parameter env params
       in
       let handler = expr env handler in
       { name = cont_id; params; sort; handler }

middle_end/flambda/simplify/simplify_set_of_closures.ml

@@ -978,6 +978,17 @@ let simplify_lifted_set_of_closures0 context ~closure_symbols
   in
   bound_symbols, static_consts, dacc
 
+module List = struct
+  include List
+
+  let rec fold_left3 f accu l1 l2 l3 =
+    match l1, l2, l3 with
+    | [], [], [] -> accu
+    | a1::l1, a2::l2, a3::l3 ->
+      fold_left3 f (f accu a1 a2 a3) l1 l2 l3
+    | _, _, _ -> invalid_arg "List.fold_left3"
+end
+
 let simplify_lifted_sets_of_closures dacc ~all_sets_of_closures_and_symbols
       ~closure_bound_names_all_sets ~simplify_toplevel =
   let all_sets_of_closures =
@@ -1011,7 +1022,7 @@ let simplify_lifted_sets_of_closures dacc ~all_sets_of_closures_and_symbols
     (* CR mshinwell: make naming consistent *)
     C.closure_bound_names_inside_functions_all_sets context
   in
-  Misc.Stdlib.List.fold_left3
+  List.fold_left3
     (fun (patterns_acc, static_consts_acc, dacc)
          (closure_symbols, set_of_closures)
          closure_bound_names_inside

middle_end/flambda/terms/bound_symbols.ml

@@ -177,8 +177,17 @@ let everything_being_defined t =
   List.map Pattern.everything_being_defined t
   |> Code_id_or_symbol.Set.union_list
 
+module List = struct
+  include List
+
+  let rec for_all_with_fixed_arg f t fixed_arg =
+    match t with
+    | [] -> true
+    | x::t -> f x fixed_arg && for_all_with_fixed_arg f t fixed_arg
+end
+
 let for_all_everything_being_defined t ~f =
-  Misc.Stdlib.List.for_all_with_fixed_arg (fun pattern f ->
+  List.for_all_with_fixed_arg (fun pattern f ->
       Pattern.for_all_everything_being_defined pattern ~f)
     t
     f
@@ -196,4 +205,4 @@ let all_ids_for_export t =
 
 let concat t1 t2 = t1 @ t2
 
-let gc_roots t = List.map Pattern.gc_roots t |> List.concat
+let gc_roots t = List.map Pattern.gc_roots t |> List.concat

middle_end/flambda/unboxing/unbox_continuation_params.ml

@@ -48,11 +48,22 @@ let refine_decision_based_on_arg_types_at_uses ~pass ~rewrite_ids_seen nth_arg
          end
       ) arg_type_by_use_id decision
 
+module List = struct
+  include List
+
+  let rec fold_left3 f accu l1 l2 l3 =
+    match l1, l2, l3 with
+    | [], [], [] -> accu
+    | a1::l1, a2::l2, a3::l3 ->
+      fold_left3 f (f accu a1 a2 a3) l1 l2 l3
+    | _, _, _ -> invalid_arg "List.fold_left3"
+end
+
 let make_decisions ~continuation_is_recursive ~arg_types_by_use_id
       denv params params_types : DE.t * Decisions.t =
   let empty = Apply_cont_rewrite_id.Set.empty in
   let _, denv, rev_decisions, seen =
-    Misc.Stdlib.List.fold_left3
+    List.fold_left3
       (fun (nth, denv, rev_decisions, seen) param param_type
            arg_type_by_use_id ->
          (* Make an optimistic decision, filter it based on the arg types at the

utils/misc.ml

@@ -99,11 +99,6 @@ module Stdlib = struct
   module List = struct
     type 'a t = 'a list
 
-    let is_singleton t =
-      match t with
-      | [_] -> true
-      | [] | _::_ -> false
-
     let rec compare cmp l1 l2 =
       match l1, l2 with
       | [], [] -> 0
@@ -177,38 +172,6 @@ module Stdlib = struct
           }
       in
       find_prefix ~longest_common_prefix_rev:[] first second
-
-    let rec fold_left3 f accu l1 l2 l3 =
-      match l1, l2, l3 with
-      | [], [], [] -> accu
-      | a1::l1, a2::l2, a3::l3 ->
-        fold_left3 f (f accu a1 a2 a3) l1 l2 l3
-      | _, _, _ -> invalid_arg "List.fold_left3"
-
-    let rec fold_left4 f accu l1 l2 l3 l4 =
-      match l1, l2, l3, l4 with
-      | [], [], [], [] -> accu
-      | a1::l1, a2::l2, a3::l3, a4::l4 ->
-        fold_left4 f (f accu a1 a2 a3 a4) l1 l2 l3 l4
-      | _, _, _, _ -> invalid_arg "List.fold_left4"
-
-    let rec map_sharing f l0 =
-      match l0 with
-      | a::l ->
-        let a' = f a in
-        let l' = map_sharing f l in
-        if a' == a && l' == l then l0 else a' :: l'
-      | [] -> []
-
-    let map_accum_left f env l =
-      let next (acc, env) x = let (y, env) = f env x in (y :: acc, env) in
-      let (acc, env) = List.fold_left next ([], env) l in
-      (List.rev acc, env)
-
-    let rec for_all_with_fixed_arg f t fixed_arg =
-      match t with
-      | [] -> true
-      | x::t -> f x fixed_arg && for_all_with_fixed_arg f t fixed_arg
   end
 
   module Option = struct
@@ -832,18 +795,6 @@ let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) =
   ) lines;
   Format.fprintf ppf "@]"
 
-let print_assoc print_key print_datum ppf l =
-  if l = [] then
-    Format.fprintf ppf "{}"
-  else
-    Format.fprintf ppf "@[<hov 1>{%a}@]"
-      (Format.pp_print_list ~pp_sep:Format.pp_print_space
-        (fun ppf (key, datum) ->
-          Format.fprintf ppf "@[<hov 1>(%a@ %a)@]"
-            print_key key print_datum datum))
-      l
-
-
 (* showing configuration and configuration variables *)
 let show_config_and_exit () =
   Config.print_config stdout;