From 9d757c2dd350cc3680b22d4a3e7e40e25b6aed74 Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 1 Oct 2024 13:02:04 +0100 Subject: [PATCH 1/2] Prefer concat_map We attempt to replace every occurrence of List.flatten with List.concat, and subsequently try to replace as many occurrences of the pattern: concat (map f xs) with concat_map f xs. Squashed: - Use concat_map in xapi-cli-server - Use concat_map in mpathalert - Use concat_map in sdk-gen - Use concat_map in xenopsd - Use concat_map in idl/ - Use concat_map in perftest - Use concat_map in xapi - Use concat_map in networkd - Use concat_map in xcp-rrdd - Use concat_map in nbd - Use concat_map in xapi-idl - Use concat_map in libs - Use concat_map in doc Signed-off-by: Colin James --- doc/content/xapi/storage/sxm.md | 4 +- ocaml/idl/datamodel_utils.ml | 47 ++-- ocaml/idl/dm_api.ml | 9 +- ocaml/idl/dot_backend.ml | 183 ++++++------ ocaml/idl/dtd_backend.ml | 10 +- ocaml/idl/ocaml_backend/gen_api.ml | 24 +- ocaml/idl/ocaml_backend/gen_client.ml | 5 +- ocaml/idl/ocaml_backend/gen_db_actions.ml | 2 +- ocaml/idl/ocaml_backend/gen_server.ml | 2 +- ocaml/idl/ocaml_backend/gen_test.ml | 46 ++- ocaml/idl/ocaml_backend/ocaml_syntax.ml | 4 +- ocaml/libs/vhd/vhd_format/f.ml | 4 +- ocaml/libs/vhd/vhd_format/patterns.ml | 2 +- ocaml/libs/vhd/vhd_format_lwt/block.ml | 2 +- ocaml/libs/xapi-rrd/lib/rrd_updates.ml | 4 +- .../lib/xapi-stdext-std/xstringext_test.ml | 7 +- ocaml/mpathalert/mpathalert.ml | 24 +- ocaml/nbd/src/main.ml | 3 +- ocaml/networkd/bin/network_server.ml | 10 +- ocaml/networkd/bin_db/networkd_db.ml | 39 ++- ocaml/networkd/lib/network_utils.ml | 112 +++----- ocaml/perftest/cumulative_time.ml | 2 +- ocaml/perftest/graphutil.ml | 14 +- ocaml/perftest/tests.ml | 262 +++++++++--------- ocaml/sdk-gen/csharp/gen_csharp_binding.ml | 12 +- ocaml/sdk-gen/java/main.ml | 7 +- ocaml/xapi-cli-server/cli_operations.ml | 102 +++---- ocaml/xapi-idl/lib_test/idl_test_common.ml | 52 ++-- ocaml/xapi/binpack.ml | 14 +- ocaml/xapi/eventgen.ml | 60 ++-- ocaml/xapi/extauth_plugin_ADpbis.ml | 8 +- ocaml/xapi/hashtbl_xml.ml | 4 +- ocaml/xapi/message_forwarding.ml | 2 +- ocaml/xapi/monitor_master.ml | 3 +- ocaml/xapi/monitor_mem_host.ml | 72 +++-- ocaml/xapi/nm.ml | 3 +- ocaml/xapi/repository.ml | 3 +- ocaml/xapi/storage_smapiv1.ml | 3 +- ocaml/xapi/storage_smapiv1_wrapper.ml | 4 +- ocaml/xapi/valid_ref_list.ml | 2 +- ocaml/xapi/xapi_bond.ml | 48 ++-- ocaml/xapi/xapi_clustering.ml | 5 +- ocaml/xapi/xapi_guest_agent.ml | 30 +- ocaml/xapi/xapi_ha_vm_failover.ml | 24 +- ocaml/xapi/xapi_host.ml | 3 +- ocaml/xapi/xapi_host_helpers.ml | 3 +- ocaml/xapi/xapi_pbd.ml | 2 +- ocaml/xapi/xapi_pci.ml | 2 +- ocaml/xapi/xapi_pool.ml | 28 +- ocaml/xapi/xapi_pvs_server.ml | 2 +- ocaml/xapi/xapi_vbd_helpers.ml | 10 +- ocaml/xapi/xapi_vgpu_type.ml | 2 +- ocaml/xapi/xapi_vm_helpers.ml | 4 +- ocaml/xapi/xapi_vm_migrate.ml | 16 +- ocaml/xapi/xapi_xenops.ml | 9 +- ocaml/xapi/xha_interface.ml | 56 ++-- ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml | 24 +- ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml | 2 +- ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml | 51 ++-- ocaml/xcp-rrdd/bin/rrdp-xenpm/rrdp_xenpm.ml | 2 +- ocaml/xenopsd/lib/xenops_server.ml | 12 +- ocaml/xenopsd/test/test_topology.ml | 4 +- ocaml/xenopsd/xc/device.ml | 110 ++++---- ocaml/xenopsd/xc/device_common.ml | 131 ++++----- ocaml/xenopsd/xc/domain.ml | 3 +- ocaml/xenopsd/xc/xenops_server_xen.ml | 2 +- 66 files changed, 796 insertions(+), 961 deletions(-) diff --git a/doc/content/xapi/storage/sxm.md b/doc/content/xapi/storage/sxm.md index ee3b90276cc..6c44e432d22 100644 --- a/doc/content/xapi/storage/sxm.md +++ b/doc/content/xapi/storage/sxm.md @@ -230,8 +230,8 @@ Next, we determine which VDIs to copy: let vifs = Db.VM.get_VIFs ~__context ~self:vm in let snapshots = Db.VM.get_snapshots ~__context ~self:vm in let vm_and_snapshots = vm :: snapshots in - let snapshots_vbds = List.flatten (List.map (fun self -> Db.VM.get_VBDs ~__context ~self) snapshots) in - let snapshot_vifs = List.flatten (List.map (fun self -> Db.VM.get_VIFs ~__context ~self) snapshots) in + let snapshots_vbds = List.concat_map (fun self -> Db.VM.get_VBDs ~__context ~self) snapshots in + let snapshot_vifs = List.concat_map (fun self -> Db.VM.get_VIFs ~__context ~self) snapshots in ``` we now decide whether we're intra-pool or not, and if we're intra-pool whether we're migrating onto the same host (localhost migrate). Intra-pool is decided by trying to do a lookup of our current host uuid on the destination pool. diff --git a/ocaml/idl/datamodel_utils.ml b/ocaml/idl/datamodel_utils.ml index 6f220c6b53b..080d9059ab8 100644 --- a/ocaml/idl/datamodel_utils.ml +++ b/ocaml/idl/datamodel_utils.ml @@ -38,7 +38,7 @@ module Types = struct | Field f -> [f.ty] | Namespace (_, fields) -> - List.concat (List.map of_content fields) + List.concat_map of_content fields (** Decompose a recursive type into a list of component types (eg a Set(String) -> String :: Set(String) ) *) @@ -62,10 +62,10 @@ module Types = struct (** All types in a list of objects (automatically decomposes) *) let of_objects system = - let fields = List.concat (List.map (fun x -> x.contents) system) in - let field_types = List.concat (List.map of_content fields) in + let fields = List.concat_map (fun x -> x.contents) system in + let field_types = List.concat_map of_content fields in - let messages = List.concat (List.map (fun x -> x.messages) system) in + let messages = List.concat_map (fun x -> x.messages) system in let return_types = let aux accu msg = match msg.msg_result with None -> accu | Some (ty, _) -> ty :: accu @@ -73,9 +73,8 @@ module Types = struct List.fold_left aux [] messages in let param_types = - List.map - (fun p -> p.param_type) - (List.concat (List.map (fun x -> x.msg_params) messages)) + List.(concat_map (fun x -> map (fun p -> p.param_type) x.msg_params)) + messages in let selves = List.map (fun obj -> Ref obj.name) system in let set_self = List.map (fun t -> Set t) selves in @@ -84,7 +83,7 @@ module Types = struct Listext.List.setify (selves @ set_self @ field_types @ return_types @ param_types) in - Listext.List.setify (List.concat (List.map decompose all)) + Listext.List.setify (List.concat_map decompose all) end (** Functions for processing relationships from the model *) @@ -124,18 +123,16 @@ module Relations = struct let other_end_of api ((a, b) as one_end) = let rels = relations_of_api api in match - List.concat - (List.map - (function - | x, other_end when x = one_end -> - [other_end] - | other_end, x when x = one_end -> - [other_end] - | _ -> - [] - ) - rels - ) + List.concat_map + (function + | x, other_end when x = one_end -> + [other_end] + | other_end, x when x = one_end -> + [other_end] + | _ -> + [] + ) + rels with | [other_end] -> other_end @@ -155,11 +152,11 @@ end let fields_of_obj (x : obj) : field list = let rec of_contents = function | Namespace (_, xs) -> - List.concat (List.map of_contents xs) + List.concat_map of_contents xs | Field x -> [x] in - List.concat (List.map of_contents x.contents) + List.concat_map of_contents x.contents (* True if an object has a label (and therefore should have a get_by_name_label message *) let obj_has_get_by_name_label x = @@ -784,7 +781,7 @@ let messages_of_obj (x : obj) document_order : message list = messages @ get_all_public @ [get_all] - @ List.concat (List.map (all_new_messages_of_field x) all_fields) + @ List.concat_map (all_new_messages_of_field x) all_fields @ constructor_destructor @ [uuid; get_record] @ name_label @@ -793,8 +790,8 @@ let messages_of_obj (x : obj) document_order : message list = [get_record; get_record_internal; get_all; uuid] @ constructor_destructor @ name_label - @ List.concat (List.map (new_messages_of_field x 0) all_fields) - @ List.concat (List.map (new_messages_of_field x 1) all_fields) + @ List.concat_map (new_messages_of_field x 0) all_fields + @ List.concat_map (new_messages_of_field x 1) all_fields @ messages @ get_all_public diff --git a/ocaml/idl/dm_api.ml b/ocaml/idl/dm_api.ml index a35bedaa957..15d5eb4bfe8 100644 --- a/ocaml/idl/dm_api.ml +++ b/ocaml/idl/dm_api.ml @@ -79,12 +79,11 @@ let field_exists api ~objname ~fieldname = *) let filter_field (pred : field -> bool) (system : obj list) = (* NB using lists rather than options - maybe change later? *) - let concat_map f xs = List.concat (List.map f xs) in let rec content = function | Field field as x -> if pred field then [x] else [] | Namespace (name, contents) -> - [Namespace (name, concat_map content contents)] + [Namespace (name, List.concat_map content contents)] in (* remove empty /leaf/ namespaces *) let rec remove_leaf = function @@ -93,7 +92,7 @@ let filter_field (pred : field -> bool) (system : obj list) = | Namespace (_, []) -> [] (* no children so removed *) | Namespace (name, contents) -> - [Namespace (name, concat_map remove_leaf contents)] + [Namespace (name, List.concat_map remove_leaf contents)] in let rec fixpoint f x = let result = f x in @@ -103,8 +102,8 @@ let filter_field (pred : field -> bool) (system : obj list) = { x with contents= - (let contents = concat_map content x.contents in - fixpoint (concat_map remove_leaf) contents + (let contents = List.concat_map content x.contents in + fixpoint (List.concat_map remove_leaf) contents ) } in diff --git a/ocaml/idl/dot_backend.ml b/ocaml/idl/dot_backend.ml index a67879fa65d..1d1ca7811ce 100644 --- a/ocaml/idl/dot_backend.ml +++ b/ocaml/idl/dot_backend.ml @@ -34,107 +34,100 @@ let rec all_field_types = function | Field fr -> [(fr.field_name, fr.ty)] | Namespace (_, xs) -> - List.concat (List.map all_field_types xs) + List.concat_map all_field_types xs let of_objs api = let xs = objects_of_api api and relations = relations_of_api api in let names : string list = List.map (fun x -> x.name) xs in let edges : string list = - List.concat - (List.map - (fun (obj : obj) -> - (* First consider the edges defined as relational *) - let relational = - List.filter (fun ((a, _), _) -> a = obj.name) relations - in - let edges = - List.map - (fun ((a, a_field_name), (b, b_field_name)) -> - let a_field = - get_field_by_name api ~objname:a ~fieldname:a_field_name - and b_field = - get_field_by_name api ~objname:b ~fieldname:b_field_name - in - let get_arrow which obj ty = - match Relations.of_types (Ref obj) ty with - | `None -> - failwith - (sprintf - "bad relational edge between %s.%s and %s.%s; \ - object name [%s] never occurs in [%s]" - a a_field_name b b_field_name obj - (Types.to_string ty) - ) - | `One -> - [which ^ "=\"none\""] - | `Many -> - [which ^ "=\"crow\""] - in - let labels = - [(* "label=\"" ^ label ^ "\"";*) "color=\"blue\""] - @ get_arrow "arrowhead" b a_field.ty - @ get_arrow "arrowtail" a b_field.ty - in - sprintf "%s -> %s [ %s ]" a b (String.concat ", " labels) - ) - relational - in - (* list of pairs of (field name, type) *) - let name_types : (string * ty) list = - List.concat (List.map all_field_types obj.contents) - in - (* get rid of all those which are defined as relational *) - let name_types = - List.filter - (fun (name, _) -> - List.filter - (fun ((a, a_name), (b, b_name)) -> - (a = obj.name && a_name = name) - || (b = obj.name && b_name = name) - ) - relations - = [] - ) - name_types - in - (* decompose each ty into a list of references *) - let name_refs : (string * string * ty) list = - List.concat - (List.map - (fun (name, ty) -> - List.map (fun x -> (name, x, ty)) (all_refs ty) - ) - name_types - ) - in - let name_names : (string * string) list = - List.map - (fun (name, obj, ty) -> - let count = - match Relations.of_types (Ref obj) ty with - | `None -> - "(0)" - | `One -> - "(1)" - | `Many -> - "(*)" - in - (name ^ count, obj) - ) - name_refs - in - let edges = - List.map - (fun (field, target) -> - sprintf "%s -> %s [ label=\"%s\" ]" obj.name target field - ) - name_names - @ edges - in - edges - ) - xs + List.concat_map + (fun (obj : obj) -> + (* First consider the edges defined as relational *) + let relational = + List.filter (fun ((a, _), _) -> a = obj.name) relations + in + let edges = + List.map + (fun ((a, a_field_name), (b, b_field_name)) -> + let a_field = + get_field_by_name api ~objname:a ~fieldname:a_field_name + and b_field = + get_field_by_name api ~objname:b ~fieldname:b_field_name + in + let get_arrow which obj ty = + match Relations.of_types (Ref obj) ty with + | `None -> + failwith + (sprintf + "bad relational edge between %s.%s and %s.%s; object \ + name [%s] never occurs in [%s]" + a a_field_name b b_field_name obj (Types.to_string ty) + ) + | `One -> + [which ^ "=\"none\""] + | `Many -> + [which ^ "=\"crow\""] + in + let labels = + [(* "label=\"" ^ label ^ "\"";*) "color=\"blue\""] + @ get_arrow "arrowhead" b a_field.ty + @ get_arrow "arrowtail" a b_field.ty + in + sprintf "%s -> %s [ %s ]" a b (String.concat ", " labels) + ) + relational + in + (* list of pairs of (field name, type) *) + let name_types : (string * ty) list = + List.concat_map all_field_types obj.contents + in + (* get rid of all those which are defined as relational *) + let name_types = + List.filter + (fun (name, _) -> + List.filter + (fun ((a, a_name), (b, b_name)) -> + (a = obj.name && a_name = name) + || (b = obj.name && b_name = name) + ) + relations + = [] + ) + name_types + in + (* decompose each ty into a list of references *) + let name_refs : (string * string * ty) list = + List.concat_map + (fun (name, ty) -> List.map (fun x -> (name, x, ty)) (all_refs ty)) + name_types + in + let name_names : (string * string) list = + List.map + (fun (name, obj, ty) -> + let count = + match Relations.of_types (Ref obj) ty with + | `None -> + "(0)" + | `One -> + "(1)" + | `Many -> + "(*)" + in + (name ^ count, obj) + ) + name_refs + in + let edges = + List.map + (fun (field, target) -> + sprintf "%s -> %s [ label=\"%s\" ]" obj.name target field + ) + name_names + @ edges + in + edges ) + xs in [ "digraph g{" diff --git a/ocaml/idl/dtd_backend.ml b/ocaml/idl/dtd_backend.ml index d820e2623ef..9fa7f6fd58d 100644 --- a/ocaml/idl/dtd_backend.ml +++ b/ocaml/idl/dtd_backend.ml @@ -99,11 +99,9 @@ let rec strings_of_dtd_element known_els = function Hashtbl.remove known_els name ; sprintf "%s%s>" prefix body :: (strings_of_attributes name attributes - @ List.concat - (List.map - (strings_of_dtd_element known_els) - (List.filter is_element els) - ) + @ List.concat_map + (strings_of_dtd_element known_els) + (List.filter is_element els) ) ) else [] @@ -166,4 +164,4 @@ let of_objs api = let xs = objects_of_api api in let known_els = Hashtbl.create 10 in let elements = List.map (dtd_element_of_obj known_els) xs in - List.concat (List.map (strings_of_dtd_element known_els) elements) + List.concat_map (strings_of_dtd_element known_els) elements diff --git a/ocaml/idl/ocaml_backend/gen_api.ml b/ocaml/idl/ocaml_backend/gen_api.ml index 1caf9eee138..7bedb49eca8 100644 --- a/ocaml/idl/ocaml_backend/gen_api.ml +++ b/ocaml/idl/ocaml_backend/gen_api.ml @@ -285,20 +285,18 @@ let gen_client highapi = ) let add_set_enums types = - List.concat - (List.map - (fun ty -> - match ty with - | DT.Enum _ -> - if List.exists (fun ty2 -> ty2 = DT.Set ty) types then - [ty] - else - [DT.Set ty; ty] - | _ -> - [ty] - ) - types + List.concat_map + (fun ty -> + match ty with + | DT.Enum _ -> + if List.exists (fun ty2 -> ty2 = DT.Set ty) types then + [ty] + else + [DT.Set ty; ty] + | _ -> + [ty] ) + types let all_types_of highapi = DU.Types.of_objects (Dm_api.objects_of_api highapi) diff --git a/ocaml/idl/ocaml_backend/gen_client.ml b/ocaml/idl/ocaml_backend/gen_client.ml index d456dd9d5d8..0082f64a1d0 100644 --- a/ocaml/idl/ocaml_backend/gen_client.ml +++ b/ocaml/idl/ocaml_backend/gen_client.ml @@ -221,8 +221,9 @@ let gen_module api : O.Module.t = let fields_of = List.map (fun x -> O.Module.Let x) in let operations = List.map (fun x -> operation ~sync obj x) obj.messages in let helpers = - List.concat - (List.map (fun x -> helper_record_constructor ~sync obj x) obj.messages) + List.concat_map + (fun x -> helper_record_constructor ~sync obj x) + obj.messages in let fields = fields_of (operations @ helpers) in (* diff --git a/ocaml/idl/ocaml_backend/gen_db_actions.ml b/ocaml/idl/ocaml_backend/gen_db_actions.ml index e0cc5cc8454..91c1d9a6ad2 100644 --- a/ocaml/idl/ocaml_backend/gen_db_actions.ml +++ b/ocaml/idl/ocaml_backend/gen_db_actions.ml @@ -586,7 +586,7 @@ let db_action api : O.Module.t = () in let all = Dm_api.objects_of_api api in - let modules = List.concat (List.map (fun x -> [obj x; obj_init x]) all) in + let modules = List.concat_map (fun x -> [obj x; obj_init x]) all in O.Module.make ~name:_db_action ~preamble: [ diff --git a/ocaml/idl/ocaml_backend/gen_server.ml b/ocaml/idl/ocaml_backend/gen_server.ml index e091e07b4d2..31e2bbe16f2 100644 --- a/ocaml/idl/ocaml_backend/gen_server.ml +++ b/ocaml/idl/ocaml_backend/gen_server.ml @@ -496,7 +496,7 @@ let gen_module api : O.Module.t = ; "Server_helpers.dispatch_exn_wrapper (fun () -> (match \ __call with " ] - @ List.flatten (List.map obj all_objs) + @ List.concat_map obj all_objs @ [ "| \"system.listMethods\" -> " ; " success (rpc_of_string_set [" diff --git a/ocaml/idl/ocaml_backend/gen_test.ml b/ocaml/idl/ocaml_backend/gen_test.ml index abf251014f0..70dc19a0fa6 100644 --- a/ocaml/idl/ocaml_backend/gen_test.ml +++ b/ocaml/idl/ocaml_backend/gen_test.ml @@ -75,30 +75,28 @@ let gen_test highapi = [ ["open API"] ; ["let _ ="] - ; List.concat - (List.map - (fun ty -> - [ - sprintf "let oc = open_out \"rpc-light_%s.xml\" in" - (OU.alias_of_ty ty) - ; sprintf "let x = %s in" (gen_test_type highapi ty) - ; sprintf - "Printf.fprintf oc \"%%s\" (Xmlrpc.to_string \ - (API.rpc_of_%s x));" - (OU.alias_of_ty ty) - ; "close_out oc;" - ; sprintf "let oc = open_out \"xml-light2_%s.xml\" in" - (OU.alias_of_ty ty) - ; sprintf - "Printf.fprintf oc \"%%s\" (Xml.to_string \ - (API.Legacy.To.%s x));" - (OU.alias_of_ty ty) - ; "close_out oc;" - (* sprintf "let s = Xml.to_string (API.Legacy.To.%s x) in" (OU.alias_of_ty ty);*) - (* sprintf "let y =" *) - ] - ) - all_types + ; List.concat_map + (fun ty -> + [ + sprintf "let oc = open_out \"rpc-light_%s.xml\" in" + (OU.alias_of_ty ty) + ; sprintf "let x = %s in" (gen_test_type highapi ty) + ; sprintf + "Printf.fprintf oc \"%%s\" (Xmlrpc.to_string (API.rpc_of_%s \ + x));" + (OU.alias_of_ty ty) + ; "close_out oc;" + ; sprintf "let oc = open_out \"xml-light2_%s.xml\" in" + (OU.alias_of_ty ty) + ; sprintf + "Printf.fprintf oc \"%%s\" (Xml.to_string (API.Legacy.To.%s \ + x));" + (OU.alias_of_ty ty) + ; "close_out oc;" + (* sprintf "let s = Xml.to_string (API.Legacy.To.%s x) in" (OU.alias_of_ty ty);*) + (* sprintf "let y =" *) + ] ) + all_types ] ) diff --git a/ocaml/idl/ocaml_backend/ocaml_syntax.ml b/ocaml/idl/ocaml_backend/ocaml_syntax.ml index 634b7477830..e52cce36523 100644 --- a/ocaml/idl/ocaml_backend/ocaml_syntax.ml +++ b/ocaml/idl/ocaml_backend/ocaml_syntax.ml @@ -153,7 +153,7 @@ module Module = struct [ List.map (fun x -> Line x) x.preamble ; (if x.letrec then [Line "let rec __unused () = ()"] else []) - ; List.concat (List.map e x.elements) + ; List.concat_map e x.elements ; List.map (fun x -> Line x) x.postamble ] in @@ -182,7 +182,7 @@ module Signature = struct else Line ("module " ^ x.name ^ " : sig") ) - ; Indent (List.concat (List.map e x.elements)) + ; Indent (List.concat_map e x.elements) ; Line "end" ] diff --git a/ocaml/libs/vhd/vhd_format/f.ml b/ocaml/libs/vhd/vhd_format/f.ml index e3bfc97a1fe..66b3e2f788e 100644 --- a/ocaml/libs/vhd/vhd_format/f.ml +++ b/ocaml/libs/vhd/vhd_format/f.ml @@ -285,7 +285,7 @@ module UTF16 = struct String.concat "" (List.map (fun c -> Printf.sprintf "%c" c) - (List.flatten (List.map utf8_chars_of_int (Array.to_list s))) + (List.concat_map utf8_chars_of_int (Array.to_list s)) ) let to_utf8 x = try Rresult.R.ok (to_utf8_exn x) with e -> Rresult.R.error e @@ -1543,7 +1543,7 @@ module Vhd = struct ) locators in - List.flatten locations @ blocks + List.concat locations @ blocks else blocks in diff --git a/ocaml/libs/vhd/vhd_format/patterns.ml b/ocaml/libs/vhd/vhd_format/patterns.ml index 1f575b00d19..942786854e3 100644 --- a/ocaml/libs/vhd/vhd_format/patterns.ml +++ b/ocaml/libs/vhd/vhd_format/patterns.ml @@ -90,7 +90,7 @@ let string_of_operation = function (string_of_choice p.sector) let descr_of_program p = - let lines = List.concat (List.map descr_of_operation p) in + let lines = List.concat_map descr_of_operation p in List.rev (fst (List.fold_left diff --git a/ocaml/libs/vhd/vhd_format_lwt/block.ml b/ocaml/libs/vhd/vhd_format_lwt/block.ml index b4574e14e28..a9dead185db 100644 --- a/ocaml/libs/vhd/vhd_format_lwt/block.ml +++ b/ocaml/libs/vhd/vhd_format_lwt/block.ml @@ -61,7 +61,7 @@ let to_sectors bufs = (Cstruct.sub remaining 0 available :: acc) (Cstruct.shift remaining available) in - List.concat (List.map (loop []) bufs) + List.concat_map (loop []) bufs let forall_sectors f offset bufs = let rec one offset = function diff --git a/ocaml/libs/xapi-rrd/lib/rrd_updates.ml b/ocaml/libs/xapi-rrd/lib/rrd_updates.ml index d9de5b045b5..af8b0f691d6 100644 --- a/ocaml/libs/xapi-rrd/lib/rrd_updates.ml +++ b/ocaml/libs/xapi-rrd/lib/rrd_updates.ml @@ -73,7 +73,7 @@ let create rra_timestep rras first_rra last_cdp_time first_cdp_time start let extract_row rra = List.map (fun ring -> Fring.peek ring i) (Array.to_list rra.rra_data) in - let values = List.concat (List.map extract_row rras) in + let values = List.concat_map extract_row rras in do_data (i + 1) ({time; row_data= Array.of_list values} :: accum) in @@ -283,7 +283,7 @@ let create_multi prefixandrrds start interval cfopt = ) in - let rras = List.flatten rras in + let rras = List.concat rras in (* The following timestep is that of the archive *) let rra_timestep = Int64.mul timestep (Int64.of_int first_rra.rra_pdp_cnt) in diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml index 7d2766cbaf4..b0816e69ebb 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml @@ -39,7 +39,7 @@ let test_rev_map = in let tests = (* Generate the product of the two lists to generate the tests *) - List.concat (List.map (fun func -> List.map (test func) spec_rev) spec_func) + List.concat_map (fun func -> List.map (test func) spec_rev) spec_func in ("rev_map", tests) @@ -83,8 +83,9 @@ let test_split = ] in let tests_limit = - List.map (fun (limit, spec) -> List.map (test ~limit) spec) specs_limit - |> List.concat + List.concat_map + (fun (limit, spec) -> List.map (test ~limit) spec) + specs_limit in ("split", List.concat [tests_no_limit; tests_limit]) diff --git a/ocaml/mpathalert/mpathalert.ml b/ocaml/mpathalert/mpathalert.ml index bea5ae2ee0a..3a5d2556bd1 100644 --- a/ocaml/mpathalert/mpathalert.ml +++ b/ocaml/mpathalert/mpathalert.ml @@ -257,25 +257,21 @@ let state_of_the_world rpc session_id = debug "Generating the current state of the world" ; let pbds = Client.PBD.get_all_records ~rpc ~session_id in let pbd_alerts = - List.flatten - (List.map - (fun (pbd_ref, pbd_rec) -> - create_pbd_alerts rpc session_id [] - (pbd_ref, pbd_rec, Unix.gettimeofday ()) - ) - pbds + List.concat_map + (fun (pbd_ref, pbd_rec) -> + create_pbd_alerts rpc session_id [] + (pbd_ref, pbd_rec, Unix.gettimeofday ()) ) + pbds in let hosts = Client.Host.get_all_records ~rpc ~session_id in let host_alerts = - List.flatten - (List.map - (fun (host_ref, host_rec) -> - create_host_alerts rpc session_id [] - (host_ref, host_rec, Unix.gettimeofday ()) - ) - hosts + List.concat_map + (fun (host_ref, host_rec) -> + create_host_alerts rpc session_id [] + (host_ref, host_rec, Unix.gettimeofday ()) ) + hosts in let alerts = List.filter diff --git a/ocaml/nbd/src/main.ml b/ocaml/nbd/src/main.ml index 5b5be77f03a..bfdcee6a43f 100644 --- a/ocaml/nbd/src/main.ml +++ b/ocaml/nbd/src/main.ml @@ -93,8 +93,7 @@ let xapi_says_use_tls () = let ask_xapi rpc session_id = Xen_api.Network.get_all_records ~rpc ~session_id >>= fun all_nets -> let all_porpoises = - List.map (fun (_str, net) -> net.API.network_purpose) all_nets - |> List.flatten + List.concat_map (fun (_str, net) -> net.API.network_purpose) all_nets in let tls = List.mem `nbd all_porpoises in let no_tls = List.mem `insecure_nbd all_porpoises in diff --git a/ocaml/networkd/bin/network_server.ml b/ocaml/networkd/bin/network_server.ml index d31d256ef92..d0b21a125d6 100644 --- a/ocaml/networkd/bin/network_server.ml +++ b/ocaml/networkd/bin/network_server.ml @@ -1136,14 +1136,13 @@ module Bridge = struct (fun () -> if from_cache then let ports = - List.concat - (List.map (fun (_, {ports; _}) -> ports) !config.bridge_config) + List.concat_map (fun (_, {ports; _}) -> ports) !config.bridge_config in List.map (fun (port, {interfaces; _}) -> (port, interfaces)) ports else match !backend_kind with | Openvswitch -> - List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) + List.concat_map Ovs.bridge_to_ports (Ovs.list_bridges ()) | Bridge -> raise (Network_error Not_implemented) ) @@ -1154,8 +1153,7 @@ module Bridge = struct (fun () -> if from_cache then let ports = - List.concat - (List.map (fun (_, {ports; _}) -> ports) !config.bridge_config) + List.concat_map (fun (_, {ports; _}) -> ports) !config.bridge_config in let names = List.map (fun (port, {interfaces; _}) -> (port, interfaces)) ports @@ -1164,7 +1162,7 @@ module Bridge = struct else match !backend_kind with | Openvswitch -> - List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) + List.concat_map Ovs.bridge_to_ports (Ovs.list_bridges ()) | Bridge -> raise (Network_error Not_implemented) ) diff --git a/ocaml/networkd/bin_db/networkd_db.ml b/ocaml/networkd/bin_db/networkd_db.ml index 22c91e852c1..f62021828fa 100644 --- a/ocaml/networkd/bin_db/networkd_db.ml +++ b/ocaml/networkd/bin_db/networkd_db.ml @@ -35,8 +35,7 @@ let _ = if List.mem_assoc !bridge config.bridge_config then ( let bridge_config = List.assoc !bridge config.bridge_config in let ifaces = - List.flatten - (List.map (fun (_, port) -> port.interfaces) bridge_config.ports) + List.concat_map (fun (_, port) -> port.interfaces) bridge_config.ports in Printf.printf "interfaces=%s\n" (String.concat "," ifaces) ; match bridge_config.vlan with @@ -58,16 +57,14 @@ let _ = | Static4 conf -> let mode = [("mode", "static")] in let addrs = - List.flatten - (List.map - (fun (ip, plen) -> - [ - ("ipaddr", Unix.string_of_inet_addr ip) - ; ("netmask", prefixlen_to_netmask plen) - ] - ) - conf + List.concat_map + (fun (ip, plen) -> + [ + ("ipaddr", Unix.string_of_inet_addr ip) + ; ("netmask", prefixlen_to_netmask plen) + ] ) + conf in let gateway = match interface_config.ipv4_gateway with @@ -105,19 +102,15 @@ let _ = | Static6 conf -> let mode = [("modev6", "static")] in let addrs = - List.flatten - (List.map - (fun (ip, plen) -> - [ - ( "ipv6addr" - , Unix.string_of_inet_addr ip - ^ "/" - ^ string_of_int plen - ) - ] - ) - conf + List.concat_map + (fun (ip, plen) -> + [ + ( "ipv6addr" + , Unix.string_of_inet_addr ip ^ "/" ^ string_of_int plen + ) + ] ) + conf in let gateway = match interface_config.ipv6_gateway with diff --git a/ocaml/networkd/lib/network_utils.ml b/ocaml/networkd/lib/network_utils.ml index fe371e694de..39417cf1177 100644 --- a/ocaml/networkd/lib/network_utils.ml +++ b/ocaml/networkd/lib/network_utils.ml @@ -1566,15 +1566,11 @@ module Ovs = struct in List.filter_map parse lines in - List.flatten - (List.map - (fun vif -> - create_port_arg - ?ty:(List.assoc_opt vif ifaces_with_type) - vif name - ) - existing_vifs + List.concat_map + (fun vif -> + create_port_arg ?ty:(List.assoc_opt vif ifaces_with_type) vif name ) + existing_vifs in let del_old_arg = let real_bridge_exists () = @@ -1746,32 +1742,26 @@ module Ovs = struct in (* Don't add new properties here, these use the legacy converter *) let extra_args_legacy = - List.flatten - (List.map get_prop_legacy - [ - ("updelay", "bond_updelay") - ; ("downdelay", "bond_downdelay") - ; ("miimon", "other-config:bond-miimon-interval") - ; ("use_carrier", "other-config:bond-detect-mode") - ; ("rebalance-interval", "other-config:bond-rebalance-interval") - ] - ) + List.concat_map get_prop_legacy + [ + ("updelay", "bond_updelay") + ; ("downdelay", "bond_downdelay") + ; ("miimon", "other-config:bond-miimon-interval") + ; ("use_carrier", "other-config:bond-detect-mode") + ; ("rebalance-interval", "other-config:bond-rebalance-interval") + ] and extra_args = - List.flatten - (List.map get_prop - [ - ("lacp-time", "other-config:lacp-time") - ; ("lacp-fallback-ab", "other-config:lacp-fallback-ab") - ] - ) + List.concat_map get_prop + [ + ("lacp-time", "other-config:lacp-time") + ; ("lacp-fallback-ab", "other-config:lacp-fallback-ab") + ] and per_iface_args = - List.flatten - (List.map get_prop - [ - ("lacp-aggregation-key", "other-config:lacp-aggregation-key") - ; ("lacp-actor-key", "other-config:lacp-actor-key") - ] - ) + List.concat_map get_prop + [ + ("lacp-aggregation-key", "other-config:lacp-aggregation-key") + ; ("lacp-actor-key", "other-config:lacp-actor-key") + ] and other_args = List.filter_map (fun (k, v) -> @@ -1801,11 +1791,9 @@ module Ovs = struct if per_iface_args = [] then [] else - List.flatten - (List.map - (fun iface -> ["--"; "set"; "interface"; iface] @ per_iface_args) - interfaces - ) + List.concat_map + (fun iface -> ["--"; "set"; "interface"; iface] @ per_iface_args) + interfaces in vsctl (["--"; "--may-exist"; "add-bond"; bridge; name] @@ -1841,26 +1829,24 @@ module Ovs = struct mac port ] | ports -> - List.flatten - (List.map - (fun port -> - [ - Printf.sprintf - "idle_timeout=0,priority=0,in_port=local,arp,dl_src=%s,actions=NORMAL" - mac - ; Printf.sprintf - "idle_timeout=0,priority=0,in_port=local,dl_src=%s,actions=NORMAL" - mac - ; Printf.sprintf - "idle_timeout=0,priority=0,in_port=%s,arp,nw_proto=1,actions=local" - port - ; Printf.sprintf - "idle_timeout=0,priority=0,in_port=%s,dl_dst=%s,actions=local" - port mac - ] - ) - ports + List.concat_map + (fun port -> + [ + Printf.sprintf + "idle_timeout=0,priority=0,in_port=local,arp,dl_src=%s,actions=NORMAL" + mac + ; Printf.sprintf + "idle_timeout=0,priority=0,in_port=local,dl_src=%s,actions=NORMAL" + mac + ; Printf.sprintf + "idle_timeout=0,priority=0,in_port=%s,arp,nw_proto=1,actions=local" + port + ; Printf.sprintf + "idle_timeout=0,priority=0,in_port=%s,dl_dst=%s,actions=local" + port mac + ] ) + ports in List.iter (fun flow -> ignore (ofctl ["add-flow"; bridge; flow])) flows @@ -1903,22 +1889,12 @@ module Ethtool = struct let set_options name options = if options <> [] then ignore - (call - ("-s" - :: name - :: List.concat (List.map (fun (k, v) -> [k; v]) options) - ) - ) + (call ("-s" :: name :: List.concat_map (fun (k, v) -> [k; v]) options)) let set_offload name options = if options <> [] then ignore - (call - ("-K" - :: name - :: List.concat (List.map (fun (k, v) -> [k; v]) options) - ) - ) + (call ("-K" :: name :: List.concat_map (fun (k, v) -> [k; v]) options)) end module Dracut = struct diff --git a/ocaml/perftest/cumulative_time.ml b/ocaml/perftest/cumulative_time.ml index 9538056094b..5c7ff17d4e9 100644 --- a/ocaml/perftest/cumulative_time.ml +++ b/ocaml/perftest/cumulative_time.ml @@ -80,7 +80,7 @@ let _ = all ; (* Plot a line for (a) elapsed time and (b) this particular duration *) let ls = - List.flatten + List.concat (List.mapi (fun i ((info, _floats), output) -> let graph_one_label = diff --git a/ocaml/perftest/graphutil.ml b/ocaml/perftest/graphutil.ml index 2713dff321f..e2b0880ed46 100644 --- a/ocaml/perftest/graphutil.ml +++ b/ocaml/perftest/graphutil.ml @@ -30,13 +30,11 @@ let merge_infos (infos : info list) = in let floats ((file, result, subtest) as i) = ( i - , List.flatten - (List.map - (fun ((f, r, s), fl) -> - if file = f && result = r && subtest = s then fl else [] - ) - infos + , List.concat_map + (fun ((f, r, s), fl) -> + if file = f && result = r && subtest = s then fl else [] ) + infos ) in let merge_infos = List.map floats names in @@ -83,9 +81,9 @@ let get_info ?(separate = false) files : info list = | None -> [((f, "", ""), floats_from_file f)] | Some results -> - List.flatten (List.map (info_from_raw_result ~separate f) results) + List.concat_map (info_from_raw_result ~separate f) results in - merge_infos (List.flatten (List.map aux files)) + merge_infos (List.concat_map aux files) let short_info_to_string ((file, result, subtest) : short_info) = Printf.sprintf "%s.%s.%s" result subtest file diff --git a/ocaml/perftest/tests.ml b/ocaml/perftest/tests.ml index d0463e9f60a..731d0fa1200 100644 --- a/ocaml/perftest/tests.ml +++ b/ocaml/perftest/tests.ml @@ -43,7 +43,7 @@ let subtest_string key tag = let startall rpc session_id test = let vms = Client.VM.get_all_records ~rpc ~session_id in let tags = List.map (fun (_, vmr) -> vmr.API.vM_tags) vms in - let tags = Listext.List.setify (List.flatten tags) in + let tags = Listext.List.setify (List.concat tags) in List.map (fun tag -> debug "Starting VMs with tag: %s" tag ; @@ -167,25 +167,24 @@ let parallel_with_vms async_op opname n vms rpc session_id test subtest_name = in let events = List.map Event_helper.record_of_event events in let finished_tasks = - List.concat - (List.map - (function - | Event_helper.Task (t, Some t_rec) -> - if - t_rec.API.task_status <> `pending - || t_rec.API.task_current_operations <> [] - then - [t] - else - [] - | Event_helper.Task (t, None) -> - [t] - | _ -> - [] - ) - events - ) + List.concat_map + (function + | Event_helper.Task (t, Some t_rec) -> + if + t_rec.API.task_status <> `pending + || t_rec.API.task_current_operations <> [] + then + [t] + else + [] + | Event_helper.Task (t, None) -> + [t] + | _ -> + [] + ) + events in + finished := process_finished_tasks finished_tasks done with @@ -239,7 +238,7 @@ let parallel_with_vms async_op opname n vms rpc session_id test subtest_name = let parallel async_op opname n rpc session_id test = let vms = Client.VM.get_all_records ~rpc ~session_id in let tags = List.map (fun (_, vmr) -> vmr.API.vM_tags) vms in - let tags = Listext.List.setify (List.flatten tags) in + let tags = Listext.List.setify (List.concat tags) in Printf.printf "Tags are [%s]\n%!" (String.concat "; " tags) ; List.map (fun tag -> @@ -260,7 +259,7 @@ let parallel_stopall = parallel Client.Async.VM.hard_shutdown "stop" let stopall rpc session_id test = let vms = Client.VM.get_all_records ~rpc ~session_id in let tags = List.map (fun (_, vmr) -> vmr.API.vM_tags) vms in - let tags = Listext.List.setify (List.flatten tags) in + let tags = Listext.List.setify (List.concat tags) in List.map (fun tag -> debug "Starting VMs with tag: %s" tag ; @@ -304,121 +303,118 @@ let clone num_clones rpc session_id test = Printf.printf "Doing clone test\n%!" ; let vms = Client.VM.get_all_records ~rpc ~session_id in let tags = List.map (fun (_, vmr) -> vmr.API.vM_tags) vms in - let tags = Listext.List.setify (List.flatten tags) in + let tags = Listext.List.setify (List.concat tags) in Printf.printf "Tags are [%s]\n%!" (String.concat "; " tags) ; - List.flatten - (List.map - (fun tag -> - let vms = - List.filter (fun (_, vmr) -> List.mem tag vmr.API.vM_tags) vms - in - Printf.printf "We've got %d VMs\n%!" (List.length vms) ; - (* Start a thread to clone each one n times *) - let body (vm, vmr, res, clone_refs) = - let name_label = vmr.API.vM_name_label in - Printf.printf "Performing %d clones of '%s' within thread...\n%!" - num_clones name_label ; - for j = 0 to num_clones - 1 do - let result = - time (fun () -> - let clone = - Client.VM.clone ~rpc ~session_id ~vm ~new_name:"clone" - in - clone_refs := clone :: !clone_refs - ) - in - Printf.printf "clone %d of '%s' finished: %f\n%!" j name_label - result ; - res := result :: !res - done - in - let threads_and_results = - List.map - (fun (vm, vmr) -> - let res : float list ref = ref [] in - let clones : API.ref_VM list ref = ref [] in - let t = Thread.create body (vm, vmr, res, clones) in - (t, (res, clones)) - ) - vms - in - let threads, times_and_clones = List.split threads_and_results in - let times, clones = List.split times_and_clones in - Printf.printf "Waiting for threads to finish...\n%!" ; - List.iter (fun t -> Thread.join t) threads ; - Printf.printf "Threads have finished\n%!" ; - (* times is a list of (list of floats, each being the time to clone a VM), one per SR *) - let times = List.map (fun x -> !x) times in - Printf.printf "Times are: [%s]\n%!" - (String.concat ", " - (List.map - (fun x -> - Printf.sprintf "[%s]" - (String.concat ", " - (List.map (fun x -> Printf.sprintf "%f" x) x) - ) - ) - times + List.concat_map + (fun tag -> + let vms = + List.filter (fun (_, vmr) -> List.mem tag vmr.API.vM_tags) vms + in + Printf.printf "We've got %d VMs\n%!" (List.length vms) ; + (* Start a thread to clone each one n times *) + let body (vm, vmr, res, clone_refs) = + let name_label = vmr.API.vM_name_label in + Printf.printf "Performing %d clones of '%s' within thread...\n%!" + num_clones name_label ; + for j = 0 to num_clones - 1 do + let result = + time (fun () -> + let clone = + Client.VM.clone ~rpc ~session_id ~vm ~new_name:"clone" + in + clone_refs := clone :: !clone_refs + ) + in + Printf.printf "clone %d of '%s' finished: %f\n%!" j name_label result ; + res := result :: !res + done + in + let threads_and_results = + List.map + (fun (vm, vmr) -> + let res : float list ref = ref [] in + let clones : API.ref_VM list ref = ref [] in + let t = Thread.create body (vm, vmr, res, clones) in + (t, (res, clones)) + ) + vms + in + let threads, times_and_clones = List.split threads_and_results in + let times, clones = List.split times_and_clones in + Printf.printf "Waiting for threads to finish...\n%!" ; + List.iter (fun t -> Thread.join t) threads ; + Printf.printf "Threads have finished\n%!" ; + (* times is a list of (list of floats, each being the time to clone a VM), one per SR *) + let times = List.map (fun x -> !x) times in + Printf.printf "Times are: [%s]\n%!" + (String.concat ", " + (List.map + (fun x -> + Printf.sprintf "[%s]" + (String.concat ", " + (List.map (fun x -> Printf.sprintf "%f" x) x) + ) ) - ) ; - let clones = List.map (fun x -> !x) clones in - (* Output the results for cloning each gold VM as a separate record *) - let results = - List.map - (fun x -> - { - resultname= test.testname - ; subtest= subtest_string test.key tag - ; xenrtresult= List.fold_left ( +. ) 0.0 (List.flatten times) - ; rawresult= CloneTest x - } - ) - times - in - (* Best-effort clean-up *) - ignore_exn (fun () -> - Printf.printf "Cleaning up...\n%!" ; - (* Create a thread to clean up each set of clones *) - let threads = - List.mapi - (fun i clones -> - Thread.create - (fun clones -> - List.iteri - (fun j clone -> - Printf.printf "Thread %d destroying VM %d...\n%!" i j ; - let vbds = - Client.VM.get_VBDs ~rpc ~session_id ~self:clone - in - let vdis = - List.map - (fun vbd -> - Client.VBD.get_VDI ~rpc ~session_id ~self:vbd - ) - vbds - in - List.iter - (fun vdi -> - Client.VDI.destroy ~rpc ~session_id ~self:vdi - ) - vdis ; - Client.VM.destroy ~rpc ~session_id ~self:clone - ) - clones - ) - clones - ) - clones - in - Printf.printf "Waiting for clean-up threads to finish...\n%!" ; - List.iter (fun t -> Thread.join t) threads ; - Printf.printf "Clean-up threads have finished\n%!" - ) ; - (* Finally, return the results *) - results - ) - tags + times + ) + ) ; + let clones = List.map (fun x -> !x) clones in + (* Output the results for cloning each gold VM as a separate record *) + let results = + List.map + (fun x -> + { + resultname= test.testname + ; subtest= subtest_string test.key tag + ; xenrtresult= List.fold_left ( +. ) 0.0 (List.concat times) + ; rawresult= CloneTest x + } + ) + times + in + (* Best-effort clean-up *) + ignore_exn (fun () -> + Printf.printf "Cleaning up...\n%!" ; + (* Create a thread to clean up each set of clones *) + let threads = + List.mapi + (fun i clones -> + Thread.create + (fun clones -> + List.iteri + (fun j clone -> + Printf.printf "Thread %d destroying VM %d...\n%!" i j ; + let vbds = + Client.VM.get_VBDs ~rpc ~session_id ~self:clone + in + let vdis = + List.map + (fun vbd -> + Client.VBD.get_VDI ~rpc ~session_id ~self:vbd + ) + vbds + in + List.iter + (fun vdi -> + Client.VDI.destroy ~rpc ~session_id ~self:vdi + ) + vdis ; + Client.VM.destroy ~rpc ~session_id ~self:clone + ) + clones + ) + clones + ) + clones + in + Printf.printf "Waiting for clean-up threads to finish...\n%!" ; + List.iter (fun t -> Thread.join t) threads ; + Printf.printf "Clean-up threads have finished\n%!" + ) ; + (* Finally, return the results *) + results ) + tags let recordssize rpc session_id test = let doxmlrpctest (subtestname, testfn) = diff --git a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml index aa65b99b4c3..bbf3360c897 100644 --- a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml +++ b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml @@ -382,7 +382,7 @@ and gen_class out_chan cls = gen_overloads generator message in let all_methods = - messages |> List.map (gen_exposed_method_overloads cls) |> List.concat + messages |> List.concat_map (gen_exposed_method_overloads cls) in List.iter (print "%s") all_methods ; List.iter (gen_exposed_field out_chan cls) contents ; @@ -581,7 +581,7 @@ and exposed_call_params message classname params = (* 'messages' are methods, 'contents' are fields *) and gen_save_changes out_chan exposed_class_name messages contents = - let fields = List.flatten (List.map flatten_content contents) in + let fields = List.concat_map flatten_content contents in let fields2 = List.filter (fun fr -> fr.qualifier == RW && not (List.mem "public" fr.full_name)) @@ -620,7 +620,7 @@ and flatten_content content = | Field fr -> [fr] | Namespace (_, c) -> - List.flatten (List.map flatten_content c) + List.concat_map flatten_content c and gen_save_changes_to_field out_chan exposed_class_name fr = let print format = fprintf out_chan format in @@ -675,9 +675,7 @@ and gen_exposed_field out_chan cls content = List.iter (gen_exposed_field out_chan cls) c and gen_proxy protocol = - let all_methods = - classes |> List.map gen_proxy_class_methods |> List.concat - in + let all_methods = classes |> List.concat_map gen_proxy_class_methods in match protocol with | CommonFunctions.JsonRpc -> let json_method x = `O [("client_method", `String x)] in @@ -690,7 +688,7 @@ and gen_proxy_class_methods {name; messages; _} = let generator params = gen_proxy_method name message params in gen_overloads generator message in - messages |> List.map (gen_message_overloads name) |> List.concat + messages |> List.concat_map (gen_message_overloads name) and gen_proxy_method classname message params = let proxy_msg_name = proxy_msg_name classname message in diff --git a/ocaml/sdk-gen/java/main.ml b/ocaml/sdk-gen/java/main.ml index b025e434964..3b7db08745b 100644 --- a/ocaml/sdk-gen/java/main.ml +++ b/ocaml/sdk-gen/java/main.ml @@ -737,9 +737,9 @@ let get_class_fields_json cls = ] ] | Namespace (name, contents) -> - List.flatten (List.map (fun c -> content_fields c name) contents) + List.concat_map (fun c -> content_fields c name) contents in - List.flatten (List.map (fun c -> content_fields c "") cls.contents) + List.concat_map (fun c -> content_fields c "") cls.contents (** [get_all_message_variants messages acc] takes a list of messages [messages] and an accumulator [acc], and recursively constructs a list of tuples representing both asynchronous and synchronous variants of each message, @@ -768,12 +768,11 @@ let rec get_all_message_variants messages acc = (fun (message, is_async) -> (message, is_async, [])) messages | _ -> - List.map + List.concat_map (fun (message, is_async) -> List.map (fun param -> (message, is_async, param)) params ) messages - |> List.flatten in if h.msg_async then get_variants [(h, false); (h, true)] @ get_all_message_variants tail acc diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index d0d981309da..aa3bf08c05a 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -1460,11 +1460,9 @@ let pool_ha_compute_vm_failover_plan printer rpc session_id params = in (* For now select all VMs resident on the given hosts *) let vms = - List.concat - (List.map - (fun host -> Client.Host.get_resident_VMs ~rpc ~session_id ~self:host) - hosts - ) + List.concat_map + (fun host -> Client.Host.get_resident_VMs ~rpc ~session_id ~self:host) + hosts in let vms = List.filter @@ -1590,32 +1588,26 @@ let pool_eject fd printer rpc session_id params = let pbds = Client.Host.get_PBDs ~rpc ~session_id ~self:host in (* Find the subset of SRs which cannot be seen from other hosts *) let srs = - List.concat - (List.map - (fun pbd -> - try - let sr = Client.PBD.get_SR ~rpc ~session_id ~self:pbd in - let other_pbds = - Client.SR.get_PBDs ~rpc ~session_id ~self:sr - in - let other_hosts = - List.map - (fun pbd -> - Client.PBD.get_host ~rpc ~session_id ~self:pbd - ) - other_pbds - in - let other_hosts_than_me = - List.filter (fun other -> other <> host) other_hosts - in - if other_hosts_than_me = [] then - [sr] - else - [] - with _ -> [] - ) - pbds + List.concat_map + (fun pbd -> + try + let sr = Client.PBD.get_SR ~rpc ~session_id ~self:pbd in + let other_pbds = Client.SR.get_PBDs ~rpc ~session_id ~self:sr in + let other_hosts = + List.map + (fun pbd -> Client.PBD.get_host ~rpc ~session_id ~self:pbd) + other_pbds + in + let other_hosts_than_me = + List.filter (fun other -> other <> host) other_hosts + in + if other_hosts_than_me = [] then + [sr] + else + [] + with _ -> [] ) + pbds in let warnings = ref [] in List.iter @@ -4169,25 +4161,23 @@ let vm_uninstall_common fd _printer rpc session_id params vms = in (* NB If a VDI is deleted then the VBD may be GCed at any time. *) let vdis = - List.concat - (List.map - (fun vbd -> - try - (* We only destroy VDIs where VBD.other_config contains 'owner' *) - let other_config = - Client.VBD.get_other_config ~rpc ~session_id ~self:vbd - in - let vdi = Client.VBD.get_VDI ~rpc ~session_id ~self:vbd in - (* Double-check the VDI actually exists *) - ignore (Client.VDI.get_uuid ~rpc ~session_id ~self:vdi) ; - if List.mem_assoc Constants.owner_key other_config then - [vdi] - else - [] - with _ -> [] - ) - vbds + List.concat_map + (fun vbd -> + try + (* We only destroy VDIs where VBD.other_config contains 'owner' *) + let other_config = + Client.VBD.get_other_config ~rpc ~session_id ~self:vbd + in + let vdi = Client.VBD.get_VDI ~rpc ~session_id ~self:vbd in + (* Double-check the VDI actually exists *) + ignore (Client.VDI.get_uuid ~rpc ~session_id ~self:vdi) ; + if List.mem_assoc Constants.owner_key other_config then + [vdi] + else + [] + with _ -> [] ) + vbds in let suspend_VDI = try @@ -4227,11 +4217,9 @@ let vm_uninstall fd printer rpc session_id params = do_vm_op printer rpc session_id (fun vm -> vm.getref ()) params [] in let snapshots = - List.flatten - (List.map - (fun vm -> Client.VM.get_snapshots ~rpc ~session_id ~self:vm) - vms - ) + List.concat_map + (fun vm -> Client.VM.get_snapshots ~rpc ~session_id ~self:vm) + vms in vm_uninstall_common fd printer rpc session_id params (vms @ snapshots) @@ -6070,11 +6058,9 @@ let cd_list printer rpc session_id params = srs in let cd_vdis = - List.flatten - (List.map - (fun (self, _) -> Client.SR.get_VDIs ~rpc ~session_id ~self) - cd_srs - ) + List.concat_map + (fun (self, _) -> Client.SR.get_VDIs ~rpc ~session_id ~self) + cd_srs in let table cd = let record = vdi_record rpc session_id cd in diff --git a/ocaml/xapi-idl/lib_test/idl_test_common.ml b/ocaml/xapi-idl/lib_test/idl_test_common.ml index 0e039037f3b..8e907f3b402 100644 --- a/ocaml/xapi-idl/lib_test/idl_test_common.ml +++ b/ocaml/xapi-idl/lib_test/idl_test_common.ml @@ -139,42 +139,34 @@ module GenTestData (C : CONFIG) (M : MARSHALLER) = struct match t.Param.name with | Some n -> inner - (List.flatten - (List.map - (fun marshalled -> - match (marshalled, t.Param.typedef.Rpc.Types.ty) with - | Rpc.Enum [], Rpc.Types.Option _ -> - params - | Rpc.Enum [x], Rpc.Types.Option _ -> - List.map - (fun (named, unnamed) -> - ((n, x) :: named, unnamed) - ) - params - | _, _ -> - List.map - (fun (named, unnamed) -> - ((n, marshalled) :: named, unnamed) - ) - params - ) - marshalled + (List.concat_map + (fun marshalled -> + match (marshalled, t.Param.typedef.Rpc.Types.ty) with + | Rpc.Enum [], Rpc.Types.Option _ -> + params + | Rpc.Enum [x], Rpc.Types.Option _ -> + List.map + (fun (named, unnamed) -> ((n, x) :: named, unnamed)) + params + | _, _ -> + List.map + (fun (named, unnamed) -> + ((n, marshalled) :: named, unnamed) + ) + params ) + marshalled ) f | None -> inner - (List.flatten - (List.map - (fun marshalled -> - List.map - (fun (named, unnamed) -> - (named, marshalled :: unnamed) - ) - params - ) - marshalled + (List.concat_map + (fun marshalled -> + List.map + (fun (named, unnamed) -> (named, marshalled :: unnamed)) + params ) + marshalled ) f ) diff --git a/ocaml/xapi/binpack.ml b/ocaml/xapi/binpack.ml index e89a775c749..14c0405bd7b 100644 --- a/ocaml/xapi/binpack.ml +++ b/ocaml/xapi/binpack.ml @@ -107,15 +107,13 @@ let rec permutations : 'a list -> 'a list list = | [] -> [[]] | x :: xs -> - List.concat - (List.map - (fun perm -> - List.map - (fun n -> insert_at n x perm) - (mkints_exclusive (List.length xs + 1)) - ) - (permutations xs) + List.concat_map + (fun perm -> + List.map + (fun n -> insert_at n x perm) + (mkints_exclusive (List.length xs + 1)) ) + (permutations xs) let rec factorial = function 0 -> 1L | x -> Int64.of_int x ** factorial (x - 1) diff --git a/ocaml/xapi/eventgen.ml b/ocaml/xapi/eventgen.ml index f03db1e9bed..46ffd833866 100644 --- a/ocaml/xapi/eventgen.ml +++ b/ocaml/xapi/eventgen.ml @@ -35,30 +35,26 @@ let compute_object_references_to_follow (obj_name : string) = let objs = Dm_api.objects_of_api api in let obj = List.find (fun obj -> obj.Datamodel_types.name = obj_name) objs in let relations = Dm_api.relations_of_api api in - let symmetric = - List.concat (List.map (fun (a, b) -> [(a, b); (b, a)]) relations) - in + let symmetric = List.concat_map (fun (a, b) -> [(a, b); (b, a)]) relations in let set = Xapi_stdext_std.Listext.List.setify symmetric in - List.concat - (List.map - (function - | { - Datamodel_types.ty= Datamodel_types.Ref _ - ; Datamodel_types.field_name - ; _ - } -> - let this_end = (obj.Datamodel_types.name, field_name) in - if List.mem_assoc this_end set then - let other_end = List.assoc this_end set in - let other_obj = fst other_end in - [(other_obj, field_name)] - else - [] - | _ -> - [] - ) - (Datamodel_utils.fields_of_obj obj) - ) + List.concat_map + (function + | { + Datamodel_types.ty= Datamodel_types.Ref _ + ; Datamodel_types.field_name + ; _ + } -> + let this_end = (obj.Datamodel_types.name, field_name) in + if List.mem_assoc this_end set then + let other_end = List.assoc this_end set in + let other_obj = fst other_end in + [(other_obj, field_name)] + else + [] + | _ -> + [] + ) + (Datamodel_utils.fields_of_obj obj) let obj_references_table : (string, (string * string) list) Hashtbl.t = Hashtbl.create 30 @@ -79,17 +75,15 @@ let follow_references (obj_name : string) = (** Compute a set of modify events but skip any for objects which were missing (must have been dangling references) *) let events_of_other_tbl_refs other_tbl_refs = - List.concat - (List.map - (fun (tbl, fld, x) -> - try [(tbl, fld, x ())] - with _ -> - (* Probably means the reference was dangling *) - warn "skipping event for dangling reference %s: %s" tbl fld ; - [] - ) - other_tbl_refs + List.concat_map + (fun (tbl, fld, x) -> + try [(tbl, fld, x ())] + with _ -> + (* Probably means the reference was dangling *) + warn "skipping event for dangling reference %s: %s" tbl fld ; + [] ) + other_tbl_refs open Xapi_database.Db_cache_types open Xapi_database.Db_action_helper diff --git a/ocaml/xapi/extauth_plugin_ADpbis.ml b/ocaml/xapi/extauth_plugin_ADpbis.ml index fc73c7b7cb6..0e9bd3e44f8 100644 --- a/ocaml/xapi/extauth_plugin_ADpbis.ml +++ b/ocaml/xapi/extauth_plugin_ADpbis.ml @@ -981,11 +981,9 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct with Not_found -> [] in let disabled_module_params = - List.concat - (List.map - (fun disabled_module -> ["--disable"; disabled_module]) - disabled_modules - ) + List.concat_map + (fun disabled_module -> ["--disable"; disabled_module]) + disabled_modules in (* we need to make sure that the user passed to domaijoin-cli command is in the UPN syntax (user@domain.com) *) let user = convert_nt_to_upn_username _user in diff --git a/ocaml/xapi/hashtbl_xml.ml b/ocaml/xapi/hashtbl_xml.ml index 1169c60ae59..b1a746adef3 100644 --- a/ocaml/xapi/hashtbl_xml.ml +++ b/ocaml/xapi/hashtbl_xml.ml @@ -52,11 +52,11 @@ let of_xml (input : Xmlm.input) = let el (tag : Xmlm.tag) acc = match tag with | (_, "config"), _ -> - List.flatten acc + List.concat acc | (_, "row"), attrs -> let key = List.assoc ("", "key") attrs in let value = List.assoc ("", "value") attrs in - (key, value) :: List.flatten acc + (key, value) :: List.concat acc | (ns, name), _ -> raise (Unmarshall_error (Printf.sprintf "Unknown tag: (%s,%s)" ns name)) in diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index cbbbdb1f078..7c4af7b0f4b 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -195,7 +195,7 @@ let map_with_drop ?(doc = "performing unknown operation") f xs = (ExnHelper.string_of_exn e) ; [] in - List.concat (List.map one xs) + List.concat_map one xs (* Iterate a function across a list, ignoring applications which throw an exception *) let iter_with_drop ?(doc = "performing unknown operation") f xs = diff --git a/ocaml/xapi/monitor_master.ml b/ocaml/xapi/monitor_master.ml index ffad86ccd6c..c1dff9b8433 100644 --- a/ocaml/xapi/monitor_master.ml +++ b/ocaml/xapi/monitor_master.ml @@ -170,8 +170,7 @@ let update_pifs ~__context host pifs = pifrec.API.pIF_tunnel_transport_PIF_of in (pifrec.API.pIF_network :: vlan_networks) @ tunnel_networks - |> List.map vifs_on_local_bridge - |> List.flatten + |> List.concat_map vifs_on_local_bridge |> List.iter set_carrier with e -> log_backtrace () ; diff --git a/ocaml/xapi/monitor_mem_host.ml b/ocaml/xapi/monitor_mem_host.ml index afddc5d0f78..e4c2f012a24 100644 --- a/ocaml/xapi/monitor_mem_host.ml +++ b/ocaml/xapi/monitor_mem_host.ml @@ -21,45 +21,41 @@ open D let get_changes rrd_files = let named_dss = - List.flatten - (List.map - (fun filename -> - try - let datasources = - Monitor_types.datasources_from_filename filename - in - Mcache.log_errors_from filename ; - datasources - |> List.filter_map (function - | Rrd.Host, ds - when List.mem ds.Ds.ds_name - ["memory_total_kib"; "memory_free_kib"] -> - Some ds - | _ -> - None (* we are only interested in Host memory stats *) - ) - |> List.map (function ds -> - let value = - match ds.Ds.ds_value with - | Rrd.VT_Int64 v -> - Memory.bytes_of_kib v - | Rrd.VT_Float v -> - Memory.bytes_of_kib (Int64.of_float v) - | Rrd.VT_Unknown -> - -1L - in - (ds.Ds.ds_name, value) - ) - with e -> - if not (Mcache.is_ignored filename) then ( - error "Unable to read host memory metrics from %s: %s" filename - (Printexc.to_string e) ; - Mcache.ignore_errors_from filename - ) ; - [] - ) - rrd_files + List.concat_map + (fun filename -> + try + let datasources = Monitor_types.datasources_from_filename filename in + Mcache.log_errors_from filename ; + datasources + |> List.filter_map (function + | Rrd.Host, ds + when List.mem ds.Ds.ds_name + ["memory_total_kib"; "memory_free_kib"] -> + Some ds + | _ -> + None (* we are only interested in Host memory stats *) + ) + |> List.map (function ds -> + let value = + match ds.Ds.ds_value with + | Rrd.VT_Int64 v -> + Memory.bytes_of_kib v + | Rrd.VT_Float v -> + Memory.bytes_of_kib (Int64.of_float v) + | Rrd.VT_Unknown -> + -1L + in + (ds.Ds.ds_name, value) + ) + with e -> + if not (Mcache.is_ignored filename) then ( + error "Unable to read host memory metrics from %s: %s" filename + (Printexc.to_string e) ; + Mcache.ignore_errors_from filename + ) ; + [] ) + rrd_files in let free_bytes = List.assoc_opt "memory_free_kib" named_dss in let total_bytes = List.assoc_opt "memory_total_kib" named_dss in diff --git a/ocaml/xapi/nm.ml b/ocaml/xapi/nm.ml index d2f121bd3f1..1483106ace5 100644 --- a/ocaml/xapi/nm.ml +++ b/ocaml/xapi/nm.ml @@ -105,8 +105,7 @@ let determine_ethtool_settings properties oc = in let settings = speed @ duplex @ autoneg @ advertise in let offload = - List.flatten - (List.map proc ["rx"; "tx"; "sg"; "tso"; "ufo"; "gso"; "gro"; "lro"]) + List.concat_map proc ["rx"; "tx"; "sg"; "tso"; "ufo"; "gso"; "gro"; "lro"] in (settings, offload) diff --git a/ocaml/xapi/repository.ml b/ocaml/xapi/repository.ml index d798246d0b0..dd123557a49 100644 --- a/ocaml/xapi/repository.ml +++ b/ocaml/xapi/repository.ml @@ -570,8 +570,7 @@ let get_pool_updates_in_json ~__context ~hosts = in let lps = updates_of_hosts - |> List.map (fun x -> x.HostUpdates.livepatches) - |> List.concat + |> List.concat_map (fun x -> x.HostUpdates.livepatches) |> LivePatchSet.of_list in let updateinfo_list = diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml index d8bf2cdc203..bc5023006aa 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -1063,8 +1063,7 @@ module SMAPIv1 : Server_impl = struct explore 0 StringMap.empty vdi_rec.API.vDI_location |> invert |> IntMap.bindings - |> List.map snd - |> List.concat + |> List.concat_map snd in let vdi_recs = List.map (fun l -> StringMap.find l locations) vdis in (* We drop cbt_metadata VDIs that do not have any actual data *) diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index 7c5a6a97f43..469be6a53c1 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -1111,7 +1111,7 @@ functor let title = Printf.sprintf "SR %s" (s_of_sr sr) in title :: List.map indent (Sr.to_string_list sr_t) in - let srs = List.concat (List.map of_sr srs) in + let srs = List.concat_map of_sr srs in let errors = List.map Errors.to_string (Errors.list ()) in let errors = ( if errors <> [] then @@ -1298,7 +1298,7 @@ functor let detach_destroy_common context ~dbg ~sr f = let active_dps sr_t = (* Enumerate all active datapaths *) - List.concat (List.map (fun (_, vdi_t) -> Vdi.dp vdi_t) (Sr.list sr_t)) + List.concat_map (fun (_, vdi_t) -> Vdi.dp vdi_t) (Sr.list sr_t) in with_sr sr (fun () -> match Host.find sr !Host.host with diff --git a/ocaml/xapi/valid_ref_list.ml b/ocaml/xapi/valid_ref_list.ml index f192830c735..ef950dd062c 100644 --- a/ocaml/xapi/valid_ref_list.ml +++ b/ocaml/xapi/valid_ref_list.ml @@ -19,6 +19,6 @@ let map f = List.filter_map (default_on_missing_ref (fun x -> Some (f x)) None) let iter f = List.iter (default_on_missing_ref f ()) -let flat_map f l = List.map (default_on_missing_ref f []) l |> List.flatten +let flat_map f l = List.concat_map (default_on_missing_ref f []) l let filter_map f l = List.filter_map Fun.id (map f l) diff --git a/ocaml/xapi/xapi_bond.ml b/ocaml/xapi/xapi_bond.ml index 173a789ac2b..72d762ff193 100644 --- a/ocaml/xapi/xapi_bond.ml +++ b/ocaml/xapi/xapi_bond.ml @@ -79,8 +79,9 @@ let get_local_vifs ~__context host networks = (* Construct (VM -> VIFs) map for all VIFs on the given networks *) let vms_with_vifs = Hashtbl.create 10 in let all_vifs = - List.concat - (List.map (fun net -> Db.Network.get_VIFs ~__context ~self:net) networks) + List.concat_map + (fun net -> Db.Network.get_VIFs ~__context ~self:net) + networks in let add_vif vif = let vm = Db.VIF.get_VM ~__context ~self:vif in @@ -103,13 +104,9 @@ let get_local_vifs ~__context host networks = (* Make a list of the VIFs for local VMs *) let vms = Hashtbl.to_seq_keys vms_with_vifs |> List.of_seq in let local_vifs = - List.concat - (List.map - (fun vm -> - if is_local vm then Hashtbl.find_all vms_with_vifs vm else [] - ) - vms - ) + List.concat_map + (fun vm -> if is_local vm then Hashtbl.find_all vms_with_vifs vm else []) + vms in debug "Found these local VIFs: %s" (String.concat ", " @@ -231,18 +228,14 @@ let fix_bond ~__context ~bond = in let local_vifs = get_local_vifs ~__context host member_networks in let local_vlans = - List.concat - (List.map - (fun pif -> Db.PIF.get_VLAN_slave_of ~__context ~self:pif) - members - ) + List.concat_map + (fun pif -> Db.PIF.get_VLAN_slave_of ~__context ~self:pif) + members in let local_tunnels = - List.concat - (List.map - (fun pif -> Db.PIF.get_tunnel_transport_PIF_of ~__context ~self:pif) - members - ) + List.concat_map + (fun pif -> Db.PIF.get_tunnel_transport_PIF_of ~__context ~self:pif) + members in (* Move VLANs from members to master *) debug "Checking VLANs to move from slaves to master" ; @@ -356,18 +349,15 @@ let create ~__context ~network ~members ~mAC ~mode ~properties = in let local_vifs = get_local_vifs ~__context host member_networks in let local_vlans = - List.concat - (List.map - (fun pif -> Db.PIF.get_VLAN_slave_of ~__context ~self:pif) - members - ) + List.concat_map + (fun pif -> Db.PIF.get_VLAN_slave_of ~__context ~self:pif) + members in + let local_tunnels = - List.concat - (List.map - (fun pif -> Db.PIF.get_tunnel_transport_PIF_of ~__context ~self:pif) - members - ) + List.concat_map + (fun pif -> Db.PIF.get_tunnel_transport_PIF_of ~__context ~self:pif) + members in let is_management_on_vlan = List.filter diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 9f21b4c43c4..ec6efe81d00 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -144,9 +144,10 @@ let get_required_cluster_stacks ~__context ~sr_sm_type = in let sms_matching_sr_type = Db.SM.get_records_where ~__context ~expr in sms_matching_sr_type - |> List.map (fun (_sm_ref, sm_rec) -> sm_rec.API.sM_required_cluster_stack) (* We assume that we only have one SM for each SR type, so this is only to satisfy type checking *) - |> List.flatten + |> List.concat_map (fun (_sm_ref, sm_rec) -> + sm_rec.API.sM_required_cluster_stack + ) let assert_cluster_stack_valid ~cluster_stack = if not (List.mem cluster_stack Constants.supported_smapiv3_cluster_stacks) diff --git a/ocaml/xapi/xapi_guest_agent.ml b/ocaml/xapi/xapi_guest_agent.ml index bd13e808ec8..7de892cdf79 100644 --- a/ocaml/xapi/xapi_guest_agent.ml +++ b/ocaml/xapi/xapi_guest_agent.ml @@ -196,12 +196,12 @@ let networks path vif_type (list : string -> string list) = | [] -> path |> find_eths - |> List.map (fun (path, prefix) -> find_all_ips path prefix) - |> List.concat + |> List.concat_map (fun (path, prefix) -> find_all_ips path prefix) | vif_pair_list -> vif_pair_list - |> List.map (fun (vif_path, vif_id) -> find_all_vif_ips vif_path vif_id) - |> List.concat + |> List.concat_map (fun (vif_path, vif_id) -> + find_all_vif_ips vif_path vif_id + ) (* One key is placed in the other map per control/* key in xenstore. This catches keys like "feature-shutdown" "feature-hibernate" "feature-reboot" @@ -242,19 +242,17 @@ let get_initial_guest_metrics (lookup : string -> string option) let all_control = list "control" in let cant_suspend_reason = lookup "data/cant_suspend_reason" in let to_map kvpairs = - List.concat - (List.map - (fun (xskey, mapkey) -> - match (lookup xskey, xskey, cant_suspend_reason) with - | Some _, "control/feature-suspend", Some reason -> - [("data-cant-suspend-reason", reason)] - | Some xsval, _, _ -> - [(mapkey, xsval)] - | None, _, _ -> - [] - ) - kvpairs + List.concat_map + (fun (xskey, mapkey) -> + match (lookup xskey, xskey, cant_suspend_reason) with + | Some _, "control/feature-suspend", Some reason -> + [("data-cant-suspend-reason", reason)] + | Some xsval, _, _ -> + [(mapkey, xsval)] + | None, _, _ -> + [] ) + kvpairs in let get_tristate xskey = match lookup xskey with diff --git a/ocaml/xapi/xapi_ha_vm_failover.ml b/ocaml/xapi/xapi_ha_vm_failover.ml index c834e384251..322d30f7996 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.ml +++ b/ocaml/xapi/xapi_ha_vm_failover.ml @@ -928,11 +928,9 @@ let compute_restart_plan ~__context ~all_protected_vms ~live_set actually running somewhere else (very strange semi-agile situation) then it will be counted as overhead there and plans will be made for it running on the host we choose. *) let pinned = - List.concat - (List.map - (host_of_non_agile_vm ~__context all_hosts_and_snapshots) - not_agile_vms - ) + List.concat_map + (host_of_non_agile_vm ~__context all_hosts_and_snapshots) + not_agile_vms in (* The restart plan for offline non-agile VMs is just the map VM -> pinned Host *) let non_agile_restart_plan = @@ -955,19 +953,15 @@ let compute_restart_plan ~__context ~all_protected_vms ~live_set in (* All these hosts are live and the VMs are running (or scheduled to be running): *) let agile_vm_placement = - List.concat - (List.map - (fun (vm, host) -> match host with Some h -> [(vm, h)] | _ -> []) - agile_vm_accounted_to_host - ) + List.concat_map + (fun (vm, host) -> match host with Some h -> [(vm, h)] | _ -> []) + agile_vm_accounted_to_host in (* These VMs are not running on any host (either in real life or only hypothetically) *) let agile_vm_failed = - List.concat - (List.map - (fun (vm, host) -> if host = None then [vm] else []) - agile_vm_accounted_to_host - ) + List.concat_map + (fun (vm, host) -> if host = None then [vm] else []) + agile_vm_accounted_to_host in let config = { diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index e8162430943..32139f79896 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -195,8 +195,7 @@ let assert_bacon_mode ~__context ~host = && Db.VM.get_is_control_domain ~__context ~self:vm ) (Db.VM.get_all ~__context) - |> List.map (fun self -> Db.VM.get_VBDs ~__context ~self) - |> List.flatten + |> List.concat_map (fun self -> Db.VM.get_VBDs ~__context ~self) |> List.filter (fun self -> Db.VBD.get_currently_attached ~__context ~self) in if control_domain_vbds <> [] then diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index beb3f2d13b0..eb707de3823 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -135,10 +135,9 @@ let valid_operations ~__context record _ref' = [List.hd plugged_clustered_srs |> Ref.string_of] [`shutdown; `reboot; `apply_updates] ; let recovering_tasks = - List.map + List.concat_map (fun sr -> Helpers.find_health_check_task ~__context ~sr) plugged_clustered_srs - |> List.concat in if recovering_tasks <> [] then set_errors Api_errors.clustered_sr_degraded diff --git a/ocaml/xapi/xapi_pbd.ml b/ocaml/xapi/xapi_pbd.ml index 67fc069c8df..7ba1fd8642d 100644 --- a/ocaml/xapi/xapi_pbd.ml +++ b/ocaml/xapi/xapi_pbd.ml @@ -76,7 +76,7 @@ let get_active_vdis_by_pbd ~__context ~self = Db.VM.get_records_where ~__context ~expr:(Eq (Field "resident_on", Literal (Ref.string_of host))) in - let vbds = List.flatten (List.map (fun (_, vmr) -> vmr.API.vM_VBDs) vms) in + let vbds = List.concat_map (fun (_, vmr) -> vmr.API.vM_VBDs) vms in let vbds_r = List.map (fun self -> Db.VBD.get_record_internal ~__context ~self) vbds in diff --git a/ocaml/xapi/xapi_pci.ml b/ocaml/xapi/xapi_pci.ml index 1ff5620cf58..7c805c7e9cf 100644 --- a/ocaml/xapi/xapi_pci.ml +++ b/ocaml/xapi/xapi_pci.ml @@ -240,7 +240,7 @@ let update_pcis ~__context = ) host_pcis in - let deps = List.flatten (List.map (fun pci -> pci.related) class_pcis) in + let deps = List.concat_map (fun pci -> pci.related) class_pcis in let deps = List.map (fun dep -> List.find (fun pci -> pci.address = dep) host_pcis) diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index ef79c86cad1..13b1d698714 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -686,16 +686,16 @@ let pre_join_checks ~__context ~rpc ~session_id ~force = try let my_nbdish = Db.Network.get_all ~__context - |> List.map (fun nwk -> Db.Network.get_purpose ~__context ~self:nwk) - |> List.flatten + |> List.concat_map (fun nwk -> + Db.Network.get_purpose ~__context ~self:nwk + ) |> List.find (function `nbd | `insecure_nbd -> true | _ -> false) in let remote_nbdish = Client.Network.get_all ~rpc ~session_id - |> List.map (fun nwk -> + |> List.concat_map (fun nwk -> Client.Network.get_purpose ~rpc ~session_id ~self:nwk ) - |> List.flatten |> List.find (function `nbd | `insecure_nbd -> true | _ -> false) in if remote_nbdish <> my_nbdish then @@ -2530,18 +2530,16 @@ let ha_compute_vm_failover_plan ~__context ~failed_hosts ~failed_vms = (String.concat "; " (List.map Ref.string_of live_hosts)) ; (* All failed_vms must be agile *) let errors = - List.concat - (List.map - (fun self -> - try - Agility.vm_assert_agile ~__context ~self ; - [(self, [("error_code", Api_errors.host_not_enough_free_memory)])] - (* default *) - with Api_errors.Server_error (code, _) -> - [(self, [("error_code", code)])] - ) - failed_vms + List.concat_map + (fun self -> + try + Agility.vm_assert_agile ~__context ~self ; + [(self, [("error_code", Api_errors.host_not_enough_free_memory)])] + (* default *) + with Api_errors.Server_error (code, _) -> + [(self, [("error_code", code)])] ) + failed_vms in let plan = List.map diff --git a/ocaml/xapi/xapi_pvs_server.ml b/ocaml/xapi/xapi_pvs_server.ml index dc6c5f59212..d1f5062f448 100644 --- a/ocaml/xapi/xapi_pvs_server.ml +++ b/ocaml/xapi/xapi_pvs_server.ml @@ -26,7 +26,7 @@ let introduce ~__context ~addresses ~first_port ~last_port ~site = addresses ; let current = Db.PVS_server.get_all_records ~__context in let current_addresses = - List.map (fun (_, r) -> r.API.pVS_server_addresses) current |> List.concat + List.concat_map (fun (_, r) -> r.API.pVS_server_addresses) current in let in_use = Listext.intersect addresses current_addresses in if in_use <> [] then diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index c5a370df137..f6b1cc260e7 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -247,13 +247,11 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = let vbds = List.filter (fun vbd -> vbd <> _ref') vdi_record.Db_actions.vDI_VBDs in - List.concat - (List.map - (fun self -> - try [Db.VBD.get_record_internal ~__context ~self] with _ -> [] - ) - vbds + List.concat_map + (fun self -> + try [Db.VBD.get_record_internal ~__context ~self] with _ -> [] ) + vbds in let pointing_to_a_suspended_VM vbd = Db.VM.get_power_state ~__context ~self:vbd.Db_actions.vBD_VM diff --git a/ocaml/xapi/xapi_vgpu_type.ml b/ocaml/xapi/xapi_vgpu_type.ml index 9656aa8f959..f7d5e1eb408 100644 --- a/ocaml/xapi/xapi_vgpu_type.ml +++ b/ocaml/xapi/xapi_vgpu_type.ml @@ -508,7 +508,7 @@ module Vendor_nvidia = struct | E (n, _, _) as t when n = name -> [t] | E (_, _, ch) -> - List.map (find_by_name name) ch |> List.concat + List.concat_map (find_by_name name) ch | D _ -> [] diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index 0387dee1952..b7596bfbc67 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -1158,7 +1158,7 @@ let choose_host_for_vm_no_wlb ~__context ~vm ~snapshot = let validate_host = vm_can_run_on_host ~__context ~vm ~snapshot ~do_memory_check:false in - List.flatten host_lists + List.concat host_lists |> Xapi_vm_placement.select_host __context vm validate_host (** choose_host_for_vm will use WLB as long as it is enabled and there @@ -1328,7 +1328,7 @@ let all_used_VBD_devices ~__context ~self = in all_devices @ all_devices2 in - List.concat (List.map possible_VBD_devices_of_string existing_devices) + List.concat_map possible_VBD_devices_of_string existing_devices let allowed_VBD_devices ~__context ~vm ~_type = let will_have_qemu = Helpers.will_have_qemu ~__context ~self:vm in diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 1f4994fee6c..d35a6b98718 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -342,7 +342,7 @@ let infer_vgpu_map ~__context ?remote vm = else [(pf_device, pf ())] in - try Db.VM.get_VGPUs ~__context ~self:vm |> List.map f |> List.concat + try Db.VM.get_VGPUs ~__context ~self:vm |> List.concat_map f with e -> raise (VGPU_mapping (Printexc.to_string e)) ) | Some {rpc; session; _} -> ( @@ -370,10 +370,7 @@ let infer_vgpu_map ~__context ?remote vm = else [(pf_device, pf ())] in - try - XenAPI.VM.get_VGPUs ~rpc ~session_id ~self:vm - |> List.map f - |> List.concat + try XenAPI.VM.get_VGPUs ~rpc ~session_id ~self:vm |> List.concat_map f with e -> raise (VGPU_mapping (Printexc.to_string e)) ) @@ -1199,12 +1196,10 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map let snapshots = Db.VM.get_snapshots ~__context ~self:vm in let vm_and_snapshots = vm :: snapshots in let snapshots_vbds = - List.flatten - (List.map (fun self -> Db.VM.get_VBDs ~__context ~self) snapshots) + List.concat_map (fun self -> Db.VM.get_VBDs ~__context ~self) snapshots in let snapshot_vifs = - List.flatten - (List.map (fun self -> Db.VM.get_VIFs ~__context ~self) snapshots) + List.concat_map (fun self -> Db.VM.get_VIFs ~__context ~self) snapshots in let is_intra_pool = try @@ -1838,8 +1833,7 @@ let assert_can_migrate ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~options let vifs = Db.VM.get_VIFs ~__context ~self:vm in let snapshots = Db.VM.get_snapshots ~__context ~self:vm in let snapshot_vifs = - List.flatten - (List.map (fun self -> Db.VM.get_VIFs ~__context ~self) snapshots) + List.concat_map (fun self -> Db.VM.get_VIFs ~__context ~self) snapshots in let vif_map = infer_vif_map ~__context (vifs @ snapshot_vifs) vif_map in try diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 0cfe9493d1a..9b8b73f145c 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -864,16 +864,14 @@ module MD = struct let pcis_of_vm ~__context (vmref, vm) = let vgpu_pcidevs = Vgpuops.list_pcis_for_passthrough ~__context ~vm:vmref in let devs = - List.flatten - (List.map (fun (_, dev) -> dev) (Pciops.sort_pcidevs vgpu_pcidevs)) + List.concat_map (fun (_, dev) -> dev) (Pciops.sort_pcidevs vgpu_pcidevs) in (* The 'unmanaged' PCI devices are in the other_config key: *) let other_pcidevs = Pciops.other_pcidevs_of_vm ~__context vm.API.vM_other_config in let unmanaged = - List.flatten - (List.map (fun (_, dev) -> dev) (Pciops.sort_pcidevs other_pcidevs)) + List.concat_map (fun (_, dev) -> dev) (Pciops.sort_pcidevs other_pcidevs) in let net_sriov_pcidevs = list_net_sriov_vf_pcis ~__context ~vm in let devs = devs @ net_sriov_pcidevs @ unmanaged in @@ -3000,14 +2998,13 @@ let resync_resident_on ~__context = in (* Get a list of VMs that the xenopsds know about with their xenopsd client *) let vms_in_xenopsds = - List.map + List.concat_map (fun queue_name -> let module Client = (val make_client queue_name : XENOPS) in let vms = Client.VM.list dbg () in List.map (fun (vm, state) -> ((vm.Vm.id, state), queue_name)) vms ) (all_known_xenopsds ()) - |> List.flatten in (* The list of VMs xenopsd knows about that (xapi knows about at all, xapi has no idea about at all) *) diff --git a/ocaml/xapi/xha_interface.ml b/ocaml/xapi/xha_interface.ml index 53be303e04c..e89d22978ab 100644 --- a/ocaml/xapi/xha_interface.ml +++ b/ocaml/xapi/xha_interface.ml @@ -172,36 +172,32 @@ module DaemonConfiguration = struct Xml.Element ( "parameters" , [] - , List.concat - (List.map int_parameter - [ - ("HeartbeatInterval", config.heart_beat_interval) - ; ("HeartbeatTimeout", config.heart_beat_timeout) - ; ("StateFileInterval", config.state_file_interval) - ; ("StateFileTimeout", config.state_file_timeout) - ; ( "HeartbeatWatchdogTimeout" - , config.heart_beat_watchdog_timeout - ) - ; ( "StateFileWatchdogTimeout" - , config.state_file_watchdog_timeout - ) - ; ("BootJoinTimeout", config.boot_join_timeout) - ; ("EnableJoinTimeout", config.enable_join_timeout) - ; ( "XapiHealthCheckInterval" - , config.xapi_healthcheck_interval - ) - ; ( "XapiHealthCheckTimeout" - , config.xapi_healthcheck_timeout - ) - ; ( "XapiRestartAttempts" - , config.xapi_restart_attempts - ) - ; ("XapiRestartTimeout", config.xapi_restart_timeout) - ; ( "XapiLicenseCheckTimeout" - , config.xapi_licensecheck_timeout - ) - ] - ) + , List.concat_map int_parameter + [ + ("HeartbeatInterval", config.heart_beat_interval) + ; ("HeartbeatTimeout", config.heart_beat_timeout) + ; ("StateFileInterval", config.state_file_interval) + ; ("StateFileTimeout", config.state_file_timeout) + ; ( "HeartbeatWatchdogTimeout" + , config.heart_beat_watchdog_timeout + ) + ; ( "StateFileWatchdogTimeout" + , config.state_file_watchdog_timeout + ) + ; ("BootJoinTimeout", config.boot_join_timeout) + ; ("EnableJoinTimeout", config.enable_join_timeout) + ; ( "XapiHealthCheckInterval" + , config.xapi_healthcheck_interval + ) + ; ( "XapiHealthCheckTimeout" + , config.xapi_healthcheck_timeout + ) + ; ("XapiRestartAttempts", config.xapi_restart_attempts) + ; ("XapiRestartTimeout", config.xapi_restart_timeout) + ; ( "XapiLicenseCheckTimeout" + , config.xapi_licensecheck_timeout + ) + ] ) ] ) diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml index f6a9fa43646..5d445e0f7dc 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml @@ -9,20 +9,18 @@ open D let create_rras use_min_max = (* Create archives of type min, max and average and last *) Array.of_list - (List.flatten - (List.map - (fun (n, ns) -> - if ns > 1 && use_min_max then - [ - Rrd.rra_create Rrd.CF_Average n ns 1.0 - ; Rrd.rra_create Rrd.CF_Min n ns 1.0 - ; Rrd.rra_create Rrd.CF_Max n ns 1.0 - ] - else - [Rrd.rra_create Rrd.CF_Average n ns 0.5] - ) - timescales + (List.concat_map + (fun (n, ns) -> + if ns > 1 && use_min_max then + [ + Rrd.rra_create Rrd.CF_Average n ns 1.0 + ; Rrd.rra_create Rrd.CF_Min n ns 1.0 + ; Rrd.rra_create Rrd.CF_Max n ns 1.0 + ] + else + [Rrd.rra_create Rrd.CF_Average n ns 0.5] ) + timescales ) let step = 5L diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml index e09b4b52511..5b20dc77393 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml @@ -511,7 +511,7 @@ let do_monitor_write xc writers = let timestamp, domains, my_paused_vms = domain_snapshot xc in let tagged_dom0_stats = generate_all_dom0_stats xc timestamp domains in write_dom0_stats writers (Int64.of_float timestamp) tagged_dom0_stats ; - let dom0_stats = List.concat (List.map snd tagged_dom0_stats) in + let dom0_stats = List.concat_map snd tagged_dom0_stats in let plugins_stats = Rrdd_server.Plugin.read_stats () in let stats = List.rev_append plugins_stats dom0_stats in Rrdd_stats.print_snapshot () ; diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml index 1502a07f9fa..057d6e9dc47 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml @@ -52,7 +52,7 @@ let update_vdi_to_vm_map () = (* Get VBDs for this domain *) let enoents = ref 0 in let vbds = - List.map + List.concat_map (fun base_path -> try let path = Printf.sprintf "%s/%d" base_path domid in @@ -75,7 +75,6 @@ let update_vdi_to_vm_map () = [] ) base_paths - |> List.flatten in if !enoents = List.length base_paths then @@ -103,7 +102,7 @@ let update_vdi_to_vm_map () = vbds ) domUs - |> List.flatten + |> List.concat ) with e -> D.error "Error while constructing VDI-to-VM map: %s" (Printexc.to_string e) ; @@ -1080,34 +1079,30 @@ let gen_metrics () = in (* Lookup the VM(s) for this VDI and associate with the RRD for those VM(s) *) let data_sources_vm_iostats = - List.flatten - (List.map - (fun ((_sr, vdi), iostats_value) -> - let create_metrics (vm, pos, _devid) = - let key_format key = Printf.sprintf "vbd_%s_%s" pos key in - Iostats_value.make_ds ~owner:(Rrd.VM vm) ~name:"VDI" ~key_format - iostats_value - in - let vms = list_all_assocs vdi vdi_to_vm in - List.map create_metrics vms - ) - sr_vdi_to_iostats_values + List.concat_map + (fun ((_sr, vdi), iostats_value) -> + let create_metrics (vm, pos, _devid) = + let key_format key = Printf.sprintf "vbd_%s_%s" pos key in + Iostats_value.make_ds ~owner:(Rrd.VM vm) ~name:"VDI" ~key_format + iostats_value + in + let vms = list_all_assocs vdi vdi_to_vm in + List.map create_metrics vms ) + sr_vdi_to_iostats_values in let data_sources_vm_stats = - List.flatten - (List.map - (fun ((_sr, vdi), stats_value) -> - let create_metrics (vm, pos, _devid) = - let key_format key = Printf.sprintf "vbd_%s_%s" pos key in - Stats_value.make_ds ~owner:(Rrd.VM vm) ~name:"VDI" ~key_format - stats_value - in - let vms = list_all_assocs vdi vdi_to_vm in - List.map create_metrics vms - ) - sr_vdi_to_stats_values + List.concat_map + (fun ((_sr, vdi), stats_value) -> + let create_metrics (vm, pos, _devid) = + let key_format key = Printf.sprintf "vbd_%s_%s" pos key in + Stats_value.make_ds ~owner:(Rrd.VM vm) ~name:"VDI" ~key_format + stats_value + in + let vms = list_all_assocs vdi vdi_to_vm in + List.map create_metrics vms ) + sr_vdi_to_stats_values in (* convert recent stats data to hashtbl for next iterator use *) @@ -1122,7 +1117,7 @@ let gen_metrics () = sr_vdi_to_last_stats_values := Some (to_hashtbl sr_vdi_to_stats) ; domid_devid_to_last_stats_blktap3 := Some domid_devid_to_stats_blktap3 ; - List.flatten + List.concat (data_sources_stats @ data_sources_iostats @ data_sources_vm_stats diff --git a/ocaml/xcp-rrdd/bin/rrdp-xenpm/rrdp_xenpm.ml b/ocaml/xcp-rrdd/bin/rrdp-xenpm/rrdp_xenpm.ml index 55c93ef7bfd..6ce1aeb525b 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-xenpm/rrdp_xenpm.ml +++ b/ocaml/xcp-rrdd/bin/rrdp-xenpm/rrdp_xenpm.ml @@ -120,7 +120,7 @@ let generate_state_dss state_kind = (fun state_id time -> gen_pm_ds state_kind cpu_id state_id time) times ) - |> List.flatten + |> List.concat with _ -> [] let generate_cpu_averages () = diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index e65b929e1f4..669af5566a1 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -1004,12 +1004,10 @@ module Redirector = struct ) (Queues.tags queue) in - List.concat - (List.map one - (default.queues - :: parallel_queues.queues - :: List.map snd (StringMap.bindings !overrides) - ) + List.concat_map one + (default.queues + :: parallel_queues.queues + :: List.map snd (StringMap.bindings !overrides) ) ) end @@ -3057,7 +3055,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) | Vm.Softreboot -> [Atomic (VM_softreboot id)] in - let operations = List.concat (List.map operations_of_action actions) in + let operations = List.concat_map operations_of_action actions in List.iter (fun x -> perform_exn x t) operations ; VM_DB.signal id | PCI_check_state id -> diff --git a/ocaml/xenopsd/test/test_topology.ml b/ocaml/xenopsd/test/test_topology.ml index 79d0f79217d..1863f546321 100644 --- a/ocaml/xenopsd/test/test_topology.ml +++ b/ocaml/xenopsd/test/test_topology.ml @@ -79,9 +79,7 @@ let vm_access_costs host all_vms (vcpus, nodes, cpuset) = in D.debug "Costs: %s" (Fmt.to_to_string pp costs) ; let cpus = float @@ CPUSet.cardinal cpuset in - let nodes = - all_vms |> List.map (fun ((_, nodes), _) -> nodes) |> List.flatten - in + let nodes = all_vms |> List.concat_map (fun ((_, nodes), _) -> nodes) in {costs with average= costs.average /. cpus; nodes} let cost_not_worse ~default c = diff --git a/ocaml/xenopsd/xc/device.ml b/ocaml/xenopsd/xc/device.ml index 3f6da8152a6..235f6457875 100644 --- a/ocaml/xenopsd/xc/device.ml +++ b/ocaml/xenopsd/xc/device.ml @@ -1100,7 +1100,7 @@ module PCI = struct ) (* From - https://github.com/torvalds/linux/blob/v4.19/include/linux/pci.h#L76-L102 *) + https://github.com/torvalds/linux/blob/v4.19/include/linux/pci.h#L76-L102 *) (* same as libxl_internal: PROC_PCI_NUM_RESOURCES *) let _proc_pci_num_resources = 7 @@ -1112,7 +1112,7 @@ module PCI = struct let _xen_domctl_dev_rdm_relaxed = 1 (* XXX: we don't want to use the 'xl' command here because the "interface" - isn't considered as stable as the C API *) + isn't considered as stable as the C API *) let xl_pci cmd pcidevs domid = List.iter (fun dev -> @@ -1141,7 +1141,7 @@ module PCI = struct Printf.sprintf "%s/backend/pci/%d/0" be_path fe_domid (* Given a domid, return a list of [ X, (domain, bus, dev, func) ] where X - indicates the order in which the device was plugged. *) + indicates the order in which the device was plugged. *) let read_pcidir ~xs domid = let path = device_model_pci_device_path xs 0 domid in let prefix = "dev-" in @@ -1436,7 +1436,7 @@ module PCI = struct let nvidia_manage = "/usr/lib/nvidia/sriov-manage" (** [num_vfs devstr] returns the number of PCI VFs of [devstr] or 0 if - [devstr] is not an SRIOV device *) + [devstr] is not an SRIOV device *) let num_vfs devstr = let path = sysfs_devices // devstr // "sriov_numvfs" in try Some (Unixext.string_of_file path |> String.trim |> int_of_string) with @@ -1448,8 +1448,8 @@ module PCI = struct (Printexc.to_string exn) (** [vfs_of device] returns the PCI addresses of the virtual functions of PCI - [device]. We find each virtual function by looking at the virtfnX symlink - in [device]. *) + [device]. We find each virtual function by looking at the virtfnX symlink + in [device]. *) let vfs_of devstr = let virtfn n = let path = sysfs_devices // devstr // Printf.sprintf "virtfn%d" n in @@ -1466,8 +1466,8 @@ module PCI = struct [] (** [deactivate_nvidia_sriov devstr] deactivates SRIOV PCI VFs of [devstr] if - necessary. This needs to be called for NVidia GPUs before using [devstr] - as a pass-through GPU. *) + necessary. This needs to be called for NVidia GPUs before using [devstr] + as a pass-through GPU. *) let deactivate_nvidia_sriov devstr = let cmd = nvidia_manage in let args = ["-d"; devstr] in @@ -1916,7 +1916,7 @@ end = struct None (** query qemu for the serial console and write it to xenstore. Only write - path for a real console, not a file or socket path. CA-318579 *) + path for a real console, not a file or socket path. CA-318579 *) let update_xenstore ~xs domid = if not @@ Service.Qemu.is_running ~xs domid then internal_error "Qemu not running for domain %d (%s)" domid __LOC__ ; @@ -1934,12 +1934,12 @@ end let can_surprise_remove ~xs (x : device) = Generic.can_surprise_remove ~xs x (** Dm_Common contains the private Dm functions that are common between the qemu - profile backends. *) + profile backends. *) module Dm_Common = struct (* An example one: [/usr/lib/xen/bin/qemu-dm -d 39 -m 256 -boot cd -serial pty - -usb -usbdevice tablet -domain-name bee94ac1-8f97-42e0-bf77-5cb7a6b664ee - -net nic,vlan=1,macaddr=00:16:3E:76:CE:44,model=rtl8139 -net - tap,vlan=1,bridge=xenbr0 -vnc 39 -k en-us -vnclisten 127.0.0.1] *) + -usb -usbdevice tablet -domain-name bee94ac1-8f97-42e0-bf77-5cb7a6b664ee + -net nic,vlan=1,macaddr=00:16:3E:76:CE:44,model=rtl8139 -net + tap,vlan=1,bridge=xenbr0 -vnc 39 -k en-us -vnclisten 127.0.0.1] *) type usb_opt = Enabled of (string * int) list | Disabled @@ -2081,7 +2081,7 @@ module Dm_Common = struct let vga_type_opts x = let open Xenops_interface.Vgpu in (* We can match on the implementation details to detect the VCS - case. Don't pass -vgpu for a compute vGPU. *) + case. Don't pass -vgpu for a compute vGPU. *) match x with | Vgpu ({implementation= Nvidia {vclass= Some "Compute"; _}; _} :: _) -> ["-std-vga"] @@ -2099,7 +2099,7 @@ module Dm_Common = struct ; Int64.to_string gvt_g.fence_sz ] and priv_opt = ["-priv"] in - List.flatten [base_opts; priv_opt] + List.concat [base_opts; priv_opt] | Vgpu [{implementation= MxGPU _; _}] -> [] | Vgpu _ -> @@ -2136,7 +2136,7 @@ module Dm_Common = struct in let vnc_opt = ["-vnc"; vnc_arg] in let keymap_opt = match keymap with Some k -> ["-k"; k] | None -> [] in - List.flatten [unused_opt; vnc_opt; keymap_opt] + List.concat [unused_opt; vnc_opt; keymap_opt] in let disp_options, wait_for_port = match info.disp with @@ -2166,17 +2166,15 @@ module Dm_Common = struct ; (info.acpi |> function false -> [] | true -> ["-acpi"]) ; (restore |> function false -> [] | true -> ["-loadvm"; restorefile]) ; info.pci_emulations - |> List.map (fun pci -> ["-pciemulation"; pci]) - |> List.concat + |> List.concat_map (fun pci -> ["-pciemulation"; pci]) ; (info.pci_passthrough |> function false -> [] | true -> ["-priv"]) ; List.rev info.extras - |> List.map (function + |> List.concat_map (function | k, None -> ["-" ^ k] | k, Some v -> ["-" ^ k; v] ) - |> List.concat ; (info.monitor |> function None -> [] | Some x -> ["-monitor"; x]) ; ["-pidfile"; Service.Qemu.pidfile_path domid] ] @@ -2193,15 +2191,14 @@ module Dm_Common = struct let root = Device_common.xenops_domain_path in try (* NB: The response size of this directory call may exceed the default - payload size limit. However, we have an exception that allows oversized - packets. *) + payload size limit. However, we have an exception that allows oversized + packets. *) xs.Xs.directory root - |> List.map (fun domid -> + |> List.concat_map (fun domid -> let path = Printf.sprintf "%s/%s/device/vgpu" root domid in try List.map (fun x -> path ^ "/" ^ x) (xs.Xs.directory path) with Xs_protocol.Enoent _ -> [] ) - |> List.concat |> List.exists (fun vgpu -> try let path = Printf.sprintf "%s/pf" vgpu in @@ -2365,20 +2362,20 @@ module Backend = struct (** Common signature for all the profile backends *) module type Intf = sig (** Vgpu functions that use the dispatcher to choose between different - profile and device-model backends *) + profile and device-model backends *) module Vgpu : sig val device : index:int -> int option end (** Vbd functions that use the dispatcher to choose between different - profile backends *) + profile backends *) module Vbd : sig val qemu_media_change : xs:Ezxenstore_core.Xenstore.Xs.xsh -> device -> string -> string -> unit end (** Vcpu functions that use the dispatcher to choose between different - profile backends *) + profile backends *) module Vcpu : sig val add : xs:Ezxenstore_core.Xenstore.Xs.xsh -> devid:int -> int -> bool -> unit @@ -2393,17 +2390,17 @@ module Backend = struct end (** Dm functions that use the dispatcher to choose between different profile - backends *) + backends *) module Dm : sig val get_vnc_port : xs:Ezxenstore_core.Xenstore.Xs.xsh -> int -> Socket.t option (** [get_vnc_port xenstore domid] returns the dom0 tcp port in which the - vnc server for [domid] can be found *) + vnc server for [domid] can be found *) val assert_can_suspend : xs:Ezxenstore_core.Xenstore.Xs.xsh -> Xenctrl.domid -> unit (** [assert_can_suspend xenstore xc] checks whether suspending is - prevented by QEMU *) + prevented by QEMU *) val suspend : Xenops_task.task_handle @@ -2426,7 +2423,7 @@ module Backend = struct -> 'a -> Forkhelpers.pidty (** [init_daemon task path args domid xenstore ready_path timeout cancel] - returns a forkhelper pid after starting the qemu daemon in dom0 *) + returns a forkhelper pid after starting the qemu daemon in dom0 *) val stop : xs:Ezxenstore_core.Xenstore.Xs.xsh @@ -2444,7 +2441,7 @@ module Backend = struct -> int -> Dm_Common.qemu_args (** [cmdline_of_info xenstore info restore domid] creates the command line - arguments to pass to the qemu wrapper script *) + arguments to pass to the qemu wrapper script *) val after_suspend_image : xs:Ezxenstore_core.Xenstore.Xs.xsh @@ -2453,7 +2450,7 @@ module Backend = struct -> int -> unit (** [after_suspend_image xs qemu_domid domid] hook to execute actions - after the suspend image has been created *) + after the suspend image has been created *) val pci_assign_guest : xs:Ezxenstore_core.Xenstore.Xs.xsh @@ -2464,18 +2461,18 @@ module Backend = struct end (** Implementation of the backend common signature for the qemu-none (PV) - backend *) + backend *) module Qemu_none : Intf = struct module Vgpu = struct let device ~index:_ = None end (** Implementation of the Vbd functions that use the dispatcher for the - qemu-none backend *) + qemu-none backend *) module Vbd = struct let qemu_media_change = Vbd_Common.qemu_media_change end (** Implementation of the Vcpu functions that use the dispatcher for the - qemu-none backend *) + qemu-none backend *) module Vcpu = struct let add = Vcpu_Common.add @@ -2487,7 +2484,7 @@ module Backend = struct end (** Implementation of the Dm functions that use the dispatcher for the - qemu-none backend *) + qemu-none backend *) module Dm = struct let get_vnc_port ~xs domid = Dm_Common.get_vnc_port ~xs domid ~f:(fun () -> @@ -2525,7 +2522,7 @@ module Backend = struct (* Backend.Qemu_none *) (** Implementation of the backend common signature for the - qemu-upstream-compat backend *) + qemu-upstream-compat backend *) module type Qemu_upstream_config = sig module NIC : sig val max_emulated : int @@ -2686,7 +2683,7 @@ module Backend = struct let extra_qemu_args ~nic_type = let mult xs ys = - List.map (fun x -> List.map (fun y -> x ^ "." ^ y) ys) xs |> List.concat + List.concat_map (fun x -> List.map (fun y -> x ^ "." ^ y) ys) xs in List.concat [ @@ -2696,8 +2693,7 @@ module Backend = struct ; mult ["piix3-ide-xen"; "piix3-usb-uhci"; nic_type] ["subvendor_id=0x5853"; "subsystem_id=0x0001"] - |> List.map (fun x -> ["-global"; x]) - |> List.concat + |> List.concat_map (fun x -> ["-global"; x]) ] end @@ -2846,11 +2842,11 @@ module Backend = struct let update_cant_suspend domid xs = let as_msg cmd = Qmp.(Success (Some __LOC__, cmd)) in (* changing this will cause fire_event_on_vm to get called, which will do - a VM.check_state, which will trigger a VM.stat from XAPI to update - migratable state *) + a VM.check_state, which will trigger a VM.stat from XAPI to update + migratable state *) let path = Dm_Common.cant_suspend_reason_path domid in (* This will raise QMP_Error if it can't do it, we catch it and update - xenstore. *) + xenstore. *) match qmp_send_cmd ~may_fail:true domid Qmp.Query_migratable with | Qmp.Unit -> debug "query-migratable precheck passed (domid=%d)" domid ; @@ -2984,7 +2980,7 @@ module Backend = struct module Vgpu = struct let device = DefaultConfig.VGPU.device end (** Implementation of the Vbd functions that use the dispatcher for the - qemu-upstream-compat backend *) + qemu-upstream-compat backend *) module Vbd = struct let cd_of devid = match @@ -3004,8 +3000,8 @@ module Backend = struct internal_error "unexpected disk for devid %d" devid (* parse NBD URI. We are not using the URI module because the - format is not compliant but used by qemu. Using sscanf instead - to recognise and parse the specific URI *) + format is not compliant but used by qemu. Using sscanf instead + to recognise and parse the specific URI *) let is_nbd str = try Scanf.sscanf str "nbd:unix:%s@:exportname=%s" (fun _ _ -> true) with _ -> false @@ -3101,7 +3097,7 @@ module Backend = struct (* Backend.Qemu_upstream_compat.Vbd *) (** Implementation of the Vcpu functions that use the dispatcher for the - qemu-upstream-compat backend *) + qemu-upstream-compat backend *) module Vcpu = struct let add = Vcpu_Common.add @@ -3110,7 +3106,7 @@ module Backend = struct let status = Vcpu_Common.status (* hot(un)plug vcpu using QMP, keeping backwards-compatible xenstored - mechanism *) + mechanism *) let set ~xs ~devid domid online = Vcpu_Common.set ~xs ~devid domid online ; match online with @@ -3156,7 +3152,7 @@ module Backend = struct end (** Implementation of the Dm functions that use the dispatcher for the - qemu-upstream-compat backend *) + qemu-upstream-compat backend *) module Dm = struct let get_vnc_port ~xs domid = Dm_Common.get_vnc_port ~xs domid ~f:(fun () -> @@ -3212,7 +3208,7 @@ module Backend = struct (fun () -> Unix.close save_fd) (* Wait for QEMU's event socket to appear. Connect to it to make sure it - is ready. *) + is ready. *) let wait_event_socket ~task ~name ~domid ~timeout = let finished = ref false in let timeout_ns = Int64.of_float (timeout *. 1e9) in @@ -3296,10 +3292,9 @@ module Backend = struct | Dm_Common.Enabled devices -> let devs = devices - |> List.map (fun (x, y) -> + |> List.concat_map (fun (x, y) -> ["-device"; sprintf "usb-%s,port=%d" x y] ) - |> List.concat in "-usb" :: devs in @@ -3357,13 +3352,12 @@ module Backend = struct ) ; let qmp = ["libxl"; "event"] - |> List.map (fun x -> + |> List.concat_map (fun x -> [ "-qmp" ; sprintf "unix:/var/run/xen/qmp-%s-%d,server,nowait" x domid ] ) - |> List.concat in let pv_device addr = try @@ -3525,11 +3519,11 @@ module Backend = struct (* Backend.Qemu_upstream *) (** Implementation of the backend common signature for the qemu-upstream - backend *) + backend *) module Qemu_upstream_compat = Make_qemu_upstream (Config_qemu_upstream_compat) (** Until the stage 4 defined in the qemu upstream design is implemented, - qemu_upstream behaves as qemu_upstream_compat *) + qemu_upstream behaves as qemu_upstream_compat *) module Qemu_upstream = Qemu_upstream_compat module Qemu_upstream_uefi = Make_qemu_upstream (Config_qemu_upstream_uefi) @@ -3663,7 +3657,7 @@ module Dm = struct () (* the following functions depend on the functions above that use the qemu - backend Q *) + backend Q *) let start_vgpu ~xc:_ ~xs task ?(restore = false) domid vgpus vcpus profile = let open Xenops_interface.Vgpu in diff --git a/ocaml/xenopsd/xc/device_common.ml b/ocaml/xenopsd/xc/device_common.ml index 871628aeef5..89d105e0bfc 100644 --- a/ocaml/xenopsd/xc/device_common.ml +++ b/ocaml/xenopsd/xc/device_common.ml @@ -312,7 +312,7 @@ let parse_backend_link x = let readdir ~xs d = try xs.Xs.directory d with Xs_protocol.Enoent _ -> [] -let to_list ys = List.concat (List.map Option.to_list ys) +let to_list ys = List.concat_map Option.to_list ys let list_kinds ~xs dir = to_list (List.map parse_kind (readdir ~xs dir)) @@ -322,88 +322,79 @@ let list_kinds ~xs dir = to_list (List.map parse_kind (readdir ~xs dir)) let list_frontends ~xs ?for_devids domid = let frontend_dir = sprintf "/xenops/domain/%d/device" domid in let kinds = list_kinds ~xs frontend_dir in - List.concat - (List.map - (fun k -> - let dir = sprintf "%s/%s" frontend_dir (string_of_kind k) in - let devids = - match for_devids with - | None -> - to_list (List.map parse_int (readdir ~xs dir)) - | Some devids -> - (* check that any specified devids are present in frontend_dir *) - List.filter - (fun devid -> - try - ignore (xs.Xs.read (sprintf "%s/%d" dir devid)) ; - true - with _ -> false - ) - devids - in - to_list - (List.map + List.concat_map + (fun k -> + let dir = sprintf "%s/%s" frontend_dir (string_of_kind k) in + let devids = + match for_devids with + | None -> + to_list (List.map parse_int (readdir ~xs dir)) + | Some devids -> + (* check that any specified devids are present in frontend_dir *) + List.filter (fun devid -> - (* domain [domid] believes it has a frontend for device [devid] *) - let frontend = {domid; kind= k; devid} in try - let link = xs.Xs.read (sprintf "%s/%d/backend" dir devid) in - match parse_backend_link link with - | Some b -> - Some {backend= b; frontend} - | None -> - None - with _ -> None + ignore (xs.Xs.read (sprintf "%s/%d" dir devid)) ; + true + with _ -> false ) devids + in + to_list + (List.map + (fun devid -> + (* domain [domid] believes it has a frontend for device [devid] *) + let frontend = {domid; kind= k; devid} in + try + let link = xs.Xs.read (sprintf "%s/%d/backend" dir devid) in + match parse_backend_link link with + | Some b -> + Some {backend= b; frontend} + | None -> + None + with _ -> None ) - ) - kinds + devids + ) ) + kinds (* NB: we only read data from the backend directory. Therefore this gives the "backend's point of view". *) let list_backends ~xs domid = let backend_dir = xs.Xs.getdomainpath domid ^ "/backend" in let kinds = list_kinds ~xs backend_dir in - List.concat - (List.map - (fun k -> - let dir = sprintf "%s/%s" backend_dir (string_of_kind k) in - let domids = to_list (List.map parse_int (readdir ~xs dir)) in - List.concat - (List.map - (fun frontend_domid -> - let dir = - sprintf "%s/%s/%d" backend_dir (string_of_kind k) - frontend_domid - in - let devids = to_list (List.map parse_int (readdir ~xs dir)) in - to_list - (List.map - (fun devid -> - (* domain [domid] believes it has a backend for - [frontend_domid] of type [k] with devid [devid] *) - let backend = {domid; kind= k; devid} in - try - let link = - xs.Xs.read (sprintf "%s/%d/frontend" dir devid) - in - match parse_frontend_link link with - | Some f -> - Some {backend; frontend= f} - | None -> - None - with _ -> None - ) - devids - ) - ) - domids - ) - ) - kinds + List.concat_map + (fun k -> + let dir = sprintf "%s/%s" backend_dir (string_of_kind k) in + let domids = to_list (List.map parse_int (readdir ~xs dir)) in + List.concat_map + (fun frontend_domid -> + let dir = + sprintf "%s/%s/%d" backend_dir (string_of_kind k) frontend_domid + in + let devids = to_list (List.map parse_int (readdir ~xs dir)) in + to_list + (List.map + (fun devid -> + (* domain [domid] believes it has a backend for + [frontend_domid] of type [k] with devid [devid] *) + let backend = {domid; kind= k; devid} in + try + let link = xs.Xs.read (sprintf "%s/%d/frontend" dir devid) in + match parse_frontend_link link with + | Some f -> + Some {backend; frontend= f} + | None -> + None + with _ -> None + ) + devids + ) + ) + domids ) + kinds (** Return a list of devices connecting two domains. Ignore those whose kind we don't recognise *) diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index dd3813ff6d9..7b31011aabe 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -1015,12 +1015,11 @@ let xenguest_args_pv ~domid ~store_port ~store_domid ~console_port let xenguest_args_pvh ~domid ~store_port ~store_domid ~console_port ~console_domid ~memory ~kernel ~cmdline ~modules = let module_args = - List.map + List.concat_map (fun (m, c) -> "-module" :: m :: (match c with Some x -> ["-cmdline"; x] | None -> []) ) modules - |> List.flatten in [ "-mode" diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index ee4524cf781..cc201d7f8a1 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -4222,7 +4222,7 @@ module VIF = struct ] ) srvs - |> List.flatten + |> List.concat in ("pvs-site", s) :: ("pvs-interface", iface) From 2f7deb36aca7b829d66dcb866e103b7033b781eb Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 1 Oct 2024 16:25:08 +0100 Subject: [PATCH 2/2] Update .git-blame-ignore-revs Include hash for large-scale replacement of List.flatten and introductions of List.concat_map. Signed-off-by: Colin James --- .git-blame-ignore-revs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs index d8259ca9cd8..06bd08f2e4a 100644 --- a/.git-blame-ignore-revs +++ b/.git-blame-ignore-revs @@ -37,3 +37,6 @@ f43c221ad556bc85870faebc3ce3c9d6e9c2efd8 # strip trailing whitespace 5a003f446391ca05ec791c38c69e93fb1e718e78 + +# prefer concat_map +f1a1ee1c0dc6e228921ebc9e1ac39c2740d649c5