Add the flexpect tool

.gitignore

@@ -222,6 +222,7 @@ middle_end/flambda/types/flambda_type.ml
 /testsuite/tools/codegen
 /testsuite/tools/expect_test
 /testsuite/tools/fldiff
+/testsuite/tools/flexpect
 /testsuite/tools/lexcmm.ml
 /testsuite/tools/parsecmm.ml
 /testsuite/tools/parsecmm.mli

flambdatest/expect/test1.flt

@@ -0,0 +1,9 @@
+let code f _ -> k = cont k (42) in
+let f = closure f in
+let symbol B = Block 0 (f) in
+cont done (B)
+===>
+let code f _ -> k = cont k (43) in
+let symbol F = closure f in
+let symbol B = Block 0 (F) in
+cont done (B)

middle_end/flambda/compare/compare.ml

@@ -108,28 +108,41 @@ module Comparison = struct
   ;;
 end
 
+let debugging = false
+
 let log f e1 e2 thunk =
-  Format.eprintf "@[<v>@[<hv>COMPARING@;<1 2>%a@;<1 0>TO@;<1 2>%a@]@,---@;<0 2>"
-    f e1 f e2;
-  let ans = thunk () in
-  Format.eprintf "%a@]@," (Comparison.print f) ans;
-  ans
+  if debugging 
+    then begin
+      Format.eprintf
+        "@[<v>@[<hv>COMPARING@;<1 2>%a@;<1 0>TO@;<1 2>%a@]@,---@;<0 2>"
+        f e1 f e2;
+      let ans = thunk () in
+      Format.eprintf "%a@]@," (Comparison.print f) ans;
+      ans
+    end
+    else
+      thunk ()
+;;
 
 let log_rel f e1 rel e2 =
-  Format.eprintf "@[<hv>%a@;<1 2>%s@;<1 0>%a@]@," f e1 rel f e2
+  if debugging then
+    Format.eprintf "@[<hv>%a@;<1 2>%s@;<1 0>%a@]@," f e1 rel f e2
+;;
 
 let log_eq p f e1 e2 =
-  let rel = if p e1 e2 then "=" else "/=" in
-  log_rel f e1 rel e2
+  if debugging then
+    let rel = if p e1 e2 then "=" else "/=" in
+    log_rel f e1 rel e2
 ;;
 
 let log_comp c f e1 e2 =
-  let rel = match c e1 e2 with
-    | n when n < 0 -> "<"
-    | 0 -> "="
-    | _ -> ">"
-  in
-  log_rel f e1 rel e2
+  if debugging then
+    let rel = match c e1 e2 with
+      | n when n < 0 -> "<"
+      | 0 -> "="
+      | _ -> ">"
+    in
+    log_rel f e1 rel e2
 ;;
 
 module Env = struct

middle_end/flambda/parser/fexpr.ml

@@ -285,3 +285,8 @@ and static_closure_binding = {
 type flambda_unit = {
   body : expr;
 }
+
+type expect_test_spec = {
+  before : flambda_unit;
+  after : flambda_unit;
+}

middle_end/flambda/parser/flambda_lex.mll

@@ -159,6 +159,7 @@ rule token = parse
   | "->" { MINUSGREATER }
   | "@" { AT }
   | "|"  { PIPE }
+  | "===>" { BIGARROW }
   | lowercase identchar *
       { let s = Lexing.lexeme lexbuf in
         try Hashtbl.find keyword_table s

middle_end/flambda/parser/flambda_parser.mli

@@ -63,6 +63,7 @@ type token =
   | CLOSURE
   | CCALL
   | BLOCK
+  | BIGARROW
   | AT
   | APPLY
   | ANDWHERE
@@ -76,6 +77,8 @@ exception Error
 
 val flambda_unit: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Fexpr.flambda_unit)
 
+val expect_test_spec: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Fexpr.expect_test_spec)
+
 module MenhirInterpreter : sig
 
   (* The incremental API. *)
@@ -91,4 +94,6 @@ module Incremental : sig
 
   val flambda_unit: Lexing.position -> (Fexpr.flambda_unit) MenhirInterpreter.checkpoint
 
+  val expect_test_spec: Lexing.position -> (Fexpr.expect_test_spec) MenhirInterpreter.checkpoint
+
 end

middle_end/flambda/parser/flambda_parser.mly

@@ -43,6 +43,7 @@ let make_const_float (i, m) =
 %token ANDWHERE [@symbol "andwhere"]
 %token AT    [@symbol "@"]
 %token APPLY [@symbol "apply"]
+%token BIGARROW [@symbol "===>"]
 %token BLOCK [@symbol "Block"]
 %token CCALL  [@symbol "ccall"]
 %token CLOSURE  [@symbol "closure"]
