forked from ocaml/dune
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathbootstrap.ml
316 lines (281 loc) · 7.43 KB
/
bootstrap.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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
#warnings "-40";;
#load "unix.cma";;
module Array = ArrayLabels
module List = ListLabels
module String = struct
include StringLabels
include struct
[@@@warning "-3"]
let capitalize_ascii = String.capitalize
let uncapitalize_ascii = String.uncapitalize
end
end
open Printf
module String_set = Set.Make(String)
(* Modules overriden to bootstrap faster *)
let overridden =
String_set.of_list
[ "Glob_lexer"
]
let ( ^/ ) = Filename.concat
let protectx x ~finally ~f =
match f x with
| y -> finally x; y
| exception e -> finally x; raise e
let starts_with s ~prefix =
let plen = String.length prefix in
let slen = String.length s in
slen >= plen && String.sub s ~pos:0 ~len:plen = prefix
let exec fmt =
ksprintf (fun cmd ->
print_endline cmd;
Sys.command cmd)
fmt
let path_sep =
if Sys.win32 then
';'
else
':'
let split_path s =
let rec loop i j =
if j = String.length s then
[String.sub s ~pos:i ~len:(j - i)]
else if s.[j] = path_sep then
String.sub s ~pos:i ~len:(j - i) :: loop (j + 1) (j + 1)
else
loop i (j + 1)
in
loop 0 0
let path =
match Sys.getenv "PATH" with
| exception Not_found -> []
| s -> split_path s
let exe = if Sys.win32 then ".exe" else ""
let prog_not_found prog =
eprintf "Program %s not found in PATH" prog;
exit 2
type mode = Native | Byte
let best_prog dir prog =
let fn = dir ^/ prog ^ ".opt" ^ exe in
if Sys.file_exists fn then
Some fn
else
let fn = dir ^/ prog ^ exe in
if Sys.file_exists fn then
Some fn
else
None
let find_prog prog =
let rec search = function
| [] -> None
| dir :: rest ->
match best_prog dir prog with
| None -> search rest
| Some fn -> Some (dir, fn)
in
search path
let get_prog dir prog =
match best_prog dir prog with
| None -> prog_not_found prog
| Some fn -> fn
let bin_dir, mode, compiler =
match find_prog "ocamlc" with
| None -> prog_not_found "ocamlc"
| Some (bin_dir, prog) ->
match best_prog bin_dir "ocamlopt" with
| Some prog -> (bin_dir, Native, prog)
| None -> (bin_dir, Byte, prog)
let ocamllex = get_prog bin_dir "ocamllex"
let ocamldep = get_prog bin_dir "ocamldep"
let run_ocamllex name =
let src = "src" ^/ name ^ ".mll" in
let dst = "src" ^/ name ^ ".ml" in
let x = Sys.file_exists dst in
let n = exec "%s -q %s" ocamllex src in
if n <> 0 then exit n;
if not x then
at_exit (fun () -> try Sys.remove dst with _ -> ())
let modules =
Sys.readdir "src"
|> Array.fold_left ~init:[] ~f:(fun acc fn ->
match String.rindex fn '.' with
| exception Not_found -> acc
| i ->
let ext = String.sub fn ~pos:(i + 1) ~len:(String.length fn - i - 1) in
match ext with
| "ml" | "mll" ->
let base = String.sub fn ~pos:0 ~len:i in
let mod_name = String.capitalize_ascii base in
if String_set.mem mod_name overridden then
acc
else begin
if ext = "mll" then run_ocamllex base;
String.capitalize_ascii base :: acc
end
| _ ->
acc)
|> String_set.of_list
let split_words s =
let rec skip_blanks i =
if i = String.length s then
[]
else
match s.[i] with
| ' ' | '\t' -> skip_blanks (i + 1)
| _ -> parse_word i (i + 1)
and parse_word i j =
if j = String.length s then
[String.sub s ~pos:i ~len:(j - i)]
else
match s.[j] with
| ' ' | '\t' -> String.sub s ~pos:i ~len:(j - i) :: skip_blanks (j + 1)
| _ -> parse_word i (j + 1)
in
skip_blanks 0
let read_deps files =
let ic =
let cmd =
sprintf "%s -modules %s"
ocamldep (String.concat ~sep:" " files)
in
print_endline cmd;
Unix.open_process_in cmd
in
let rec loop acc =
match input_line ic with
| exception End_of_file ->
ignore (Unix.close_process_in ic);
acc
| line ->
let i = String.index line ':' in
let unit =
String.sub line ~pos:0 ~len:i
|> Filename.basename
|> Filename.chop_extension
|> String.capitalize_ascii
in
let deps =
split_words (String.sub line ~pos:(i + 1)
~len:(String.length line - (i + 1)))
|> List.filter ~f:(fun m -> String_set.mem m modules)
in
loop ((unit, deps) :: acc)
in
loop []
let topsort deps =
let n = List.length deps in
let deps_by_module = Hashtbl.create n in
List.iter deps ~f:(fun (m, deps) ->
Hashtbl.add deps_by_module m deps);
let not_seen = ref (List.map deps ~f:fst |> String_set.of_list) in
let res = ref [] in
let rec loop m =
if String_set.mem m !not_seen then begin
not_seen := String_set.remove m !not_seen;
List.iter (Hashtbl.find deps_by_module m) ~f:loop;
res := m :: !res
end
in
while not (String_set.is_empty !not_seen) do
loop (String_set.choose !not_seen)
done;
List.rev !res
let modules =
let files =
List.map (String_set.elements modules) ~f:(fun unit ->
sprintf "src/%s.ml" (String.uncapitalize_ascii unit))
in
topsort (read_deps files)
let count_newlines s =
let newlines = ref 0 in
String.iter s ~f:(function
| '\n' -> incr newlines
| _ -> ());
!newlines
let read_file fn =
let ic = open_in fn in
let data = really_input_string ic (in_channel_length ic) in
close_in ic;
data
let generated_file = "boot.ml"
let generate_file_with_all_the_sources () =
let oc = open_out generated_file in
let pos_in_generated_file = ref 1 in
let pr fmt =
ksprintf (fun s ->
output_string oc s;
output_char oc '\n';
incr pos_in_generated_file)
fmt
in
let dump fn =
let s = read_file fn in
pr "# 1 %S" fn;
output_string oc s;
let newlines = count_newlines s in
let newlines =
if s <> "" && s.[String.length s - 1] <> '\n' then begin
output_char oc '\n';
newlines + 1
end else
newlines
in
pos_in_generated_file := !pos_in_generated_file + newlines;
pr "# %d %S" (!pos_in_generated_file + 1) generated_file
in
let s = {|
module Jbuilder_re = struct
module Re = struct
type t = unit
type re = unit
let compile () = ()
let execp _ _ = false
end
end
module Glob_lexer = struct
let parse_string _ = failwith "globs are not available during bootstrap"
end
|}
in
output_string oc s;
pos_in_generated_file := !pos_in_generated_file + count_newlines s;
List.iter modules ~f:(fun m ->
let base = String.uncapitalize_ascii m in
let mli = sprintf "src/%s.mli" base in
let ml = sprintf "src/%s.ml" base in
if Sys.file_exists mli then begin
pr "module %s : sig" m;
dump mli;
pr "end = struct";
dump ml;
pr "end"
end else begin
pr "module %s = struct" m;
dump ml;
pr "end"
end);
output_string oc "let () = Main.bootstrap ()\n";
close_out oc
let () = generate_file_with_all_the_sources ()
let cleanup ~keep_ml_file =
try
Array.iter (Sys.readdir ".") ~f:(fun fn ->
if fn <> "boot.exe" &&
starts_with fn ~prefix:"boot." &&
(fn <> "boot.ml" || not keep_ml_file) then
Sys.remove fn)
with _ ->
()
let () =
let lib_ext =
match mode with
| Native -> "cmxa"
| Byte -> "cma"
in
let n =
match exec "%s -w -40 -o boot.exe unix.%s %s" compiler lib_ext generated_file with
| n -> n
| exception e -> cleanup ~keep_ml_file:true; raise e
in
cleanup ~keep_ml_file:(n <> 0);
if n <> 0 then exit n