forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
Rewrite gc command for current architecture
- Reads referenced layers from build.jsonl (not old layers JSON)
- Run dirs are now subdirectories, not flat files
- Reports orphaned build layers (--delete-orphans to remove)
- Shows odoc store universe count
- Cleans stale temp dirs, old solutions, old run dirs
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
+110
-90
+110
-90
day11/bin/cmd_gc.ml
+110
-90
day11/bin/cmd_gc.ml
···
2
2
3
3
open Cmdliner
4
4
5
-
let run cache_dir =
5
+
let du cmd =
6
+
try
7
+
let ic = Unix.open_process_in cmd in
8
+
let line = input_line ic in
9
+
ignore (Unix.close_process_in ic);
10
+
String.trim line
11
+
with _ -> "?"
12
+
13
+
let run cache_dir delete_orphans =
6
14
let cache_dir = Common.fpath cache_dir in
7
15
Printf.printf "=== Garbage Collection ===\n\n";
8
-
(* 1. Disk usage overview *)
9
-
let du cmd =
10
-
try
11
-
let ic = Unix.open_process_in cmd in
12
-
let line = input_line ic in
13
-
ignore (Unix.close_process_in ic);
14
-
String.trim line
15
-
with _ -> "?"
16
-
in
17
16
Printf.printf "Disk usage:\n";
18
17
Printf.printf " Cache dir: %s\n"
19
18
(du (Printf.sprintf "du -sh %s 2>/dev/null | cut -f1"
20
19
(Fpath.to_string cache_dir)));
21
20
Printf.printf " Filesystem: %s\n\n"
22
21
(du "df -h . 2>/dev/null | tail -1 | awk '{print $4 \" free of \" $2}'");
23
-
(* 2. Clean stale overlay mounts *)
24
-
let tmp = Filename.get_temp_dir_name () in
25
-
let stale_mounts =
26
-
try Sys.readdir tmp |> Array.to_list
27
-
|> List.filter (fun n ->
28
-
String.length n > 10 && String.sub n 0 10 = "day11_run_")
29
-
with _ -> [] in
30
-
if stale_mounts <> [] then begin
31
-
Printf.printf "Cleaning %d stale overlay mounts...\n%!" (List.length stale_mounts);
32
-
List.iter (fun name ->
33
-
let merged = Filename.concat (Filename.concat tmp name) "merged" in
34
-
ignore (Sys.command (Printf.sprintf "sudo umount %s 2>/dev/null" merged))
35
-
) stale_mounts;
36
-
ignore (Sys.command (Printf.sprintf "sudo rm -rf %s"
37
-
(String.concat " " (List.map (Filename.concat tmp) stale_mounts))));
38
-
Printf.printf " Done.\n\n"
39
-
end;
40
-
(* 3. GC old solution caches — keep the 3 most recent *)
22
+
(* 1. Clean stale temp dirs *)
23
+
let n_stale = Day11_lib.Gc.gc_stale_temp_dirs () in
24
+
if n_stale > 0 then
25
+
Printf.printf "Cleaned %d stale overlay temp dirs\n\n" n_stale;
26
+
(* 2. GC old solution caches — keep the 3 most recent *)
41
27
let solutions_dir = Fpath.(cache_dir / "solutions") in
42
28
(match Bos.OS.Dir.contents solutions_dir with
43
29
| Ok dirs ->
44
30
let dirs = dirs
45
31
|> List.filter (fun p -> Bos.OS.Dir.exists p |> Result.get_ok)
46
32
|> List.sort (fun a b ->
47
-
(* Sort by mtime, newest first *)
48
33
let ma = try (Unix.stat (Fpath.to_string a)).Unix.st_mtime
49
34
with _ -> 0.0 in
50
35
let mb = try (Unix.stat (Fpath.to_string b)).Unix.st_mtime
···
53
38
in
54
39
if List.length dirs > 3 then begin
55
40
let to_delete = List.filteri (fun i _ -> i >= 3) dirs in
56
-
Printf.printf "Solution caches: keeping 3 of %d, deleting %d\n%!"
41
+
Printf.printf "Solution caches: keeping 3 of %d, deleting %d\n"
57
42
(List.length dirs) (List.length to_delete);
58
43
List.iter (fun d ->
59
-
Printf.printf " Deleting %s\n%!" (Fpath.basename d);
44
+
Printf.printf " Deleting %s\n" (Fpath.basename d);
60
45
ignore (Sys.command (Printf.sprintf "rm -rf %s"
61
46
(Fpath.to_string d)))
62
47
) to_delete;
···
65
50
Printf.printf "Solution caches: %d (keeping all)\n\n"
66
51
(List.length dirs)
67
52
| Error _ -> ());
68
-
(* 4. GC old run files — keep last 30 *)
53
+
(* 3. GC old run dirs — keep last 10 *)
69
54
let runs_dir = Fpath.(cache_dir / "runs") in
70
55
(match Bos.OS.Dir.contents runs_dir with
71
-
| Ok files ->
72
-
let files = files
73
-
|> List.filter (fun f -> Fpath.has_ext ".json" f)
56
+
| Ok dirs ->
57
+
let dirs = dirs
58
+
|> List.filter (fun p -> Bos.OS.Dir.exists p |> Result.get_ok)
74
59
|> List.sort (fun a b ->
75
60
compare (Fpath.to_string b) (Fpath.to_string a))
76
61
in
77
-
if List.length files > 30 then begin
78
-
let to_delete = List.filteri (fun i _ -> i >= 30) files in
79
-
Printf.printf "Run files: keeping 30 of %d, deleting %d\n%!"
80
-
(List.length files) (List.length to_delete);
81
-
List.iter (fun f ->
82
-
ignore (Bos.OS.File.delete f)
62
+
if List.length dirs > 10 then begin
63
+
let to_delete = List.filteri (fun i _ -> i >= 10) dirs in
64
+
Printf.printf "Run dirs: keeping 10 of %d, deleting %d\n"
65
+
(List.length dirs) (List.length to_delete);
66
+
List.iter (fun d ->
67
+
ignore (Bos.OS.Path.delete ~recurse:true d)
83
68
) to_delete;
84
69
Printf.printf "\n"
85
70
end else
86
-
Printf.printf "Run files: %d (keeping all)\n\n" (List.length files)
71
+
Printf.printf "Run dirs: %d (keeping all)\n\n" (List.length dirs)
87
72
| Error _ -> ());
88
-
(* 5. GC orphaned build layers *)
89
-
(* Find layers referenced by the latest run *)
90
-
let latest_run =
73
+
(* 4. Find referenced build layers from latest run's build.jsonl *)
74
+
let latest_run_dir =
91
75
match Bos.OS.Dir.contents runs_dir with
92
-
| Ok files ->
93
-
let runs = files
94
-
|> List.filter (fun f -> Fpath.has_ext ".json" f)
95
-
|> List.sort (fun a b ->
96
-
compare (Fpath.to_string b) (Fpath.to_string a))
97
-
in
98
-
(match runs with
99
-
| f :: _ ->
100
-
(try
101
-
let data = In_channel.with_open_text (Fpath.to_string f)
102
-
In_channel.input_all in
103
-
let json = Yojson.Safe.from_string data in
104
-
let open Yojson.Safe.Util in
105
-
let layers = json |> member "layers" |> to_assoc in
106
-
Some (List.map (fun (hash, _) ->
107
-
"build-" ^ String.sub hash 0 12) layers)
108
-
with _ -> None)
109
-
| [] -> None)
76
+
| Ok dirs ->
77
+
dirs
78
+
|> List.filter (fun p -> Bos.OS.Dir.exists p |> Result.get_ok)
79
+
|> List.sort (fun a b ->
80
+
compare (Fpath.to_string b) (Fpath.to_string a))
81
+
|> (function d :: _ -> Some d | [] -> None)
110
82
| Error _ -> None
111
83
in
112
84
(* Find the os_dir *)
···
116
88
List.find_opt (fun p ->
117
89
let name = Fpath.basename p in
118
90
String.length name > 0 &&
119
-
Bos.OS.Dir.exists Fpath.(p / "packages") |> Result.get_ok
91
+
name <> "solutions" && name <> "runs" &&
92
+
name <> "base" && name <> "merged-repo" &&
93
+
not (Fpath.has_ext ".json" p) &&
94
+
Bos.OS.Dir.exists p |> Result.get_ok
120
95
) entries
121
96
| Error _ -> None
122
97
in
123
-
(match os_dir, latest_run with
124
-
| Some os_dir, Some referenced ->
125
-
let referenced_set = Hashtbl.create (List.length referenced) in
126
-
List.iter (fun r -> Hashtbl.replace referenced_set r ()) referenced;
127
-
let all_layers =
128
-
match Bos.OS.Dir.contents os_dir with
129
-
| Ok entries ->
130
-
List.filter (fun p ->
131
-
let name = Fpath.basename p in
132
-
String.starts_with ~prefix:"build-" name &&
133
-
not (Fpath.has_ext ".lock" p) &&
134
-
Bos.OS.Dir.exists p |> Result.get_ok
135
-
) entries
136
-
| Error _ -> []
98
+
(match os_dir, latest_run_dir with
99
+
| Some os_dir, Some run_dir ->
100
+
let os_dir_s = Fpath.to_string os_dir in
101
+
(* Collect referenced layer names from build.jsonl *)
102
+
let build_jsonl = Fpath.(run_dir / "build.jsonl") in
103
+
let referenced =
104
+
if Bos.OS.File.exists build_jsonl |> Result.get_ok then begin
105
+
let ic = open_in (Fpath.to_string build_jsonl) in
106
+
let refs = ref [] in
107
+
(try while true do
108
+
let line = input_line ic in
109
+
try
110
+
let json = Yojson.Safe.from_string line in
111
+
let open Yojson.Safe.Util in
112
+
let hash = json |> member "hash" |> to_string in
113
+
let layer_name = "build-" ^ String.sub hash 0 12 in
114
+
refs := layer_name :: !refs
115
+
with _ -> ()
116
+
done with End_of_file -> close_in ic);
117
+
List.sort_uniq String.compare !refs
118
+
end else []
137
119
in
138
-
let orphans = List.filter (fun p ->
139
-
not (Hashtbl.mem referenced_set (Fpath.basename p))
140
-
) all_layers in
141
-
if orphans <> [] then begin
142
-
Printf.printf "Build layers: %d total, %d referenced, %d orphaned\n%!"
143
-
(List.length all_layers) (List.length referenced) (List.length orphans);
144
-
Printf.printf " Delete orphans? (would free space)\n";
145
-
Printf.printf " Run with --delete-orphans to remove them.\n\n"
120
+
Printf.printf "Build layers referenced in latest run: %d\n"
121
+
(List.length referenced);
122
+
if delete_orphans && referenced <> [] then begin
123
+
let result = Day11_lib.Gc.gc_build_layers ~os_dir:os_dir_s
124
+
~referenced in
125
+
Printf.printf " Total: %d, Kept: %d, Deleted: %d\n\n"
126
+
result.total result.kept result.deleted
127
+
end else if referenced <> [] then begin
128
+
(* Just count orphans *)
129
+
let all_layers =
130
+
try Sys.readdir os_dir_s |> Array.to_list
131
+
|> List.filter (fun n ->
132
+
String.length n > 6 && String.sub n 0 6 = "build-"
133
+
&& not (Filename.check_suffix n ".lock"))
134
+
with _ -> [] in
135
+
let referenced_set = Hashtbl.create (List.length referenced) in
136
+
List.iter (fun r -> Hashtbl.replace referenced_set r ()) referenced;
137
+
let orphans = List.filter (fun n ->
138
+
not (Hashtbl.mem referenced_set n)) all_layers in
139
+
Printf.printf " Total: %d, Referenced: %d, Orphaned: %d\n"
140
+
(List.length all_layers) (List.length referenced)
141
+
(List.length orphans);
142
+
if orphans <> [] then
143
+
Printf.printf " Run with --delete-orphans to remove them.\n\n"
144
+
else
145
+
Printf.printf "\n"
146
146
end else
147
-
Printf.printf "Build layers: %d total, all referenced\n\n"
148
-
(List.length all_layers)
147
+
Printf.printf " No run data to check references.\n\n";
148
+
(* 5. GC odoc store universes *)
149
+
let store_u = Filename.concat os_dir_s "odoc-store/odoc-out/u" in
150
+
if Sys.file_exists store_u then begin
151
+
(* All universes currently in use are referenced *)
152
+
let all_universes =
153
+
try Sys.readdir store_u |> Array.to_list
154
+
|> List.filter (fun n ->
155
+
Sys.is_directory (Filename.concat store_u n))
156
+
with _ -> [] in
157
+
Printf.printf "Odoc store: %d universe hashes in u/\n"
158
+
(List.length all_universes);
159
+
if delete_orphans then begin
160
+
(* For now, keep all — need solution data to determine referenced *)
161
+
Printf.printf " (universe GC requires solution data, skipping)\n\n"
162
+
end else
163
+
Printf.printf "\n"
164
+
end
149
165
| _ ->
150
-
Printf.printf "Build layers: no run data to check references\n\n");
166
+
Printf.printf "No os_dir or run data found.\n\n");
151
167
(* 6. Summary *)
152
168
Printf.printf "Cache dir: %s\n"
153
169
(du (Printf.sprintf "du -sh %s 2>/dev/null | cut -f1"
154
170
(Fpath.to_string cache_dir)));
155
171
0
156
172
173
+
let delete_orphans_term =
174
+
let doc = "Actually delete orphaned layers (default: report only)" in
175
+
Arg.(value & flag & info [ "delete-orphans" ] ~doc)
176
+
157
177
let cmd =
158
178
let info = Cmd.info "gc" ~doc:"Reclaim disk space and clean up" in
159
-
let term = Term.(const run $ Common.cache_dir_term) in
179
+
let term = Term.(const run $ Common.cache_dir_term $ delete_orphans_term) in
160
180
Cmd.v info term