Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
3.4 kB · 124 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125module M = Merge_queue
type policy = Serial | Admit
type course = { branch : M.Branch.t; arrived_ms : int; started_ms : int; base : int; landed_ms : int; cone : M.Cone.t;}
let ms_of now t = int_of_float (Float.round (Ptime.Span.to_float_s (Ptime.diff t now) *. 1000.))
let at now ms = match Option.bind (Ptime.Span.of_float_s (float_of_int ms /. 1000.)) (Ptime.add_span now) with | Some t -> t | None -> invalid_arg "Sim_queue: time out of range"
type running = { entry : M.Order.entry; started : int; base : int; ends : int }
let run ~duration estimates ~now policy (queue : M.Order.entry list) = let arrived (e : M.Order.entry) = ms_of now e.job.arrived in let length (e : M.Order.entry) = List.fold_left (fun s c -> s + duration c) 0 e.job.ready in let same (a : M.Order.entry) (b : M.Order.entry) = M.Branch.equal a.job.branch b.job.branch in let pending = ref queue in let running = ref [] in let landed = ref [] in let start t (e : M.Order.entry) = pending := List.filter (fun e' -> not (same e e')) !pending; running := !running @ [ { entry = e; started = t; base = List.length !landed; ends = t + length e; }; ] in let admit t = let queued = List.filter (fun e -> arrived e <= t) !pending in match policy with | Serial -> ( if !running = [] then match List.stable_sort (fun a b -> Int.compare (arrived a) (arrived b)) queued with | e :: _ -> start t e | [] -> ()) | Admit -> let names = M.Order.admit estimates ~now:(at now t) ~running:(List.map (fun r -> r.entry.cone) !running) queued in List.iter (fun b -> match List.find_opt (fun (e : M.Order.entry) -> M.Branch.equal e.job.branch b) queued with | Some e -> start t e | None -> failwith "Sim_queue: admitted a land not queued") names in let rec loop t = let ended, still = List.partition (fun r -> r.ends <= t) !running in running := still; List.iter (fun r -> landed := !landed @ [ { branch = r.entry.job.branch; arrived_ms = arrived r.entry; started_ms = r.started; base = r.base; landed_ms = r.ends; cone = r.entry.cone; }; ]) ended; admit t; let next = List.map (fun r -> r.ends) !running @ List.filter (fun a -> a > t) (List.map arrived !pending) in match next with [] -> () | n -> loop (List.fold_left min max_int n) in loop 0; List.map (fun (e : M.Order.entry) -> match List.find_opt (fun l -> M.Branch.equal l.branch e.job.branch) !landed with | Some l -> l | None -> Fmt.failwith "Sim_queue: %a never landed" M.Branch.pp e.job.branch) queue
let lead_ms l = l.landed_ms - l.arrived_ms
let mean_lead_ms ls = List.fold_left (fun s l -> s + lead_ms l) 0 ls / List.length ls
let pp ppf l = Fmt.pf ppf "%a arrived %dms, checked %d-%dms on base %d" M.Branch.pp l.branch l.arrived_ms l.started_ms l.landed_ms l.base