flan/test/test_session.ml

(* The session: the declarations a running process was built from, plus every
   change accepted since (NEXT.md, the dev loop).

   Two halves. First, what a session refuses — every case here is a change that
   would compile, load, install, and then be wrong, because a cell is a bare
   pointer and storage that already exists already has a shape. Second, that
   refusing leaves the session usable, which is the failure people actually hit:
   one typo must not poison every later evaluation. *)

open Flan

(* The watchdog first: a hang is the one failure mode that reports
   nothing at all. See watchdog.ml. *)
let () = Watchdog.arm ~seconds:600 "test_session"

let failures = ref 0
let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt

let has hay needle =
  let n = String.length needle and h = String.length hay in
  let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
  go 0

(* Every rejection is asserted on its reason, not just on the failure: the
   reason is the part that has to survive a refactor. *)
let checked_program file =
  Check.program
    (Load.program ~file (Parse.program (Reader.read_file file))).Load.decls

let refuses ?(file = "programs/reload.flan") name src reason =
  let t, _ = Session.create ~file () in
  match Session.eval t src with
  | _ -> fail "%s was accepted" name
  | exception Loc.Error { Loc.dmsg = msg; _ } ->
    if not (has msg reason) then
      fail "%s\n        said: %S\n     wanted it to mention: %S" name msg reason

