| @@ -18,6 +18,29 @@ let require ok message = if not ok then failwith message |
| 18 | 18 | let read s k offset = integer (S.read_byte s (nat k) (nat offset)) |
| 19 | 19 | let step capacity s a = S.checked (nat 8) (nat 4096) (nat capacity) s a |
| 20 | 20 | |
| 21 | +let selftest () = |
| 22 | + let state = ref S.boot in |
| 23 | + let reference = Array.init 8 (fun k -> Array.init 4096 (fun b -> ((k mod 4) * 17 + b) mod 256)) in |
| 24 | + let random = Random.State.make [|2026; 4; 8|] in |
| 25 | + for i = 0 to 1023 do |
| 26 | + let k = Random.State.int random 8 in |
| 27 | + let offset = if i mod 127 = 0 then 4095 else Random.State.int random 128 in |
| 28 | + let byte = Random.State.int random 256 in |
| 29 | + let action = S.Write (nat k, nat offset, nat byte) in |
| 30 | + state := Option.get (step 12 !state action); |
| 31 | + reference.(k).(offset) <- byte; |
| 32 | + for j = 0 to 7 do |
| 33 | + require (read !state j offset = reference.(j).(offset)) "private memory refinement" |
| 34 | + done |
| 35 | + done; |
| 36 | + require (integer (S.frontier !state) = 12) "one copy per written page"; |
| 37 | + List.iter (fun action -> require (step 12 !state action = None) "invalid action accepted") |
| 38 | + [S.Write (nat 8, nat 0, nat 1); S.Write (nat 0, nat 4096, nat 1); |
| 39 | + S.Write (nat 0, nat 0, nat 256); S.Read (nat 8, nat 0)]; |
| 40 | + require (step 4 S.boot (S.Write (nat 0, nat 0, nat 1)) = None) "exhaustion accepted"; |
| 41 | + require (Option.is_some (step 12 !state (S.Write (nat 0, nat 0, nat 1)))) "private write rejected"; |
| 42 | + print_endline "checked 1024 model writes with boundary and exhaustion cases" |
| 43 | + |
| 21 | 44 | type document = { fields : string array; values : string array } |
| 22 | 45 | |
| 23 | 46 | type guest = { |
| @@ -360,10 +383,98 @@ let work image path = |
| 360 | 383 | with Invalid_argument message | Sys_error message -> print_endline (String.capitalize_ascii message) |
| 361 | 384 | done) |
| 362 | 385 | |
| 386 | +let exercise () = |
| 387 | + let original = load "document" in |
| 388 | + let g = launch "build/loader.img" original in |
| 389 | + Fun.protect ~finally:(fun () -> close g) (fun () -> |
| 390 | + let physicals () = |
| 391 | + Array.of_list (List.map (fun line -> match String.split_on_char ' ' line with |
| 392 | + | ["@map"; _; _; address; rights] -> int_of_string address, rights |
| 393 | + | _ -> failwith "invalid mapping record") (request g "P")) |
| 394 | + in |
| 395 | + let initial_frames = physicals () in |
| 396 | + require (Array.length initial_frames = 8) "mapping count"; |
| 397 | + for p = 0 to 3 do |
| 398 | + require (initial_frames.(p) = initial_frames.(p + 4) && snd initial_frames.(p) = "0") |
| 399 | + "initial physical sharing" |
| 400 | + done; |
| 401 | + require (query g 0 = original.values && query g 1 = original.values && query g 2 = original.values) "initial document"; |
| 402 | + edit g 0 3 "x"; |
| 403 | + require ((query g 0).(3) = "x") "document edit"; |
| 404 | + let copied_frames = physicals () in |
| 405 | + require (fst copied_frames.(3) <> fst initial_frames.(3) && snd copied_frames.(3) = "1" |
| 406 | + && copied_frames.(7) = initial_frames.(7)) "physical copy isolation"; |
| 407 | + peek g 0 3; |
| 408 | + peek g 1 3; |
| 409 | + peek g 2 3; |
| 410 | + require (query g 1 = original.values && query g 2 = original.values) "snapshot isolation"; |
| 411 | + require (integer (S.frontier g.state) = 5) "first write copy"; |
| 412 | + edit g 0 3 ""; |
| 413 | + require ((query g 0).(3) = "") "empty field"; |
| 414 | + require (integer (S.frontier g.state) = 5) "repeated edit allocated"; |
| 415 | + require ((physicals ()).(3) = copied_frames.(3)) "private physical frame changed"; |
| 416 | + edit g 0 3 (String.make 255 'x'); |
| 417 | + require (String.length (query g 0).(3) = 255) "maximum field"; |
| 418 | + let rejected = try edit g 0 0 (String.make 256 'x'); false with Invalid_argument _ -> true in |
| 419 | + require rejected "oversized field accepted"; |
| 420 | + let before = query g 0 in |
| 421 | + let rejected = try ignore (request g ("E 0 0 " ^ String.make 256 'x')); false |
| 422 | + with Failure message -> message = "field too long" in |
| 423 | + require (rejected && query g 0 = before) "guest edit bounds"; |
| 424 | + for c = 0 to 1 do |
| 425 | + for p = 0 to 3 do edit g c p (Printf.sprintf "snapshot %d field %d" c p) done |
| 426 | + done; |
| 427 | + require (integer (S.frontier g.state) = 12) "copy pool accounting"; |
| 428 | + let final_frames = physicals () in |
| 429 | + for k = 0 to 7 do |
| 430 | + for j = k + 1 to 7 do |
| 431 | + require (fst final_frames.(k) <> fst final_frames.(j)) "private physical alias" |
| 432 | + done |
| 433 | + done; |
| 434 | + edit g 1 0 "updated after pool exhausted"; |
| 435 | + require ((query g 1).(0) = "updated after pool exhausted") "private edit after exhaustion"; |
| 436 | + require (query g 2 = original.values) "original changed"; |
| 437 | + let values = query g 0 in |
| 438 | + save "build/export.txt" {original with values}; |
| 439 | + require ((load "build/export.txt").values = values) "saved document differs"; |
| 440 | + let rejected = try edit g 2 0 "changed"; false with Invalid_argument _ -> true in |
| 441 | + require rejected "original edit accepted"; |
| 442 | + let survivor = query g 1 in |
| 443 | + discard g 0; |
| 444 | + require (List.length g.available = 4 && query g 1 = survivor) "discard isolation"; |
| 445 | + let reset_frames = physicals () in |
| 446 | + for p = 0 to 3 do require (reset_frames.(p) = initial_frames.(p)) "discard mapping restore" done; |
| 447 | + pool g; |
| 448 | + for cycle = 0 to 15 do |
| 449 | + for p = 0 to 3 do edit g 0 p (Printf.sprintf "cycle %d field %d" cycle p) done; |
| 450 | + require (g.available = [] && integer (S.frontier g.state) = 12) "recycling grew pool"; |
| 451 | + require (query g 1 = survivor && query g 2 = original.values) "recycling changed survivor"; |
| 452 | + discard g 0 |
| 453 | + done; |
| 454 | + discard g 1; |
| 455 | + require (List.length g.available = 8) "complete pool return"; |
| 456 | + let recycled = fst final_frames.(7) in |
| 457 | + edit g 0 0 "draft now owns review frame"; |
| 458 | + require (fst (physicals ()).(0) = recycled) "cross snapshot physical reuse"; |
| 459 | + edit g 1 3 "review writes its old virtual address"; |
| 460 | + require (fst (physicals ()).(7) <> recycled && (query g 0).(0) = "draft now owns review frame") |
| 461 | + "stale client mapping survived discard"; |
| 462 | + discard g 0; |
| 463 | + discard g 1; |
| 464 | + pool g; |
| 465 | + require (query g 2 = original.values && List.length g.available = 8) "reclamation final state"); |
| 466 | + let g = launch "build/unsafe.img" original in |
| 467 | + let detected = Fun.protect ~finally:(fun () -> close g) (fun () -> |
| 468 | + try edit g 0 3 "changed"; false with Failure message -> message = "write reached a shared page") in |
| 469 | + require detected "writable alias was not detected"; |
| 470 | + print_endline "exercised edits, exports, full pool recycling and stale mapping isolation" |
| 471 | + |
| 363 | 472 | let () = |
| 364 | 473 | Sys.catch_break true; |
| 365 | 474 | try |
| 366 | 475 | match Array.to_list Sys.argv with |
| 476 | + | [_; "--model"] -> selftest () |
| 477 | + | [_; "--test"] -> exercise () |
| 367 | 478 | | [_] | [_; "work"] -> work "build/loader.img" "document" |
| 368 | 479 | | [_; "work"; path] -> work "build/loader.img" path |
| 369 | 480 | | _ -> invalid_arg "usage: check work DOCUMENT" |
