diff --git a/test/programs/reload-v5.flan b/test/programs/reload-v5.flan new file mode 100644 index 0000000..b114017 --- /dev/null +++ b/test/programs/reload-v5.flan @@ -0,0 +1,29 @@ +;;;; v5 is v4 with one difference: [extra] is an i32 rather than an i64. +;;;; +;;;; [extra] does not exist in the host — v3 introduced it at run time, so its +;;;; storage was allocated by runtime/flan_dev.c the first time a module asked +;;;; for it, and every later module that mentions the name is handed back that +;;;; same allocation. Handing it back for a differently shaped type is layout +;;;; drift: the new body would read and write at offsets the old allocation was +;;;; never laid out for, and nothing downstream could ever say so. The registry +;;;; compares the size it recorded against the size it is asked for and aborts +;;;; instead — retyping a var needs a restart, and this is the file that says +;;;; the guard is real. +;;;; +;;;; Loaded on top of v3, and never alongside v4: the process it aborts is the +;;;; whole of the test. +(defvar counter i64) +(defvar extra i32) + +(defn helper [x i64] i64 (* x 2)) + +(defn added [] i32 + (set extra (+ extra 100)) + extra) + +(defn bump [] i64 + (println "v5") + (set counter (+ counter (i64 (added)))) + (helper counter)) + +(defn outer [] i64 (bump)) diff --git a/test/test_reload.ml b/test/test_reload.ml index b94eccd..d4d66e5 100644 --- a/test/test_reload.ml +++ b/test/test_reload.ml @@ -82,6 +82,10 @@ let () = not exist. This is the C-c C-k unit. *) let so3, ir3, _, _ = module_of p3 [ "bump"; "added" ] "v3.so" in let so4, ir4, _, _ = module_of p4 [ "added" ] "v4.so" in + (* v5 retypes [extra], which v3 introduced at run time. It is built here + and loaded in a process of its own below: what it does is abort. *) + let p5 = checked "programs/reload-v5.flan" in + let so5, _, _, _ = module_of p5 [ "added" ] "v5.so" in (* A redefinition module must not define what the host already owns: defining [counter] would give the loaded object a private copy and the @@ -196,6 +200,32 @@ let () = if code <> 0 || text <> want then fail "reload\n got: %S (exit %d)\n wanted: %S" text code want; + (* The layout-drift guard, which needs a process of its own because what it + does is abort one. [extra] does not exist in the host: v3 introduced it + at run time, so flan_dev.c allocated its storage and recorded its size, + and every later module asking for that name is handed the same + allocation back. v5 asks for it as an i32. Handing back eight bytes for + a four-byte type is not an error anything downstream can detect — the + new body simply reads fields at offsets the allocation was never laid + out for — so the registry compares sizes and dies at the first chance + it has. + + Asserted on the message as well as on the exit status: a process that + died for some other reason is not this guard firing, and the exit code + alone cannot tell the two apart. *) + let out5 = tmp "out5" and err5 = tmp "err5" in + let code5 = + Sys.command + (Printf.sprintf "%s %s %s %s > %s 2> %s" (Filename.quote host) + (Filename.quote so1) (Filename.quote so3) (Filename.quote so5) + (Filename.quote out5) (Filename.quote err5)) + in + let said = In_channel.with_open_bin err5 In_channel.input_all in + if code5 = 0 then + fail "a global retyped across a reload was accepted (exit 0)"; + if not (has said "size changed") then + fail "a retyped global did not stop on the size guard: %S" said; + Printf.printf "reload: emit %.1fms llc %.1fms ld %.1fms (v2: emit %.1fms llc %.1fms ld %.1fms) host run %.1fms\n" emit_ms t1.Build.llc_ms t1.Build.link_ms emit2_ms t2.Build.llc_ms @@ -203,7 +233,7 @@ let () = print_string timings; List.iter (fun p -> try Sys.remove p with Sys_error _ -> ()) - [ host; so1; so2; so3; so4; out; tmp "err" ]; + [ host; so1; so2; so3; so4; so5; out; out5; err5; tmp "err" ]; if !failures = 0 then print_endline "reload: all tests passed" else begin Printf.printf "\n%d failure(s)\n" !failures;