let () =
  (* A cell carries no signature, so every call site compiled before the change
     still passes the old arguments through it. *)
  (* [outer] is called only from C, and [spare] is read by nothing, so the
     checker has no complaint about either change and the session is the only
     thing that can refuse them. A change something else in the program uses is
     an ordinary type error first, which is a different and louder failure. *)
  refuses "a changed parameter type"
    "(defn outer [x i64] i64 (bump))"
    "changes signature";
  refuses "a changed return type"
    "(defn outer [] i32 (i32 (bump)))"
    "changes signature";
  refuses "a changed arity"
    "(defn outer [a i64 b i64] i64 (bump))"
    "changes signature";
  (* The storage exists and has a shape: reusing it reads at the wrong offsets,
     and replacing it discards the state the reload exists to preserve. *)
  refuses "a retyped global"
    "(defvar spare i32)"
    "changes type";
  (* Values of the type are already in the running program's memory. *)
  (* A defconst the *checker* consumed is in the shape of the program — an
     array length is decided before any type resolves — so no store can reach
     it. One that is only read at run time is a different matter; see below. *)
  refuses "a changed defconst used at compile time"
    "(defconst folded i64 8)"
    "used at compile time";
  (* An enum member is erased to an i32 literal in the caller, so the same
     applies. It is compared over declarations because Tast.program carries no
     enums at all, for exactly that reason. *)
  refuses "a changed enum member"
    "(defenum Colour [red 0 green 2])"
    "changes its members";
  refuses ~file:"programs/values.flan" "a restructured struct"
    "(defstruct P [x i32 y i32])"
    "changes layout";

  (* An ordinary redefinition, and what the session works out about it. *)
  let t, _ = Session.create ~file:"programs/reload.flan" () in
  let c = Session.eval t "(defn bump [] i64 (set counter (+ counter 5)) counter)" in
  if not c.Session.installs then fail "a redefined function had nothing to install";
  if c.Session.fns <> [ "bump" ] then
    fail "redefining bump reported %s" (String.concat " " c.Session.fns);
  (* The prelude is in the checked program and in no accumulated AST, so a
     session that derived [known] from declarations would call rand-seed
     through a registry cell nobody ever publishes. *)
  if not (has c.Session.ir "@\"flan.cell.rand-seed\" = external global ptr") then
    fail "the prelude was treated as new";
  if has c.Session.ir "flan_dev_cell" then
    fail "a name the host has went through the registry";

  (* DWARF in a redefinition module, which is a property of the session and
     not of the call. [Emit.redefinition] has taken a ~debug argument all
     along and was tested with it; what was missing was anyone passing it, so
     every body installed by C-c C-c lost its debug info in a running process.
     The defect was one unpassed argument, so the test is that the argument
     arrives — asserted on the emitted text, which is the only place it shows.

     Both directions matter. A session that always emitted debug info would
     force -O0 on every reloaded body ([Build.shared] does that, and must),
     which would change the frame time of the one function being iterated on.
     Off unless asked for is the behaviour, so off is asserted too. *)
  let dt, _ = Session.create ~debug:true ~file:"programs/reload.flan" () in
  let dc =
    Session.eval dt
      "(defn bump [] i64 (let [step (i64 5)] (set counter (+ counter step)) counter))"
  in
  if not (has dc.Session.ir "!DILocalVariable(name: \"step\"") then
    fail "a debug session's redefinition carries no name for its local";
  if not (has dc.Session.ir "!DISubprogram(name: \"bump\"") then
    fail "a debug session's redefinition carries no subprogram";
  let pt, _ = Session.create ~file:"programs/reload.flan" () in
  let pc =
    Session.eval pt
      "(defn bump [] i64 (let [step (i64 5)] (set counter (+ counter step)) counter))"
  in
  if has pc.Session.ir "!DILocalVariable" then
    fail "a plain session's redefinition carries debug info it was not asked for";

  (* The same for an expression evaluation, which takes the other path out of
     the session and so can lose the flag on its own. *)
  let ec = Session.eval_expr dt "(+ counter 1)" in
  if not (has ec.Session.ir "!DISubprogram") then
    fail "a debug session's eval thunk carries no debug info";

  (* A form that does not check must leave the session exactly as it was. This
     is the one that decides whether a REPL survives a typo. *)
  (match Session.eval t "(defn bump [] i64 nonsense)" with
   | _ -> fail "an unresolvable name was accepted"
   | exception Loc.Error _ -> ());
  (match Session.eval t "(defn bump [] i64 (set counter (+ counter 6)) counter)" with
   | c -> if c.Session.fns <> [ "bump" ] then fail "the session did not recover"
   | exception Loc.Error { Loc.dmsg = m; _ } -> fail "the session was poisoned by a typo: %s" m);

  (* A declaration the program already has, with no body and no new storage,
     is accepted and has nothing to send. Building a module for it would report
     success for a change that cannot have taken effect, and would cost the
     program a reload it did not need. *)
  (match Session.eval t "(defvar counter i64)" with
   | c -> if c.Session.installs then fail "an empty change claimed to install"
   | exception Loc.Error { Loc.dmsg = m; _ } -> fail "redeclaring a var unchanged: %s" m);

  (* A constant that is only ever read at run time is just bytes in the
     program's memory. A dev build emits it as a mutable global and the module
     stores the new value at the frame boundary, which is how a colour table
     gets tuned live. *)
  (match Session.eval t "(defconst palette [2 u32] [9 9])" with
   | c ->
     if not c.Session.installs then
       fail "a changed run-time constant had nothing to install";
     if not (has c.Session.ir "store [2 x i32]") then
       fail "a changed run-time constant published no new value"
   | exception Loc.Error { Loc.dmsg = m; _ } -> fail "changing a run-time constant: %s" m);
  (* And in a dev build its storage is writable, where a release build keeps
     it immutable and gets all the folding back. *)
  let host = checked_program "programs/reload.flan" in
  if not (has (Emit.program ~dev:true host) "@\"flan.palette\" = global") then
    fail "a dev build left a constant immutable";
  if not (has (Emit.program host) "@\"flan.palette\" = constant") then
    fail "a release build made a constant mutable";

  (* A new global carries its declared initial value, copied once when the
     storage is allocated and never again — calloc alone would make it zero. *)
  let c = Session.eval t "(defvar started i64 42) (defn read-started [] i64 started)" in
  if not (has c.Session.ir "@\".init.") then
    fail "a new global's initialiser was dropped";
  if not c.Session.installs then fail "adding a global had nothing to install";

  (* Names the process was never built with go through the registry instead of
     binding to a symbol, and adding one is allowed where retyping one is not. *)
  let c = Session.eval t "(defvar fresh i64) (defn use-fresh [] i64 (set fresh 3) fresh)" in
  if not (List.mem "fresh" c.Session.names && List.mem "use-fresh" c.Session.fns) then
    fail "adding a var and a function reported %s" (String.concat " " c.Session.names);
  if not (has c.Session.ir "call ptr @flan_dev_global") then
    fail "a new global did not go through the registry";
  (* And once added, it is part of the session: a later form can use it. *)
  (match Session.eval t "(defn use-fresh [] i64 (set fresh 4) fresh)" with
   | _ -> ()
   | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a name added earlier was forgotten: %s" m);

  (* A file with imports, re-evaluated whole — the C-c C-k case. The session
      keeps the *expanded* declarations, so the package's names are replaced in
      place rather than appended a second time and rejected as duplicates. *)
  let t, _ = Session.create ~file:"../sand.flan" () in
  let src = In_channel.with_open_bin "../sand.flan" In_channel.input_all in
  (* [~origin] is the buffer's own path and both editor paths send it
     (flan-dev.el's `:file (or buffer-file-name "<buffer>")`). Omitting it here
     was testing a request the editor never sends. It used to matter to this
     case for a second reason — sand.flan embedded brush.png, and an embedded
     path resolves relative to the file the form is written in, so the default
     origin of "<eval>" found nothing. sand.flan has no embed any more; the
     first reason is the one that stands. *)
  (match Session.eval ~origin:"../sand.flan" t src with
   | c ->
     if not (List.mem "game-draw" c.Session.fns) then
       fail "reloading sand.flan did not include its own functions"
   | exception Loc.Error { Loc.dmsg = m; _ } ->
     fail "reloading a file with imports failed: %s" m);

  (* A form typed into a file that is *imported as a package* has to be
     qualified the way the import qualified it, or it splices as a brand-new
     unrelated name: the evaluation reports success and the running program
     goes on calling the one it already had. The alias is chosen by the
     importer and written nowhere in the file, so the path is the only thing
     that can decide it — which is why it is derived here and not sent by the
     editor. *)
  let t, _ = Session.create ~file:"../sand.flan" () in
  (match
     Session.eval ~origin:"../vendor/agent/agent.flan" t
       "(defn poll [] i32 (poll-raw))"
   with
   | c ->
     if c.Session.fns <> [ "agent/poll" ] then
       fail "a form from a package file reported %s, wanted agent/poll"
         (String.concat " " c.Session.fns)
   | exception Loc.Error { Loc.dmsg = m; _ } -> fail "redefining agent/poll: %s" m);
  (* A package that is a single file, which is what sand.flan is to the
     headless driver. The file being edited *is* the package rather than a
     member of a directory, so matching on the directory alone would answer
     "not a package" — and the failure is the silent one above: the form
     splices as a bare [step] and the running program keeps the one it had. *)
  let t2, _ = Session.create ~file:"programs/sand-headless.flan" () in
  (match Session.eval ~origin:"../sand.flan" t2 "(defn step [] () (do))" with
   | c ->
     if c.Session.fns <> [ "sand/step" ] then
       fail "a form from a single-file package reported %s, wanted sand/step"
         (String.concat " " c.Session.fns)
   | exception Loc.Error { Loc.dmsg = m; _ } -> fail "redefining sand/step: %s" m);

  (* And a file that is not a package keeps its names as written. *)
  (match Session.eval ~origin:"../sand.flan" t "(defn game-draw [] () (do))" with
   | c ->
     if c.Session.fns <> [ "game-draw" ] then
       fail "a form from the program's own file reported %s"
         (String.concat " " c.Session.fns)
   | exception Loc.Error { Loc.dmsg = m; _ } -> fail "redefining game-draw: %s" m);

  (* An expression's thunk leaves nothing behind, and the module says so, which
     is what lets the agent unload it: nothing may point into its text
     afterwards. So it is called directly rather than through a cell, and it
     must not take a registry slot either — there are 4096 of those and an
     expression evaluated in a loop would exhaust them. A module that publishes
     a body can never say this; its whole purpose is to leave a pointer. *)
  let t, _ = Session.create ~file:"programs/reload.flan" () in
  let e = Session.eval_expr t "(+ 1 2)" in
  if not (has e.Session.ir "@flan_reload_transient") then
    fail "an expression's module did not declare itself unloadable";
  if not (has e.Session.ir "define void @flan_reload_call") then
    fail "an expression's module carried no thunk to run";
  if has e.Session.ir "flan.cellp.eval" then
    fail "an expression's thunk took a registry slot";
  if has e.Session.ir "call ptr @flan_dev_cell" then
    fail "an expression's thunk was looked up by name";
  let c = Session.eval t "(defn bump [] i64 (set counter (+ counter 1)) counter)" in
  if has c.Session.ir "@flan_reload_transient" then
    fail "a module that publishes a body claimed to be unloadable";

  (* And a third condition, about data rather than text. A string literal lives
     in the evaluating module's own image, and an expression may store one
     anywhere: [(set msg "x")] on a string global would leave that global
     pointing into a mapping the agent then drops — and since the next thunk can
     be mapped at the same address, the result is silent garbage rather than a
     fault. A module carrying any string constant keeps its mapping. *)
  let str = Session.eval_expr t "(println \"tuned\")" in
  if not (has str.Session.ir ".str.0") then
    fail "the fixture stopped carrying a string constant, so it proves nothing";
  if has str.Session.ir "@flan_reload_transient" then
    fail "an expression holding a string claimed to be unloadable";

  if !failures = 0 then print_endline "session: all tests passed"
  else begin
    Printf.printf "\n%d failure(s)\n" !failures;
    exit 1
  end