Mirrors_Framework/paparazzi
1
0
Fork 0
mirror of https://github.com/paparazzi/paparazzi.git synced 2026-06-02 05:17:03 +08:00
Code Issues Actions 29 Packages Projects Releases Wiki Activity

[ocaml] make a clean functional version of topological sort algorithm

Browse Source
This commit is contained in:
Gautier Hattenberger
2021-08-17 12:50:03 +02:00
parent 9fe528ab54
commit cf49ef3303
1 changed files with 79 additions and 74 deletions
Download Patch File Download Diff File Expand all files Collapse all files
sw/lib/ocaml/aircraft.ml
+79 -74
View File
@@ -105,90 +105,95 @@ let target_conf_add_module = fun conf target firmware name mtype load_type ->
(* add "unloaded" module for reference *) (* add "unloaded" module for reference *)
{ conf with modules = conf.modules @ [(Unloaded, m)] } end { conf with modules = conf.modules @ [(Unloaded, m)] } end
type sort_result = {
resolved: (string * (load_type * Module.t)) list; (* modules to load (fully resolved) *)
unresolved: (string * Module.t) list; (* modules no fully resolved (for cycle detection) *)
unloaded: (load_type * Module.t) list; (* modules not loaded for this target / firmware *)
conflicts: (string * string) list; (* modules in conflict *)
required: (GC.bool_expr * string) list; (* functionalities required *)
provided: string list; (* functionalities provided (should contain required) *)
}
let init_sort_result = fun () ->
{ resolved = []; unresolved = []; unloaded = [];
conflicts = []; required = []; provided = []
}
(* topological sort to load modules and their dependencies *) (* topological sort to load modules and their dependencies *)
let resolve_modules_dep = fun config_by_target firmware user_target -> let resolve_modules_dep = fun config_by_target firmware user_target ->
let resolved = ref [] in (* modules to load (fully resolved) *)
let unresolved = ref [] in (* modules no fully resolved (for cycle detection) *)
let unloaded = ref [] in (* modules not loaded for this target / firmware *)
let conflicts = ref [] in (* modules in conflict *)
let required = ref [] in (* functionalities required *)
let provided = ref [] in (* functionalities provided (should contain required) *)
let add_unique = fun l s -> let add_unique = fun l s ->
if List.exists (fun e -> String.compare s e = 0) l then l else l @ [s] if List.exists (fun e -> String.compare s e = 0) l then l else l @ [s]
in in
(* recursive dependency resolution *) (* recursive dependency resolution *)
let rec dep_resolve = fun m target load_type -> let rec dep_resolve = fun sol m target load_type ->
let test_module = fun _m lt -> let test_module = fun s _m lt ->
(* test if module is not in resolved *) (* test if module is not in resolved *)
if not (List.mem_assoc _m.Module.name !resolved) then begin if not (List.mem_assoc _m.Module.name s.resolved) then begin
(* test if module is in unresolved to detect cycles *) (* test if module is in unresolved to detect cycles *)
if List.mem_assoc _m.Module.name !unresolved then if List.mem_assoc _m.Module.name s.unresolved then
failwith ("Error [Aircraft]: cyclic dependency found when loading module "^_m.Module.name); failwith ("Error [Aircraft]: cyclic dependency found when loading module "^_m.Module.name);
(* no cycle, call resolve function recursively *) (* no cycle, call resolve function recursively *)
dep_resolve _m target lt dep_resolve s _m target lt (* returns sol *)
end end else s
in in
let name = m.Module.name in let name = m.Module.name in
(* mark module has unresolved *) (* mark module has unresolved *)
unresolved := !unresolved @ [(name, m)]; let sol = { sol with unresolved = sol.unresolved @ [(name, m)] } in
(* if module should be loaded, look for dependencies *) (* if module should be loaded, look for dependencies *)
if Module.check_loading target firmware m then begin let sol =
match m.Module.dependencies with if Module.check_loading target firmware m then begin
| Some dep -> match m.Module.dependencies with
(* iter over requires *) | Some dep ->
List.iter (fun dep_expr -> (* iter over requires *)
match dep_expr with let sol = List.fold_left (fun s dep_expr ->
| GC.Var dep_name -> match dep_expr with
if Str.string_match (Str.regexp "^@.*") dep_name 0 then | GC.Var dep_name ->
(* add to required list *) if Str.string_match (Str.regexp "^@.*") dep_name 0 then
required := !required @ [(dep_expr, name)] (* add to required list *)
else { s with required = s.required @ [(dep_expr, name)] }
(* get module from name *) else
let _m = Module.from_module_name dep_name None in (* get module from name *)
test_module _m (if name = "root" then UserLoad else Depend) let _m = Module.from_module_name dep_name None in
| _ -> required := !required @ [(dep_expr, name)] (* expression of required modules or functionalities *) test_module s _m (if name = "root" then UserLoad else Depend)
) dep.Module.requires; | _ -> { s with required = s.required @ [(dep_expr, name)] } (* expression of required modules or functionalities *)
(* iter over autoload modules *) ) sol dep.Module.requires in
List.iter (fun autoload -> (* iter over autoload modules *)
let _m = Module.from_module_name autoload.Module.aname autoload.Module.atype in let sol = List.fold_left (fun s autoload ->
test_module _m AutoLoad let _m = Module.from_module_name autoload.Module.aname autoload.Module.atype in
) m.Module.autoloads; test_module s _m AutoLoad
(* add conflicts to list *) ) sol m.Module.autoloads in
conflicts := !conflicts @ (List.map (fun c -> (c, name)) dep.Module.conflicts); (* add conflicts to list *)
(* add provides to list (if not present) *) let sol = { sol with conflicts = sol.conflicts @ (List.map (fun c -> (c, name)) dep.Module.conflicts) } in
provided := List.fold_left add_unique !provided dep.Module.provides; (* add provides to list (if not present) *)
(* all dep and autoload resolved, add to list *) let sol = { sol with provided = List.fold_left add_unique sol.provided dep.Module.provides } in
if not (name = "root") then (* don't add root module *) (* all dep and autoload resolved, add to list *)
resolved := !resolved @ [(name, (load_type, m))] if not (name = "root") then (* don't add root module *)
| None -> { sol with resolved = sol.resolved @ [(name, (load_type, m))] } (* add to list and return solution *)
(* no dep, only check autoload *) else sol (* return current solution *)
List.iter (fun autoload -> | None ->
let _m = Module.from_module_name autoload.Module.aname autoload.Module.atype in (* no dep, only check autoload *)
test_module _m AutoLoad let sol = List.fold_left (fun s autoload ->
) m.Module.autoloads; let _m = Module.from_module_name autoload.Module.aname autoload.Module.atype in
if not (name = "root") then (* don't add root module *) test_module s _m AutoLoad
resolved := !resolved @ [(name, (load_type, m))] (* add to list *) ) sol m.Module.autoloads in
end else begin if not (name = "root") then (* don't add root module *)
(* not adding module, but still add autoloads if target is valid *) { sol with resolved = sol.resolved @ [(name, (load_type, m))] } (* add to list and return solution *)
List.iter (fun autoload -> else sol (* return current solution *)
let _m = Module.from_module_name autoload.Module.aname autoload.Module.atype in end else begin
test_module _m AutoLoad (* not adding module, but still add autoloads if target is valid *)
) m.Module.autoloads; let sol = List.fold_left (fun s autoload ->
(* return resolved but not adding module *) let _m = Module.from_module_name autoload.Module.aname autoload.Module.atype in
unloaded := !unloaded @ [(Unloaded, m)]; test_module s _m AutoLoad
end; ) sol m.Module.autoloads in
(* remove from unresolved list to make search faster *) (* return resolved but not adding module *)
unresolved := List.remove_assoc name !unresolved { sol with unloaded = sol.unloaded @ [(Unloaded, m)] }
end
in
(* remove from unresolved list to make search faster and return current solution *)
{ sol with unresolved = List.remove_assoc name sol.unresolved }
in in
(* iter on all targets *) (* iter on all targets *)
Hashtbl.iter (fun target conf -> Hashtbl.iter (fun target conf ->
(* reset global lists *)
resolved := [];
unresolved := [];
unloaded := [];
conflicts := [];
required := [];
provided := [];
(* check if a board, target or firmware specific module is available *) (* check if a board, target or firmware specific module is available *)
let target_module_name = Env.paparazzi_conf // "modules" // "targets" // target ^ ".xml" in let target_module_name = Env.paparazzi_conf // "modules" // "targets" // target ^ ".xml" in
let target_module = if Sys.file_exists target_module_name then [GC.Var target_module_name] else [] in let target_module = if Sys.file_exists target_module_name then [GC.Var target_module_name] else [] in
@@ -204,7 +209,7 @@ let resolve_modules_dep = fun config_by_target firmware user_target ->
Module.dependencies = Some root_dep; Module.dependencies = Some root_dep;
Module.makefiles = [Module.empty_makefile] Module.makefiles = [Module.empty_makefile]
} in } in
dep_resolve root_module target UserLoad; let solution = dep_resolve (init_sort_result ()) root_module target UserLoad in
(* test for conflicts and required functionalities and option if requested *) (* test for conflicts and required functionalities and option if requested *)
if (not (user_target = "")) && (target = user_target) then begin if (not (user_target = "")) && (target = user_target) then begin
(* check conflicts for resolved modules *) (* check conflicts for resolved modules *)
@@ -212,22 +217,22 @@ let resolve_modules_dep = fun config_by_target firmware user_target ->
List.iter (fun (name, _) -> List.iter (fun (name, _) ->
if name = c then if name = c then
failwith (Printf.sprintf "Error [Aircraft]: find conflict with module '%s' while loading '%s' in target '%s'" cname name target) failwith (Printf.sprintf "Error [Aircraft]: find conflict with module '%s' while loading '%s' in target '%s'" cname name target)
) !resolved; ) solution.resolved;
List.iter (fun name -> List.iter (fun name ->
if name = c then if name = c then
failwith (Printf.sprintf "Error [Aircraft]: find conflict with funcionality while loading '%s' for '%s' in target '%s'" name cname target) failwith (Printf.sprintf "Error [Aircraft]: find conflict with funcionality while loading '%s' for '%s' in target '%s'" name cname target)
) !provided ) solution.provided
) !conflicts; ) solution.conflicts;
(* chek that all required functionalities or modules are provided *) (* chek that all required functionalities or modules are provided *)
List.iter (fun (r, name) -> List.iter (fun (r, name) ->
if not (List.exists (fun p -> GC.eval_bool p r) (!provided @ (fst (List.split !resolved)))) then if not (List.exists (fun p -> GC.eval_bool p r) (solution.provided @ (fst (List.split solution.resolved)))) then
failwith (Printf.sprintf "Error [Aircraft]: functionality '%s' is not provided for '%s' in target '%s'" (GC.sprint_expr r) name target) failwith (Printf.sprintf "Error [Aircraft]: functionality '%s' is not provided for '%s' in target '%s'" (GC.sprint_expr r) name target)
) !required ) solution.required
end; end;
(* add configure, defines and modules to conf for all resolved modules *) (* add configure, defines and modules to conf for all resolved modules *)
let new_conf = List.fold_left (fun c (lt, m) -> let new_conf = List.fold_left (fun c (lt, m) ->
target_conf_add_module_config c target firmware m lt target_conf_add_module_config c target firmware m lt
) { conf with modules = !unloaded } (snd (List.split !resolved)) in ) { conf with modules = solution.unloaded } (snd (List.split solution.resolved)) in
(*let new_conf = { new_conf with modules = new_conf.modules @ !unloaded } in*) (*let new_conf = { new_conf with modules = new_conf.modules @ !unloaded } in*)
Hashtbl.replace config_by_target target new_conf Hashtbl.replace config_by_target target new_conf
) config_by_target ) config_by_target