Source file b0_build.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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
(*---------------------------------------------------------------------------
   Copyright (c) 2020 The b0 programmers. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

open B0_std
open B0_std.Fut.Syntax

type b0_unit = B0_defs.b0_unit
type b0_unit_set = B0_defs.Unit.Set.t

include B0_defs.Build_def

let memo b = b.u.m

(* Units *)

let must_build b = b.b.must_build
let may_build b = b.b.may_build
let current b = match b.u.current with
| None -> invalid_arg "Build not running" | Some u -> u

let require_unit b u =
  if String.Map.mem (B0_defs.Unit.name u) b.b.requested then () else
  match B0_defs.Unit.Set.mem u b.b.may_build with
  | true ->
      b.b.requested <- String.Map.add (B0_defs.Unit.name u) u b.b.requested;
      B0_random_queue.add b.b.waiting u
  | false ->
      B0_memo.fail b.u.m
        "@[<v>Unit %a requested %a which is not part of the build.@,\
         Try with %a or add the unit %a to the build."
        B0_defs.Unit.pp_name (current b)
        B0_defs.Unit.pp_name u Fmt.code "--unlock"
        B0_defs.Unit.pp_name u

let require_units b us = List.iter (require_unit b) us
let current_meta b = B0_defs.Unit.meta (current b)

(* Directories *)

module B0_dir = struct
  let build_dir ~b0_dir ~variant = Fpath.(b0_dir / "b" / variant)

  let default_build_dir ~b0_dir =
    (* FIXME this is hardcoded. In the future we likely want to
       read it from a file or symlink *)
    Ok (build_dir ~b0_dir ~variant:"user")

  let log_file ~build_dir =
    Fpath.(build_dir / B0_memo_cli.Log.filename)

  let shared_build_dir ~build_dir = Fpath.(build_dir / "_shared")
  let store_dir ~build_dir = Fpath.(build_dir / "_store")
  let unit_build_dir ~build_dir ~name = Fpath.(build_dir / name)
  let scratch_dir ~b0_dir = Fpath.(b0_dir / "_scratch")
end

let unit_dir b u =
  B0_dir.unit_build_dir ~build_dir:b.b.build_dir ~name:(B0_defs.Unit.name u)

let unit_scope_dir b u = match B0_def.scope_dir (B0_defs.Unit.def u) with
| None -> b.b.root_dir
| Some dir -> dir

let current_dir b = unit_dir b (current b)
let scope_dir b = unit_scope_dir b (current b)
let shared_dir b = b.b.shared_dir

let in_unit_dir b u p = Fpath.(unit_dir b u // p)
let in_unit_scope_dir b u p = Fpath.(unit_scope_dir b u // p)
let in_current_dir b p = Fpath.(current_dir b // p)
let in_scope_dir b p = Fpath.(scope_dir b // p)
let in_shared_dir b p = Fpath.(b.b.shared_dir // p)

(* Store *)

let self =
  B0_store.key @@ fun _ ->
  failwith "B0_build.self was not set at store creation"

let store b = b.b.store
let get b k = B0_store.get b.b.store k

(* Create *)

let make ~root_dir ~b0_dir ~variant ~store m ~may_build ~must_build =
  let u = { current = None; m } in
  let build_dir = B0_dir.build_dir ~b0_dir ~variant in
  let shared_dir = B0_dir.shared_build_dir ~build_dir in
  let store = B0_store.make m ~dir:(B0_dir.store_dir ~build_dir) store in
  let may_build = B0_defs.Unit.Set.union may_build must_build in
  let add_requested u acc = String.Map.add (B0_defs.Unit.name u) u acc in
  let requested =
    B0_defs.Unit.Set.fold add_requested must_build String.Map.empty
  in
  let waiting =
    let q = B0_random_queue.empty () in
    B0_defs.Unit.Set.iter (B0_random_queue.add q) must_build; q
  in
  let b =
    { root_dir; b0_dir; build_dir; shared_dir; store; must_build;
      may_build; requested; waiting; }
  in
  let b = { u; b } in
  B0_store.set store self b;
  b

(* Run *)

let run_unit b unit =
  let m = B0_memo.with_mark b.u.m (B0_defs.Unit.name unit) in
  let u = { current = Some unit; m } in
  let b = { b with u } in
  B0_memo.run_proc m begin fun () ->
    let* () = B0_memo.mkdir b.u.m (unit_dir b unit) in
    (B0_defs.unit_build_proc unit) b
  end

let rec run_units b = match B0_random_queue.take b.b.waiting with
| Some u -> run_unit b u; run_units b
| None ->
    B0_memo.stir ~block:true b.u.m;
    if B0_random_queue.length b.b.waiting = 0 then () else run_units b

let write_log_file ~log_file m =
  Log.if_error ~use:() @@ B0_memo_log.(write log_file (of_memo m))

let report_memo_errors ppf m = match B0_memo.status m with
| Ok _ as v -> v
| Error e ->
    let read_howto = Fmt.any "b0 log -r " in
    let write_howto = Fmt.any "b0 log -w " in
    B0_zero_conv.Op.pp_aggregate_error ~read_howto ~write_howto () ppf e;
    Error ()

let run b =
  let log_file =
    (* FIXME we likely want to surface that at the API level. Either
         at create or run *)
    B0_dir.log_file ~build_dir:b.b.build_dir
  in
  let hook () = write_log_file ~log_file b.u.m in
  Os.Exit.on_sigint ~hook @@ fun () ->
  begin
    B0_memo.run_proc b.u.m begin fun () ->
      let* () = B0_memo.delete b.u.m b.b.build_dir in
      let* () = B0_memo.mkdir b.u.m b.b.build_dir in
      let* () = B0_memo.mkdir b.u.m (B0_store.dir b.b.store) in
      run_units b; Fut.return ()
    end;
    B0_memo.stir ~block:true b.u.m;
    let ret = report_memo_errors Fmt.stderr b.u.m in
    Log.time (fun _ m -> m "deleting trash") begin fun () ->
      Log.if_error ~use:() (B0_memo.delete_trash ~block:false b.u.m)
    end;
    write_log_file ~log_file b.u.m;
    ret
  end

let did_build b =
  String.Map.fold (fun _ u acc -> B0_defs.Unit.Set.add u acc)
    b.b.requested B0_defs.Unit.Set.empty