Import flexpect from old repo and add to Makefile/dune (ocaml-flambda…

…#340)

You can now `make runtest` to run a couple of tests. One of them is an
`flexpect`-based test, with a functioning `make promote`. (The other
is the preexisting `meet_test.ml`, which simply needed to be made a
test in `dune`.)

There are also the `fldiff` and `parseflambda` utilities from the old
repo. `fldiff` might be useful for testing the `Flambda2_compare`
module, and `parseflambda` more or less runs the middle end and
nothing else.

HACKING.md

@@ -121,6 +121,9 @@ install parallel`.
 There is also a `make ci` target (best run as e.g. `make -j16 ci`) which does a full build
 and test run.
 
+Some of our tests are expect tests run using a custom tool called `flexpect`.
+Corrected outputs can be promoted using `make promote`.
+
 ## Running only part of the upstream testsuite
 
 This can be done from the `_runtest` directory after it has been initialised by a previous `make runtest-upstream`.

Makefile.in

@@ -267,6 +267,21 @@ runtest:
 	  ARCH=`grep '^ARCH=' ocaml/Makefile.config | cut -d'=' -f2` \
 	  $(dune) runtest --root=. --profile=release --build-dir=_build2
 
+# Only needed for running the test tools by hand; runtest will take care of
+# building them using Dune
+.PHONY: test-tools
+test-tools: stage1
+	PATH=$(stage1_prefix)/bin:$$PATH \
+	  ARCH=`grep '^ARCH=' ocaml/Makefile.config | cut -d'=' -f2` \
+	  $(dune) build @middle_end/flambda2/tests/tools/all \
+	    --root=. --profile=release --build-dir=_build2
+
+.PHONY: promote
+promote:
+	PATH=$(stage1_prefix)/bin:$$PATH \
+	  ARCH=`grep '^ARCH=' ocaml/Makefile.config | cut -d'=' -f2` \
+	  $(dune) promote --root=. --build-dir=_build2
+
 # The following horror will be removed when work to allow the testsuite to
 # run on an installed tree (led by David Allsopp) is completed.
 # stage2 needs to have been built first.

middle_end/flambda2/compare/compare.ml

@@ -351,12 +351,13 @@ and subst_pattern env (pattern : Bound_symbols.Pattern.t) :
 and subst_static_const env (static_const : Static_const_or_code.t) :
     Static_const_or_code.t =
   match static_const with
-  | Code code -> Code (subst_code env code)
+  | Code code -> Static_const_or_code.create_code (subst_code env code)
   | Static_const (Block (tag, mut, fields)) ->
     let fields = List.map (subst_field env) fields in
-    Static_const (Block (tag, mut, fields))
+    Static_const_or_code.create_static_const (Block (tag, mut, fields))
   | Static_const (Set_of_closures set_of_closures) ->
-    Static_const (Set_of_closures (subst_set_of_closures env set_of_closures))
+    Static_const_or_code.create_static_const
+      (Set_of_closures (subst_set_of_closures env set_of_closures))
   | _ -> static_const
 
 and subst_code env (code : Code.t) : Code.t =
@@ -391,7 +392,7 @@ and subst_params_and_body env params_and_body =
   Function_params_and_body.pattern_match params_and_body
     ~f:(fun
          ~return_continuation
-         exn_continuation
+         ~exn_continuation
          params
          ~body
          ~my_closure
@@ -401,7 +402,7 @@ and subst_params_and_body env params_and_body =
        ->
       let body = subst_expr env body in
       let dbg = Function_params_and_body.debuginfo params_and_body in
-      Function_params_and_body.create ~return_continuation exn_continuation
+      Function_params_and_body.create ~return_continuation ~exn_continuation
         params ~dbg ~body ~my_closure ~free_names_of_body ~my_depth)
 
 and subst_let_cont env (let_cont_expr : Let_cont_expr.t) =
@@ -1126,18 +1127,18 @@ and static_consts env (const1 : Static_const_or_code.t)
     (const2 : Static_const_or_code.t) : Static_const_or_code.t Comparison.t =
   match const1, const2 with
   | Code code1, Code code2 ->
-    codes env code1 code2
-    |> Comparison.map ~f:(fun code1' : Static_const_or_code.t -> Code code1')
+    codes env code1 code2 |> Comparison.map ~f:Static_const_or_code.create_code
   | ( Static_const (Block (tag1, mut1, fields1)),
       Static_const (Block (tag2, mut2, fields2)) ) ->
     blocks env (tag1, mut1, fields1) (tag2, mut2, fields2)
     |> Comparison.map
          ~f:(fun (tag1', mut1', fields1') : Static_const_or_code.t ->
-           Static_const (Block (tag1', mut1', fields1')))
+           Static_const_or_code.create_static_const
+             (Block (tag1', mut1', fields1')))
   | Static_const (Set_of_closures set1), Static_const (Set_of_closures set2) ->
     sets_of_closures env set1 set2
     |> Comparison.map ~f:(fun set1' : Static_const_or_code.t ->
-           Static_const (Set_of_closures set1'))
+           Static_const_or_code.create_static_const (Set_of_closures set1'))
   | _, _ ->
     if Static_const_or_code.equal const1 const2
     then Equivalent
@@ -1149,7 +1150,7 @@ and codes env (code1 : Code.t) (code2 : Code.t) =
       params_and_body2
       ~f:(fun
            ~return_continuation
-           exn_continuation
+           ~exn_continuation
            params
            ~body1
            ~body2
@@ -1160,8 +1161,8 @@ and codes env (code1 : Code.t) (code2 : Code.t) =
         |> Comparison.map ~f:(fun body1' ->
                let dbg = Function_params_and_body.debuginfo params_and_body1 in
                Function_params_and_body.create ~return_continuation
-                 exn_continuation params ~dbg ~body:body1' ~my_closure ~my_depth
-                 ~free_names_of_body:Unknown))
+                 ~exn_continuation params ~dbg ~body:body1' ~my_closure
+                 ~my_depth ~free_names_of_body:Unknown))
   in
 
   let bodies_or_deleted env body1 body2 : _ Or_deleted.t Comparison.t =
@@ -1260,25 +1261,23 @@ and let_cont_exprs env (let_cont1 : Let_cont.t) (let_cont2 : Let_cont.t) :
   | _, _ -> Different { approximant = subst_let_cont env let_cont1 }
 
 and cont_handlers env handler1 handler2 =
-  log Continuation_handler.print handler1 handler2 (fun () ->
-      Continuation_handler.pattern_match_pair handler1 handler2
-        ~f:(fun params ~handler1:expr1 ~handler2:expr2 ->
-          exprs env expr1 expr2
-          |> Comparison.map ~f:(fun handler ->
-                 Continuation_handler.create params ~handler
-                   ~free_names_of_handler:Unknown
-                   ~is_exn_handler:
-                     (Continuation_handler.is_exn_handler handler2))
-          |> Comparison.add_condition
-               ~cond:
-                 (Bool.equal
-                    (Continuation_handler.is_exn_handler handler1)
-                    (Continuation_handler.is_exn_handler handler2))
-               ~approximant:(fun () -> subst_cont_handler env handler1))
-      |> function
-      | Ok comp -> comp
-      | Error _ ->
-        Comparison.Different { approximant = subst_cont_handler env handler1 })
+  Flambda.Continuation_handler.pattern_match_pair handler1 handler2
+    ~f:(fun params ~handler1:expr1 ~handler2:expr2 ->
+      exprs env expr1 expr2
+      |> Comparison.map ~f:(fun handler ->
+             Continuation_handler.create params ~handler
+               ~free_names_of_handler:Unknown
+               ~is_exn_handler:(Continuation_handler.is_exn_handler handler2))
+      |> Comparison.add_condition
+           ~cond:
+             (Bool.equal
+                (Continuation_handler.is_exn_handler handler1)
+                (Continuation_handler.is_exn_handler handler2))
+           ~approximant:(fun () -> subst_cont_handler env handler1))
+  |> function
+  | Ok comp -> comp
+  | Error _ ->
+    Comparison.Different { approximant = subst_cont_handler env handler1 }
 
 let flambda_units u1 u2 =
   let ret_cont = Continuation.create ~sort:Toplevel_return () in

middle_end/flambda2/compare/dune

@@ -8,9 +8,21 @@
    -principal
    -nostdlib
    -open
-   Flambda2_terms
+   Flambda2_algorithms
    -open
-   Flambda2_algorithms))
+   Flambda2_bound_identifiers
+   -open
+   Flambda2_identifiers
+   -open
+   Flambda2_kinds
+   -open
+   Flambda2_nominal
+   -open
+   Flambda2_numbers
+   -open
+   Flambda2_term_basics
+   -open
+   Flambda2_terms))
  (ocamlopt_flags
   (:standard -O3))
  (libraries stdlib ocamlcommon flambda2_algorithms flambda2_terms))

middle_end/flambda2/flambda2.mli

@@ -27,3 +27,12 @@ val lambda_to_cmm :
   module_block_size_in_words:int ->
   module_initializer:Lambda.lambda ->
   Cmm.phrase list
+
+val symbol_for_global :
+  ?comp_unit:Flambda2_identifiers.Compilation_unit.t ->
+  Ident.t ->
+  Flambda2_identifiers.Symbol.t
+
+val get_global_info :
+  Flambda2_identifiers.Compilation_unit.t ->
+  Flambda2_cmx.Flambda_cmx_format.t option

middle_end/flambda2/tests/dune

@@ -1,14 +1,12 @@
-(executable
- (name meet_test)
+(tests
+ (names meet_test)
  (modes native)
- (flags (:standard -principal -nostdlib -cclib "-I ../../runtime"))
- (libraries ocamloptcomp ocamloptcommon ocamlmiddleend flambda ocamlcommon runtimeopt stdlib)
- (modules meet_test))
+ (flags (:standard -principal -nostdlib))
+ (libraries
+  stdlib runtime_native ocamloptcomp ocamlcommon
+  flambda2_bound_identifiers flambda2_cmx flambda2_identifiers flambda2_kinds
+  flambda2_nominal flambda2_numbers flambda2_term_basics flambda2_types))
 
 (include_subdirs no)
 
-(alias
-  (name world)
-  (deps
-    meet_test.exe
-  ))
+(dirs mlexamples tools)

middle_end/flambda2/tests/meet_test.ml

@@ -1,16 +1,23 @@
+open Flambda2_bound_identifiers
+open Flambda2_cmx
+open Flambda2_identifiers
+open Flambda2_kinds
+open Flambda2_nominal
+open Flambda2_numbers
+open Flambda2_term_basics
+open Flambda2_types
 module K = Flambda_kind
 module T = Flambda2_types
 module TE = T.Typing_env
 module TEE = T.Typing_env_extension
 
-let resolver _ = None
-
-let get_imported_names () = Name.Set.empty
-
-let get_imported_code () = Exported_code.empty
+let create_env () =
+  let resolver _ = None in
+  let get_imported_names () = Name.Set.empty in
+  TE.create ~resolver ~get_imported_names
 
 let test_meet_chains_two_vars () =
-  let env = TE.create ~resolver ~get_imported_names ~get_imported_code in
+  let env = create_env () in
   let var1 = Variable.create "var1" in
   let var1' = Bound_var.create var1 Name_mode.normal in
   let env = TE.add_definition env (Bound_name.var var1') K.value in
@@ -43,7 +50,7 @@ let test_meet_chains_two_vars () =
     Format.eprintf "Final situation:@ %a\n%!" TE.print env
 
 let test_meet_chains_three_vars () =
-  let env = TE.create ~resolver ~get_imported_names ~get_imported_code in
+  let env = create_env () in
   let var1 = Variable.create "var1" in
   let var1' = Bound_var.create var1 Name_mode.normal in
   let env = TE.add_definition env (Bound_name.var var1') K.value in
@@ -81,7 +88,7 @@ let test_meet_chains_three_vars () =
     Format.eprintf "Final situation:@ %a\n%!" TE.print env
 
 let meet_variants_don't_lose_aliases () =
-  let env = TE.create ~resolver ~get_imported_names ~get_imported_code in
+  let env = create_env () in
   let define env v =
     let v' = Bound_var.create v Name_mode.normal in
     TE.add_definition env (Bound_name.var v') K.value
@@ -136,7 +143,7 @@ let test_meet_two_blocks () =
     TE.add_definition env (Bound_name.var v') K.value
   in
   let defines env l = List.fold_left define env l in
-  let env = TE.create ~resolver ~get_imported_names ~get_imported_code in
+  let env = create_env () in
   let block1 = Variable.create "block1" in
   let field1 = Variable.create "field1" in
   let block2 = Variable.create "block2" in

middle_end/flambda2/tests/mlexamples/dune

@@ -0,0 +1,6 @@
+(rule
+ (alias runtest)
+ (action
+  (progn
+   (run ../tools/flexpect.exe tests0.flt)
+   (diff? tests0.flt tests0.flt.corrected))))

middle_end/flambda2/tests/tools/dune

@@ -0,0 +1,7 @@
+(executables
+  (names flexpect fldiff parseflambda)
+  (modes native)
+  (flags (:standard -principal -nostdlib))
+  (libraries
+   stdlib runtime_native ocamlcommon ocamloptcomp
+   flambda2 flambda2_compare flambda2_parser flambda2_terms))

middle_end/flambda2/tests/tools/fldiff.ml

@@ -0,0 +1,26 @@
+open Import
+
+let parse_flambda file =
+  match
+    Parse_flambda.parse ~symbol_for_global:Flambda2.symbol_for_global file
+  with
+  | Ok unit -> unit
+  | 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;
+    exit 1
+
+let _ =
+  let file1 = Sys.argv.(1) in
+  let file2 = Sys.argv.(2) in
+  let unit1 = parse_flambda file1 in
+  let unit2 = parse_flambda file2 in
+  Format.printf "%a@."
+    (Compare.Comparison.print Flambda_unit.print)
+    (Compare.flambda_units unit1 unit2)