(* The spike's harness: run the real frontend, lower the functions it produced
   with [X86], put the bytes in executable memory, call them, and compare with
   what the language says they should answer.

   The comparison is the whole point. Reading the bytes proves nothing -- a
   disassembly that looks right and a program that returns the wrong number is
   the normal outcome of hand-encoding, which is why the oracle here is the
   arithmetic and not objdump. [oracle.sh] disassembles the same buffer, and
   that is a debugging aid, not the evidence. *)

external jit_alloc : int -> nativeint = "spike_jit_alloc"
external jit_write : nativeint -> string -> unit = "spike_jit_write"
external jit_protect : nativeint -> int -> unit = "spike_jit_protect"
external call1 : nativeint -> int64 -> int64 = "spike_call1"
external call2 : nativeint -> int64 -> int64 -> int64 = "spike_call2"
external sym : string -> nativeint = "spike_sym"

let failures = ref 0
let checks = ref 0

let check name got want =
  incr checks;
  if got = want then Printf.printf "  ok    %-28s = %Ld\n" name got
  else begin
    incr failures;
    Printf.printf "  FAIL  %-28s = %Ld, want %Ld\n" name got want
  end

(* One page per function, so that a function that runs off its own end lands in
   an unmapped page and segfaults at the fault rather than in the middle of the
   next function. This is the crudest possible version of the code-object
   question the whole exercise is really about. *)
let page = 4096

let install (code : string) : nativeint =
  if String.length code > page then failwith "function exceeds one page";
  let p = jit_alloc page in
  jit_write p code;
  jit_protect p page;
  p

let run src =
  let decls =
    Flan.Load.program ~file:src (Flan.Parse.program_all (Flan.Reader.read_file src))
  in
  let prog = Flan.Check.program_all decls.Flan.Load.decls in
  Printf.printf "frontend: %d fns, %d globals, %d structs, %d externs\n"
    (List.length prog.Flan.Tast.fns) (List.length prog.Flan.Tast.globals)
    (List.length prog.Flan.Tast.structs) (List.length prog.Flan.Tast.externs);

  (* Two passes, because [spike-calls] calls functions whose addresses are not
     known until they are installed. Pass one installs every function at a
     fixed page; pass two emits the real code into it. A real backend does this
     with relocations; the spike does it by emitting twice, which is the same
     answer with none of the machinery. *)
  let addrs : (string, nativeint) Hashtbl.t = Hashtbl.create 16 in
  let unsupported = ref [] in
  let lowerable =
    List.filter
      (fun (fd : Flan.Tast.fn) ->
         try
           ignore (X86.fn ~resolve:(fun _ -> 0L) fd);
           true
         with X86.Unsupported m ->
           unsupported := (fd.Flan.Tast.name, m) :: !unsupported;
           false)
      prog.Flan.Tast.fns
  in
  List.iter
    (fun (fd : Flan.Tast.fn) ->
       Hashtbl.replace addrs fd.Flan.Tast.name (jit_alloc page))
    lowerable;
  let resolve name =
    match Hashtbl.find_opt addrs name with
    | Some p -> Int64.of_nativeint p
    | None ->
      (* Not a Flan function: a runtime entry point, looked up the way a dev
         build already reaches the host's symbols -- through the dynamic symbol
         table, which --dev links with -rdynamic. *)
      Int64.of_nativeint (sym name)
  in
  let bytes = Hashtbl.create 16 in
  List.iter
    (fun (fd : Flan.Tast.fn) ->
       let code = X86.fn ~resolve fd in
       Hashtbl.replace bytes fd.Flan.Tast.name code;
       let p = Hashtbl.find addrs fd.Flan.Tast.name in
       jit_write p code;
       jit_protect p page)
    lowerable;

  Printf.printf "lowered: %d of %d functions\n"
    (List.length lowerable) (List.length prog.Flan.Tast.fns);
  List.iter (fun (n, m) -> Printf.printf "  skipped %-20s %s\n" n m)
    (List.rev !unsupported);
  Hashtbl.iter (fun n c -> Printf.printf "  %-20s %4d bytes at %nx\n"
                   n (String.length c) (Hashtbl.find addrs n)) bytes;

  (* Dumped so oracle.sh can disassemble exactly the bytes that ran. *)
  (try
     let oc = open_out_bin (Filename.concat (Filename.dirname Sys.argv.(0)) "spike-add.bin") in
     output_string oc (Hashtbl.find bytes "spike-add");
     close_out oc
   with Not_found -> ());

  print_endline "results:";
  let at n = Hashtbl.find addrs n in
  check "spike-add 3 4" (call2 (at "spike-add") 3L 4L) 7L;
  check "spike-add -5 2" (call2 (at "spike-add") (-5L) 2L) (-3L);
  check "spike-arith 10 4" (call2 (at "spike-arith") 10L 4L) 19L;
  check "spike-let 6" (call1 (at "spike-let") 6L) 1332L;
  check "spike-if 1 2" (call2 (at "spike-if") 1L 2L) 1L;
  check "spike-if 9 2" (call2 (at "spike-if") 9L 2L) 7L;
  check "spike-calls 5" (call1 (at "spike-calls") 5L) 656L;

  Printf.printf "\n%d checks, %d failures\n" !checks !failures;
  exit (if !failures = 0 then 0 else 1)

(* The frontend's diagnostics printed rather than swallowed: a spike that says
   [Fatal error: exception Errors(_)] costs an hour. *)
let () =
  try run Sys.argv.(1) with
  | Flan.Loc.Error d -> prerr_endline (Flan.Loc.report d); exit 2
  | Flan.Loc.Errors ds -> prerr_endline (Flan.Loc.report_all ds); exit 2