@@ -105,23 +106,32 @@ let make_const_float (i, m) =
 %token WITH   [@symbol "with"]
 %token EOF
 
-%start flambda_unit
+%start flambda_unit expect_test_spec
 %type <Fexpr.flambda_unit> flambda_unit
+%type <Fexpr.expect_test_spec> expect_test_spec
 %type <Fexpr.static_structure> static_structure
-%type <Fexpr.expr> expr
-(* %type <Fexpr.name> name *)
 %type <Fexpr.kind> kind
 %type <Fexpr.named> named
 %type <Fexpr.of_kind_value> of_kind_value
 %%
 
+flambda_unit:
+  | body = module_
+    EOF
+    { body }
+;
+
+expect_test_spec:
+  | before = module_; BIGARROW; after = module_; EOF
+    { { before; after } }
+;
+
 (* XCR lwhite: Probably easier to just use some default names for these
    continuations
    
    lmaurer: Makes sense. I went with "done" and "error" for the names. *)
-flambda_unit:
+module_:
   | body = expr
-    EOF
     { { body } }
 ;
 

middle_end/flambda/parser/parse_flambda.ml

@@ -11,15 +11,15 @@ let make_loc (startpos, endpos) = {
   Location.loc_ghost = false;
 }
 
-let parse_fexpr filename =
+let run_parser ~start_symbol filename =
   let ic = open_in filename in
   try
     let pos = { Lexing.pos_fname = filename; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } in
     let lb = Lexing.from_channel ic in
     let lb = { lb with lex_start_p = pos; lex_curr_p = pos } in
     let supplier = Parser.MenhirInterpreter.lexer_lexbuf_to_supplier Lex.token lb in
