Joseph Ferano
0fbca40446
x86.ml is an instruction selector for the part of Tast that fits in one integer register: literals, slots, let, if, arithmetic, comparison, and a call. Everything else raises with the node that defeated it, because an honest refusal is the measurement and a silently wrong answer would waste the exercise. The frontend is the real one -- Reader, Parse, Load, Check -- so what is lowered is the same Tast.fn the LLVM backend gets. Seven arithmetic results are compared against what the language says they should be; the disassembly proves nothing and is not the evidence. Nothing is wired into the build. No dune file under spike/, driven by hand with ocamlfind and clang as spike/embed already does.
125 lines
5.0 KiB
OCaml
125 lines
5.0 KiB
OCaml
(* 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
|