| @@ -0,0 +1,374 @@ |
| 1 | +module S = Split.Split |
| 2 | + |
| 3 | +let numbers = |
| 4 | + let xs = Array.make 4097 S.Zero_nat in |
| 5 | + for i = 1 to 4096 do xs.(i) <- S.Suc xs.(i - 1) done; |
| 6 | + xs |
| 7 | + |
| 8 | +let nat n = numbers.(n) |
| 9 | + |
| 10 | +let integer n = |
| 11 | + let rec count acc = function |
| 12 | + | S.Zero_nat -> acc |
| 13 | + | S.Suc n -> count (acc + 1) n |
| 14 | + in |
| 15 | + count 0 n |
| 16 | + |
| 17 | +let require ok message = if not ok then failwith message |
| 18 | +let read s k offset = integer (S.read_byte s (nat k) (nat offset)) |
| 19 | +let step capacity s a = S.checked (nat 8) (nat 4096) (nat capacity) s a |
| 20 | + |
| 21 | +type document = { fields : string array; values : string array } |
| 22 | + |
| 23 | +type guest = { |
| 24 | + pid : int; |
| 25 | + input : in_channel; |
| 26 | + output : out_channel; |
| 27 | + serial : out_channel; |
| 28 | + original : document; |
| 29 | + mutable state : unit S.pager_ext; |
| 30 | + mutable frames : int array; |
| 31 | + mutable available : S.nat list; |
| 32 | + mutable tracing : bool; |
| 33 | +} |
| 34 | + |
| 35 | +let names = [|"draft"; "review"; "original"|] |
| 36 | + |
| 37 | +let index xs name = |
| 38 | + let rec find i = |
| 39 | + if i = Array.length xs then invalid_arg ("unknown name " ^ name) |
| 40 | + else if xs.(i) = name then i else find (i + 1) |
| 41 | + in |
| 42 | + find 0 |
| 43 | + |
| 44 | +let text value = |
| 45 | + if String.length value > 255 then invalid_arg "a field can contain at most 255 bytes"; |
| 46 | + String.iter (fun c -> if Char.code c < 32 || Char.code c > 126 then |
| 47 | + invalid_arg "fields must contain printable ASCII text") value |
| 48 | + |
| 49 | +let load path = |
| 50 | + let input = open_in path in |
| 51 | + let entries = Fun.protect ~finally:(fun () -> close_in input) (fun () -> |
| 52 | + let rec collect acc = |
| 53 | + match input_line input with |
| 54 | + | exception End_of_file -> List.rev acc |
| 55 | + | line when String.trim line = "" -> collect acc |
| 56 | + | line -> |
| 57 | + let at = match String.index_opt line '=' with |
| 58 | + | Some at -> at |
| 59 | + | None -> invalid_arg "expected a key followed by an equals sign and a value" |
| 60 | + in |
| 61 | + let name = String.trim (String.sub line 0 at) in |
| 62 | + let value = String.trim (String.sub line (at + 1) (String.length line - at - 1)) in |
| 63 | + require (name <> "" && not (String.contains name ' ')) "keys must be single words"; |
| 64 | + require (not (List.mem_assoc name acc)) ("duplicate field " ^ name); |
| 65 | + text value; |
| 66 | + collect ((name, value) :: acc) |
| 67 | + in |
| 68 | + collect []) in |
| 69 | + require (List.length entries = 4) "a document requires exactly four fields"; |
| 70 | + {fields = Array.of_list (List.map fst entries); values = Array.of_list (List.map snd entries)} |
| 71 | + |
| 72 | +let close g = |
| 73 | + (try Unix.kill g.pid Sys.sigterm with Unix.Unix_error (Unix.ESRCH, _, _) -> ()); |
| 74 | + ignore (Unix.waitpid [] g.pid); |
| 75 | + close_in_noerr g.input; |
| 76 | + close_out_noerr g.output; |
| 77 | + close_out_noerr g.serial |
| 78 | + |
| 79 | +let event g line = |
| 80 | + match String.split_on_char ' ' line with |
| 81 | + | ["SPLIT"; operation; c] when operation = "STOP" || operation = "RUN" -> |
| 82 | + let c = int_of_string c in |
| 83 | + require (c >= 0 && c < 2) "invalid worker lifecycle"; |
| 84 | + if g.tracing then Printf.printf "%s %s TCB\n" |
| 85 | + (if operation = "STOP" then "Suspend" else "Resume ") (String.capitalize_ascii names.(c)) |
| 86 | + | ["SPLIT"; "RELEASE"; k; f; old; source; cleared] -> |
| 87 | + let k, f = int_of_string k, int_of_string f in |
| 88 | + require (k >= 0 && k < 8 && integer (S.ptable g.state (nat k)) = f) |
| 89 | + "released frame mismatch"; |
| 90 | + require (int_of_string cleared = 4096) "incomplete frame scrub"; |
| 91 | + let state, available = match S.reclaim (nat 4) (nat 8) g.state g.available (nat k) with |
| 92 | + | Some result -> result |
| 93 | + | None -> failwith "model rejected frame reclamation" |
| 94 | + in |
| 95 | + g.state <- state; g.available <- available; |
| 96 | + if g.tracing then begin |
| 97 | + Printf.printf "Unmap VA 0x%08x PA 0x%08x\n" (0x40000000 + k mod 4 * 4096) (int_of_string old); |
| 98 | + Printf.printf "Restore VA 0x%08x -> PA 0x%08x Rights R--\n" |
| 99 | + (0x40000000 + k mod 4 * 4096) (int_of_string source); |
| 100 | + Printf.printf "Scrub PA 0x%08x Readback 4096 zero bytes\n" (int_of_string old); |
| 101 | + Printf.printf "Release Frame %d -> Reclaimed pool\n" f |
| 102 | + end |
| 103 | + | ["SPLIT"; "FAULT"; k; address; ip; fsr; source; target] -> |
| 104 | + let k, address, ip, fsr, source, target = int_of_string k, int_of_string address, |
| 105 | + int_of_string ip, int_of_string fsr, int_of_string source, int_of_string target in |
| 106 | + require (k >= 0 && k < 8 && ip > 0 && ip land 3 = 0 && fsr land 64 <> 0) |
| 107 | + "invalid write fault metadata"; |
| 108 | + require (address land (lnot 4095) = 0x40000000 + k mod 4 * 4096) |
| 109 | + "fault address does not match its slot"; |
| 110 | + require (source <> target && source land 4095 = 0 && target land 4095 = 0) |
| 111 | + "invalid physical copy frames"; |
| 112 | + if g.tracing then begin |
| 113 | + Printf.printf "VMFault %-6s VA 0x%08x IP 0x%08x FSR 0x%08x\n" |
| 114 | + (String.capitalize_ascii names.(k / 4)) address ip fsr; |
| 115 | + Printf.printf "Copy PA 0x%08x -> PA 0x%08x Bytes 4096\n" source target; |
| 116 | + Printf.printf "Remap VA 0x%08x -> PA 0x%08x Rights RW-\n" (address land (lnot 4095)) target; |
| 117 | + Printf.printf "Retry IP 0x%08x\n" ip |
| 118 | + end |
| 119 | + | ["SPLIT"; "COPY"; k; source; fresh] -> |
| 120 | + let k, source, fresh = int_of_string k, int_of_string source, int_of_string fresh in |
| 121 | + require (k >= 0 && k < 8 && fresh < 12) "invalid page copy"; |
| 122 | + require (not (S.writable g.state (nat k))) "duplicate page copy"; |
| 123 | + require (integer (S.ptable g.state (nat k)) = source) "copy source mismatch"; |
| 124 | + let recycled = g.available <> [] in |
| 125 | + let state, available = match S.reserve (nat 4) (nat 8) (nat 12) g.state g.available (nat k) with |
| 126 | + | Some result -> result |
| 127 | + | None -> failwith "model rejected frame allocation" |
| 128 | + in |
| 129 | + require (integer (S.ptable state (nat k)) = fresh) "allocation mismatch"; |
| 130 | + g.state <- state; g.available <- available; |
| 131 | + if g.tracing && recycled then Printf.printf "Acquire Frame %d <- Reclaimed pool\n" fresh |
| 132 | + | "SPLIT" :: "TABLE" :: frames -> |
| 133 | + require (List.length frames = 8) "invalid page table"; |
| 134 | + g.frames <- Array.of_list (List.map int_of_string frames); |
| 135 | + Array.iteri (fun k f -> require (integer (S.ptable g.state (nat k)) = f) |
| 136 | + "page table differs from model") g.frames |
| 137 | + | ["SPLIT"; operation; k; offset; byte] when operation = "R" || operation = "W" -> |
| 138 | + let k, offset, byte = int_of_string k, int_of_string offset, int_of_string byte in |
| 139 | + require (k >= 0 && k < 8 && offset >= 0 && offset < 4096 && byte >= 0 && byte < 256) |
| 140 | + "invalid memory observation"; |
| 141 | + if operation = "W" then begin |
| 142 | + require (S.writable g.state (nat k)) "write reached a shared page"; |
| 143 | + g.state <- Option.get (step 12 g.state (S.Write (nat k, nat offset, nat byte))) |
| 144 | + end; |
| 145 | + require (read g.state k offset = byte) "guest memory differs from model"; |
| 146 | + if g.tracing && operation = "W" && (offset = 0 || byte = 0) then |
| 147 | + Printf.printf "Store %-6s VA 0x%08x Byte 0x%02x\n" |
| 148 | + (String.capitalize_ascii names.(k / 4)) (0x40000000 + k mod 4 * 4096 + offset) byte |
| 149 | + | _ -> () |
| 150 | + |
| 151 | +let receive g expected = |
| 152 | + let handler = Sys.signal Sys.sigalrm (Sys.Signal_handle (fun _ -> failwith "guest did not respond")) in |
| 153 | + ignore (Unix.alarm 10); |
| 154 | + Fun.protect ~finally:(fun () -> ignore (Unix.alarm 0); Sys.set_signal Sys.sigalrm handler) (fun () -> |
| 155 | + let rec collect acc = |
| 156 | + let raw = input_line g.input in |
| 157 | + let line = if String.ends_with ~suffix:"\r" raw then String.sub raw 0 (String.length raw - 1) else raw in |
| 158 | + output_string g.serial (line ^ "\n"); |
| 159 | + event g line; |
| 160 | + if String.starts_with ~prefix:"@error " line then failwith (String.sub line 7 (String.length line - 7)); |
| 161 | + if line = expected then List.rev acc |
| 162 | + else collect (if String.starts_with ~prefix:"@" line then line :: acc else acc) |
| 163 | + in |
| 164 | + collect []) |
| 165 | + |
| 166 | +let request g line = |
| 167 | + output_string g.output (line ^ "\n"); |
| 168 | + flush g.output; |
| 169 | + receive g "@done" |
| 170 | + |
| 171 | +let launch image original = |
| 172 | + let child_input, writer = Unix.pipe () in |
| 173 | + let reader, child_output = Unix.pipe () in |
| 174 | + Unix.set_close_on_exec reader; |
| 175 | + Unix.set_close_on_exec writer; |
| 176 | + let args = [|"qemu-system-aarch64"; "-machine"; "virt,virtualization=on"; |
| 177 | + "-cpu"; "cortex-a53"; "-m"; "2G"; "-nographic"; "-monitor"; "none"; |
| 178 | + "-serial"; "stdio"; "-device"; "loader,file=" ^ image ^ ",addr=0x70000000,cpu-num=0"|] in |
| 179 | + let pid = Unix.create_process args.(0) args child_input child_output child_output in |
| 180 | + Unix.close child_input; |
| 181 | + Unix.close child_output; |
| 182 | + let contents f offset = |
| 183 | + let f, offset = integer f, integer offset in |
| 184 | + nat (if f < 4 && offset < String.length original.values.(f) then Char.code original.values.(f).[offset] else 0) |
| 185 | + in |
| 186 | + let g = {pid; input = Unix.in_channel_of_descr reader; output = Unix.out_channel_of_descr writer; |
| 187 | + serial = open_out "build/live.log"; original; state = S.initial (nat 4) contents; |
| 188 | + frames = Array.init 8 (fun k -> k mod 4); available = []; tracing = false} in |
| 189 | + try |
| 190 | + ignore (receive g "@ready"); |
| 191 | + Array.iteri (fun p value -> ignore (request g (Printf.sprintf "B %d %s" p value))) original.values; |
| 192 | + ignore (request g "S"); |
| 193 | + g |
| 194 | + with exn -> close g; raise exn |
| 195 | + |
| 196 | +let query g target = |
| 197 | + let values = Array.make 4 "" and seen = Array.make 4 false in |
| 198 | + List.iter (fun line -> |
| 199 | + require (String.length line >= 8) "incomplete document response"; |
| 200 | + let p = Char.code line.[7] - Char.code '0' in |
| 201 | + require (p >= 0 && p < 4 && not seen.(p)) "invalid document response"; |
| 202 | + values.(p) <- if String.length line > 8 then String.sub line 9 (String.length line - 9) else ""; |
| 203 | + seen.(p) <- true) (request g (Printf.sprintf "Q %d" target)); |
| 204 | + require (Array.for_all Fun.id seen) "incomplete document"; |
| 205 | + if target = 2 then require (values = g.original.values) "original document changed"; |
| 206 | + values |
| 207 | + |
| 208 | +let edit g target field value = |
| 209 | + if target = 2 then invalid_arg "the original is read-only"; |
| 210 | + text value; |
| 211 | + ignore (request g (Printf.sprintf "E %d %d %s" target field value)) |
| 212 | + |
| 213 | +let save path document = |
| 214 | + let output = open_out path in |
| 215 | + Fun.protect ~finally:(fun () -> close_out output) (fun () -> |
| 216 | + Array.iteri (fun i value -> Printf.fprintf output "%s = %s\n" document.fields.(i) value) document.values) |
| 217 | + |
| 218 | +let memory g = |
| 219 | + ignore (request g "M"); |
| 220 | + print_endline "Original: 4 read-only source pages"; |
| 221 | + Printf.printf "%-12s %14s %14s\n" "Snapshot" "Private pages" "Shared pages"; |
| 222 | + for c = 0 to 1 do |
| 223 | + let private_pages = ref 0 in |
| 224 | + for p = 0 to 3 do if g.frames.(c * 4 + p) >= 4 then incr private_pages done; |
| 225 | + Printf.printf "%-12s %14d %14d\n" (String.capitalize_ascii names.(c)) !private_pages (4 - !private_pages) |
| 226 | + done; |
| 227 | + let copies = integer (S.frontier g.state) - 4 - List.length g.available in |
| 228 | + Printf.printf "Copy pool: %d used, %d reserved pages available\n" copies (8 - copies) |
| 229 | + |
| 230 | +let discard g target = |
| 231 | + if target = 2 then invalid_arg "the original is read-only"; |
| 232 | + ignore (request g (Printf.sprintf "D %d" target)); |
| 233 | + require (query g target = g.original.values) "discard did not restore original" |
| 234 | + |
| 235 | +let pool g = |
| 236 | + let remaining = ref g.available and count = ref 0 and samples = ref 0 in |
| 237 | + List.iter (fun line -> match String.split_on_char ' ' line with |
| 238 | + | ["@free"; f; pa; cleared] -> |
| 239 | + let f = int_of_string f in |
| 240 | + require (int_of_string cleared = 4096) "returned frame contains data"; |
| 241 | + (match !remaining with |
| 242 | + | head :: tail when integer head = f -> remaining := tail |
| 243 | + | _ -> failwith "returned pool differs from model"); |
| 244 | + incr count; |
| 245 | + Printf.printf "Frame %d PA 0x%08x Unmapped from clients 4096 zero bytes\n" f (int_of_string pa) |
| 246 | + | ["@zero"; f; offset; byte] -> |
| 247 | + let f, offset, byte = int_of_string f, int_of_string offset, int_of_string byte in |
| 248 | + require (List.exists (fun n -> integer n = f) g.available && offset = !samples mod 32 && byte = 0) |
| 249 | + "returned frame sample mismatch"; |
| 250 | + incr samples; |
| 251 | + if offset mod 16 = 0 then Printf.printf " %04x " offset; |
| 252 | + Printf.printf "%02x " byte; |
| 253 | + if offset mod 16 = 15 then print_newline () |
| 254 | + | _ -> failwith "invalid pool response") (request g "F"); |
| 255 | + require (!remaining = [] && !samples = !count * 32) "incomplete pool response"; |
| 256 | + if !count = 0 then print_endline "Reclaimed pool empty" |
| 257 | + |
| 258 | +let mappings g = |
| 259 | + print_endline "Snapshot Virtual address Physical address Rights"; |
| 260 | + List.iter (fun line -> match String.split_on_char ' ' line with |
| 261 | + | ["@map"; k; address; physical; writable] -> |
| 262 | + let k = int_of_string k in |
| 263 | + require ((g.frames.(k) >= 4) = (writable = "1")) "mapping rights mismatch"; |
| 264 | + Printf.printf "%-8s 0x%08x 0x%08x %s\n" |
| 265 | + (String.capitalize_ascii names.(k / 4)) (int_of_string address) |
| 266 | + (int_of_string physical) (if writable = "1" then "RW-" else "R--") |
| 267 | + | _ -> failwith "invalid mapping response") (request g "P") |
| 268 | + |
| 269 | +let peek g target field = |
| 270 | + let address = ref 0 and physical = ref 0 and seen = Array.make 64 false in |
| 271 | + let bytes = Array.make 64 0 in |
| 272 | + List.iter (fun line -> match String.split_on_char ' ' line with |
| 273 | + | ["@addr"; va; pa] -> address := int_of_string va; physical := int_of_string pa |
| 274 | + | ["@byte"; offset; byte] -> |
| 275 | + let offset, byte = int_of_string offset, int_of_string byte in |
| 276 | + require (offset >= 0 && offset < 64 && byte >= 0 && byte < 256) "invalid byte response"; |
| 277 | + let expected = if target < 2 then read g.state (target * 4 + field) offset |
| 278 | + else if offset < String.length g.original.values.(field) then Char.code g.original.values.(field).[offset] else 0 in |
| 279 | + require (byte = expected) "memory dump differs from model"; |
| 280 | + seen.(offset) <- true; bytes.(offset) <- byte |
| 281 | + | _ -> failwith "invalid memory response") (request g (Printf.sprintf "H %d %d" target field)); |
| 282 | + require (Array.for_all Fun.id seen) "incomplete memory response"; |
| 283 | + Printf.printf "%s %s VA 0x%08x PA 0x%08x\n" (String.capitalize_ascii names.(target)) |
| 284 | + (String.capitalize_ascii g.original.fields.(field)) !address !physical; |
| 285 | + for row = 0 to 3 do |
| 286 | + Printf.printf "%08x " (!address + row * 16); |
| 287 | + for i = 0 to 15 do Printf.printf "%02x " bytes.(row * 16 + i) done; |
| 288 | + print_string " "; |
| 289 | + for i = 0 to 15 do |
| 290 | + let byte = bytes.(row * 16 + i) in |
| 291 | + print_char (if byte >= 32 && byte < 127 then Char.chr byte else '.') |
| 292 | + done; |
| 293 | + print_newline () |
| 294 | + done |
| 295 | + |
| 296 | +let edit_value line = |
| 297 | + let size = String.length line in |
| 298 | + let rec spaces i = if i < size && line.[i] = ' ' then spaces (i + 1) else i in |
| 299 | + let rec words i remaining = |
| 300 | + if remaining = 0 then String.sub line i (size - i) |
| 301 | + else match String.index_from_opt line (spaces i) ' ' with |
| 302 | + | None -> "" |
| 303 | + | Some at -> words (spaces at) (remaining - 1) |
| 304 | + in |
| 305 | + words 0 3 |
| 306 | + |
| 307 | +let work image path = |
| 308 | + let original = load path in |
| 309 | + let g = launch image original in |
| 310 | + Fun.protect ~finally:(fun () -> close g) (fun () -> |
| 311 | + print_endline "Split Configuration Snapshots"; |
| 312 | + print_endline "seL4 guest running on AArch64"; |
| 313 | + print_endline ("Opened " ^ path ^ ". Draft and Review share the original pages."); |
| 314 | + print_endline "Commands: show, edit, discard, diff, maps, peek, pool, trace, memory, save, quit"; |
| 315 | + let running = ref true in |
| 316 | + while !running do |
| 317 | + print_string "$ "; flush stdout; |
| 318 | + match input_line stdin with |
| 319 | + | exception End_of_file -> running := false |
| 320 | + | line -> |
| 321 | + try |
| 322 | + match String.split_on_char ' ' (String.trim line) |> List.filter ((<>) "") with |
| 323 | + | [] -> () |
| 324 | + | ["quit"] -> running := false |
| 325 | + | ["clear"] -> print_string "\027[2J\027[H" |
| 326 | + | ["trace"; "on"] -> g.tracing <- true; print_endline "Live VM trace enabled" |
| 327 | + | ["trace"; "off"] -> g.tracing <- false; print_endline "Live VM trace disabled" |
| 328 | + | ["maps"] -> mappings g |
| 329 | + | ["pool"] -> pool g |
| 330 | + | ["discard"; name] -> |
| 331 | + discard g (index names name); |
| 332 | + print_endline ("Discarded " ^ String.capitalize_ascii name ^ " edits. Original mappings restored.") |
| 333 | + | ["peek"; name; field] -> peek g (index names name) (index original.fields field) |
| 334 | + | ["show"; name] -> |
| 335 | + let values = query g (index names name) in |
| 336 | + print_endline (String.capitalize_ascii name ^ " configuration"); |
| 337 | + Array.iteri (fun i value -> Printf.printf "%-8s %s\n" (String.capitalize_ascii original.fields.(i)) value) values |
| 338 | + | "edit" :: name :: field :: _ -> |
| 339 | + let target = index names name and page = index original.fields field in |
| 340 | + let owned = target < 2 && S.writable g.state (nat (target * 4 + page)) in |
| 341 | + edit g (index names name) (index original.fields field) (edit_value line); |
| 342 | + Printf.printf "Updated %s in %s. %s\n" (String.capitalize_ascii field) |
| 343 | + (String.capitalize_ascii name) |
| 344 | + (if owned then "Reused its private page." else "Copied one shared page.") |
| 345 | + | ["diff"; name] -> |
| 346 | + let values = query g (index names name) and baseline = query g 2 in |
| 347 | + print_endline ("Changes in " ^ String.capitalize_ascii name); |
| 348 | + let changed = ref false in |
| 349 | + Array.iteri (fun i value -> if value <> baseline.(i) then begin |
| 350 | + changed := true; |
| 351 | + Printf.printf "%s\n Original %s\n %-8s %s\n" (String.capitalize_ascii original.fields.(i)) |
| 352 | + baseline.(i) (String.capitalize_ascii name) value |
| 353 | + end) values; |
| 354 | + if not !changed then print_endline "No changes" |
| 355 | + | ["memory"] -> memory g |
| 356 | + | ["save"; name; filename] -> |
| 357 | + save filename {original with values = query g (index names name)}; |
| 358 | + print_endline ("Saved " ^ filename) |
| 359 | + | _ -> print_endline "Use show NAME, edit NAME FIELD TEXT, diff NAME, memory, save NAME FILE, or quit" |
| 360 | + with Invalid_argument message | Sys_error message -> print_endline (String.capitalize_ascii message) |
| 361 | + done) |
| 362 | + |
| 363 | +let () = |
| 364 | + Sys.catch_break true; |
| 365 | + try |
| 366 | + match Array.to_list Sys.argv with |
| 367 | + | [_] | [_; "work"] -> work "build/loader.img" "document" |
| 368 | + | [_; "work"; path] -> work "build/loader.img" path |
| 369 | + | _ -> invalid_arg "usage: check work DOCUMENT" |
| 370 | + with |
| 371 | + | Sys.Break -> print_newline () |
| 372 | + | Failure message | Invalid_argument message | Sys_error message -> |
| 373 | + prerr_endline message; exit 1 |
| 374 | + | exn -> prerr_endline (Printexc.to_string exn); exit 1 |