-    let start = Parser.Incremental.flambda_unit pos in
-    let unit =
+    let start = start_symbol pos in
+    let result =
       try Parser.MenhirInterpreter.loop_handle
             (fun ans -> Ok ans)
             (function
@@ -44,15 +44,23 @@ let parse_fexpr filename =
         Error (Lexing_error (error, make_loc loc))
     in
     close_in ic;
-    unit
+    result
   with
   | e ->
     let x = Printexc.get_raw_backtrace () in
     close_in ic;
     Printexc.raise_with_backtrace e x
 
-let make_compilation_unit file =
-  let basename = Filename.chop_suffix file ".fl" |> Filename.basename in
+let parse_fexpr = run_parser ~start_symbol:Parser.Incremental.flambda_unit
+
+let parse_expect_test_spec =
+  run_parser ~start_symbol:Parser.Incremental.expect_test_spec
+
+let make_compilation_unit ~extension ~filename =
+  let basename =
+    Filename.chop_suffix filename ("." ^ extension)
+    |> Filename.basename
+  in
   let name = String.capitalize_ascii basename in
   let linkage_name = Linkage_name.create name in
   let id = Ident.create_persistent name in
@@ -61,7 +69,7 @@ let make_compilation_unit file =
 let parse ~backend filename =
   parse_fexpr filename
   |> Result.map (fun fexpr ->
-    let comp_unit = make_compilation_unit filename in
+    let comp_unit = make_compilation_unit ~extension:"fl" ~filename in
     let old_comp_unit = Compilation_unit.get_current () in
     Compilation_unit.set_current comp_unit;
     let module_ident = Compilation_unit.get_persistent_ident comp_unit in

middle_end/flambda/parser/parse_flambda.mli

@@ -2,12 +2,17 @@ type error =
   | Lexing_error of Flambda_lex.error * Location.t
   | Parsing_error of string * Location.t
 
+val parse_expect_test_spec
+   : string
+  -> (Fexpr.expect_test_spec, error) result
+
 val parse_fexpr
    : string
   -> (Fexpr.flambda_unit, error) result
 
 val make_compilation_unit
-   : string
+   : extension:string
+  -> filename:string
   -> Compilation_unit.t
 
 val parse

testsuite/tools/Makefile

@@ -70,6 +70,22 @@ fldiff_OCAMLFLAGS = $(addprefix -I $(TOPDIR)/, $(fldiff_DIRS))
 fldiff_LIBS = $(addprefix $(COMPILERLIBSDIR)/,\
   ocamlcommon ocamloptcomp)
 
+flexpect_MAIN=flexpect
+flexpect_PROG=$(flexpect_MAIN)$(EXE)
+flexpect_DIRS=\
+  asmcomp \
+	parsing \
+	utils \
+  middle_end/flambda/compilenv_deps \
+  middle_end/flambda/parser \
+  middle_end/flambda/compare \
+  middle_end/flambda/simplify \
+  middle_end/flambda/terms
+flexpect_OCAMLFLAGS = $(addprefix -I $(TOPDIR)/, $(flexpect_DIRS))
+
+flexpect_LIBS = $(addprefix $(COMPILERLIBSDIR)/,\
+  ocamlcommon ocamloptcomp)
+
 tools := $(expect_PROG)
 
 ifeq "$(NATIVE_COMPILER)" "true"
@@ -94,6 +110,8 @@ $(parseflambda_PROG): COMPFLAGS = $(parseflambda_OCAMLFLAGS)
 
 $(fldiff_PROG): COMPFLAGS = $(fldiff_OCAMLFLAGS)
 
+$(flexpect_PROG): COMPFLAGS = $(flexpect_OCAMLFLAGS)
+
 codegen_main.cmo: parsecmm.cmo
 
 $(codegen_PROG): $(codegen_OBJECTS)
@@ -105,6 +123,9 @@ $(parseflambda_PROG): $(parseflambda_MAIN).cmo
 $(fldiff_PROG): $(fldiff_MAIN).cmo
 	$(OCAMLC) -o $@ $(fldiff_LIBS:=.cma) $^
 
+$(flexpect_PROG): $(flexpect_MAIN).cmo
+	$(OCAMLC) -o $@ $(flexpect_LIBS:=.cma) $^
+
 parsecmm.mli parsecmm.ml: parsecmm.mly
 	$(OCAMLYACC) -q parsecmm.mly
 

testsuite/tools/flexpect.ml

@@ -0,0 +1,77 @@
+let check_invariants program =
+  try Flambda_unit.invariant program
+  with exn ->
+    Format.eprintf "Program which failed invariant check:@ %a\n%!"
+      Flambda_unit.print program;
+    raise exn
+
+module Outcome = struct
+  type t = Success | Failure | Error
+
+  let to_exit_code = function
+    | Success -> 0
+    | Failure -> 1
+    | Error -> 2
+end
+
+let run_expect_test ~backend filename : Outcome.t =
+  match Parse_flambda.parse_expect_test_spec filename with
+  | Ok { before; after = expected } ->
+    begin
+      let comp_unit =
+        Parse_flambda.make_compilation_unit ~extension:"flt" ~filename
+      in
+      Compilation_unit.set_current comp_unit;
+      let module_ident = Compilation_unit.get_persistent_ident comp_unit in
+      let before_fl = Fexpr_to_flambda.conv ~backend ~module_ident before in
+      check_invariants before_fl;
+      let { Simplify.unit = actual_fl; _ } =
+        Simplify.run ~backend ~round:1 before_fl
+      in
+      let expected_fl = Fexpr_to_flambda.conv ~backend ~module_ident expected in
+      match Compare.flambda_units actual_fl expected_fl with
+      | Equivalent ->
+        Format.eprintf "PASS@.";
+        Success
+      | Different { approximant = actual' } ->
+        let actual_fexpr = Flambda_to_fexpr.conv actual' in
+        let corrected_filename = filename ^ ".corrected" in
+        let corrected_out = open_out corrected_filename in
+        Format.fprintf (corrected_out |> Format.formatter_of_out_channel)
+          "@[<v>%a@ ===>@ %a@]@."
+          Print_fexpr.flambda_unit before
+          Print_fexpr.flambda_unit actual_fexpr;
+        close_out corrected_out;
+        Format.eprintf "FAIL - Saving corrected test as %s@."
+          corrected_filename;
+        Failure
+    end
+  | Error e ->
+    begin match e with
+    | Parsing_error (msg, loc) ->
+      Format.eprintf
+        "%a:@.\
+         Syntax error: %s@."
+        Location.print_loc loc
+        msg
+    | Lexing_error (error, loc) ->
+      Format.eprintf
+        "%a:@.\
+         Lex error: %a@."
+        Location.print_loc loc
+        Flambda_lex.pp_error error
+    end;
+    Error
+
+let _ =
+  let file = Sys.argv.(1) in
+  let ext = Filename.extension file in
+  let outcome =
+    match ext with
+    | ".flt" ->
+      run_expect_test ~backend:(module Asmgen.Flambda_backend) file
+    | _ ->
+      Misc.fatal_errorf "Unrecognized extension %s; expected .flt" ext
+  in
+  exit (outcome |> Outcome.to_exit_code)
+

testsuite/tools/parseflambda.ml

@@ -7,10 +7,12 @@ let check_invariants program =
       Flambda_unit.print program;
     raise exn
 
-let parse_flambda ~backend file =
-    match Parse_flambda.parse_fexpr file with
+let parse_flambda ~backend filename =
+    match Parse_flambda.parse_fexpr filename with
     | Ok unit ->
-      let comp_unit = Parse_flambda.make_compilation_unit file in
+      let comp_unit =
+        Parse_flambda.make_compilation_unit ~extension:"fl" ~filename
+      in
       Compilation_unit.set_current comp_unit;
       Format.printf "%a@.@."
         Print_fexpr.flambda_unit unit;