Source file `primus_round_robin_main.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
open Core_kernel[@@warning "-D"]
open Bap.Std
open Monads.Std
open Bap_primus.Std
open Format
include Self()

module Mid = Monad.State.Multi.Id

type t = {
  pending : Mid.t Fqueue.t;
  finished : Mid.Set.t
}

let state = Primus.Machine.State.declare
    ~uuid:"d1b33e16-bf5d-48d5-a174-3901dff3d123"
    ~name:"round-robin-scheduler"
    (fun _ -> {
         pending = Fqueue.empty;
         finished = Mid.Set.empty;
       })


module RR(Machine : Primus.Machine.S) = struct
  open Machine.Syntax



  let rec schedule t = match Fqueue.dequeue t.pending with
    | None ->
      Machine.forks () >>| Seq.filter ~f:(fun id ->
          not (Set.mem t.finished id)) >>= fun fs ->
      if Seq.is_empty fs
      then Machine.return ()
      else schedule {
          t with
          pending = Seq.fold fs ~init:Fqueue.empty ~f:Fqueue.enqueue
        }
    | Some (next,pending) ->
      Machine.status next >>= function
      | `Dead ->
        schedule {pending; finished = Set.add t.finished next}
      | _ ->
        Machine.Global.put state {t with pending} >>= fun () ->
        Machine.switch next >>= fun () ->
        Machine.Global.get state >>= schedule

  let step _ =
    Machine.Global.get state >>= schedule

  let finish () =
    Machine.current () >>= fun id ->
    Machine.Global.update state ~f:(fun t ->
        {t with finished = Set.add t.finished id}) >>= fun () ->
    step ()


  let init () =
    Machine.sequence [
      Primus.Interpreter.leave_blk >>> step;
      Primus.System.fini >>> finish;
    ]
end

let register enabled =
  if enabled
  then Primus.Machine.add_component (module RR) [@warning "-D"];
  Primus.Components.register_generic "round-robin-scheduler" (module RR)
    ~package:"bap"
    ~desc:"Enables the round-robin scheduler (experimental)."

open Config;;
manpage [
  `S "DESCRIPTION";

  `P
    "The round-robin scheduler will try to distribute machine time
    equally between competing clones. The state tree will be traversed
    in an order that is close to the bread-first search order";

  `P
    "The round-robin scheduler will switch the context after each basic block."
];;

let enabled = flag "scheduler" ~doc:"Enable the scheduler."


let () = when_ready (fun {get=(!!)} -> register !!enabled)