Merge pull request #446 from chambart/travis_test_flambda

GPR#446: Travis also test flambda

.gitignore

@@ -211,6 +211,7 @@
 /stdlib/sys.ml
 
 /testsuite/**/*.result
+/testsuite/**/*.opt_result
 /testsuite/**/*.byte
 /testsuite/**/*.native
 /testsuite/**/program

.travis-ci.sh

@@ -29,7 +29,8 @@ control.
 ------------------------------------------------------------------------
 EOF
     mkdir -p $PREFIX
-    ./configure --prefix $PREFIX -with-debug-runtime -with-instrumented-runtime
+    ./configure --prefix $PREFIX -with-debug-runtime \
+      -with-instrumented-runtime $CONFIG_ARG
     export PATH=$PREFIX/bin:$PATH
     make world.opt
     make ocamlnat

.travis.yml

@@ -18,6 +18,7 @@ script: bash -ex .travis-ci.sh
 matrix:
   include:
   - env: CI_KIND=build XARCH=i386
+  - env: CI_KIND=build XARCH=i386 CONFIG_ARG=-flambda
   - env: CI_KIND=changes
   - env: CI_KIND=tests
   allow_failures:

middle_end/closure_conversion.ml

@@ -65,6 +65,7 @@ let add_default_argument_wrappers lam =
                (function
                  | (id, Lambda.Lfunction {kind; params; body; attr}) ->
                    Simplif.split_default_wrapper id kind params body attr
+                     ~create_wrapper_body:stubify
                  | _ -> assert false)
                defs)
         in
@@ -106,25 +107,6 @@ let tupled_function_call_stub original_params unboxed_version
     ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline
     ~is_a_functor:false
 
-(** Propagate an [Lev_after] debugging event into an adjacent Flambda node. *)
-let add_debug_info (ev : Lambda.lambda_event) (flam : Flambda.t)
-      : Flambda.t =
-  match ev.lev_kind with
-  | Lev_after _ ->
-    begin match flam with
-    | Apply ap ->
-      Apply { ap with dbg = Debuginfo.from_call ev; }
-    | Let let_expr ->
-      Flambda.map_defining_expr_of_let let_expr ~f:(function
-        | Prim (p, args, _dinfo) ->
-          Prim (p, args, Debuginfo.from_call ev)
-        | defining_expr -> defining_expr)
-    | Send { kind; meth; obj; args; dbg = _; } ->
-      Send { kind; meth; obj; args; dbg = Debuginfo.from_call ev; }
-    | _ -> flam
-    end
-  | _ -> flam
-
 let rec eliminate_const_block (const : Lambda.structured_constant)
       : Lambda.lambda =
   match const with
@@ -136,6 +118,11 @@ let rec eliminate_const_block (const : Lambda.structured_constant)
   | Const_immstring _
   | Const_float_array _ -> Lconst const
 
+let default_debuginfo ?(inner_debuginfo = Debuginfo.none) env_debuginfo =
+  match env_debuginfo with
+  | None -> inner_debuginfo
+  | Some debuginfo -> debuginfo
+
 let rec close_const t env (const : Lambda.structured_constant)
       : Flambda.named * string =
   match const with
@@ -156,7 +143,7 @@ let rec close_const t env (const : Lambda.structured_constant)
   | Const_block _ ->
     Expr (close t env (eliminate_const_block const)), "const_block"
 
-and close t env (lam : Lambda.lambda) : Flambda.t =
+and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
   match lam with
   | Lvar id ->
     begin match Env.find_var_exn env id with
@@ -173,13 +160,17 @@ and close t env (lam : Lambda.lambda) : Flambda.t =
     name_expr cst ~name:("const_" ^ name)
   | Llet ((Strict | Alias | StrictOpt), id, defining_expr, body) ->
     let var = Variable.create_with_same_name_as_ident id in
-    let defining_expr = close_let_bound_expression t var env defining_expr in
+    let defining_expr =
+      close_let_bound_expression t var env defining_expr
+    in
     let body = close t (Env.add_var env id var) body in
     Flambda.create_let var defining_expr body
   | Llet (Variable, id, defining_expr, body) ->
     let mut_var = Mutable_variable.of_ident id in
     let var = Variable.create_with_same_name_as_ident id in
-    let defining_expr = close_let_bound_expression t var env defining_expr in
+    let defining_expr =
+      close_let_bound_expression t var env defining_expr
+    in
     let body = close t (Env.add_mutable_var env id mut_var) body in
     Flambda.create_let var defining_expr (Let_mutable (mut_var, var, body))
   | Lfunction { kind; params; body; attr; } ->
@@ -222,7 +213,10 @@ and close t env (lam : Lambda.lambda) : Flambda.t =
               func = func_var;
               args;
               kind = Indirect;
-              dbg = Debuginfo.from_location Dinfo_call ap_loc;
+              dbg =
+                default_debuginfo
+                  ~inner_debuginfo:(Debuginfo.from_location Dinfo_call ap_loc)
+                  debuginfo;
               inline = ap_inlined;
             })))
   | Lletrec (defs, body) ->
@@ -336,7 +330,7 @@ and close t env (lam : Lambda.lambda) : Flambda.t =
               (Prim (Pintcomp Ceq, [zero; denominator], Debuginfo.none))
                 (If_then_else (is_zero,
                   name_expr (Prim (Praise Raise_regular, [exn],
-                      Debuginfo.none))
+                      default_debuginfo debuginfo))
                     ~name:"dummy",
                   (* CR-someday pchambart: find the right event.
                      mshinwell: I briefly looked at this, and couldn't
@@ -383,12 +377,14 @@ and close t env (lam : Lambda.lambda) : Flambda.t =
         ap_inlined = Default_inline;
       }
     in
-    close t env (Lambda.Lapply apply)
+    close t env ?debuginfo (Lambda.Lapply apply)
   | Lprim (Praise kind, [Levent (arg, event)]) ->
     let arg_var = Variable.create "raise_arg" in
     Flambda.create_let arg_var (Expr (close t env arg))
       (name_expr
-        (Prim (Praise kind, [arg_var], Debuginfo.from_raise event))
+        (Prim (Praise kind, [arg_var],
+               default_debuginfo ~inner_debuginfo:(Debuginfo.from_raise event)
+                 debuginfo))
         ~name:"raise")
   | Lprim (Pfield _, [Lprim (Pgetglobal id, [])])
       when Ident.same id t.current_unit_id ->
@@ -418,7 +414,7 @@ and close t env (lam : Lambda.lambda) : Flambda.t =
       ~evaluation_order:`Right_to_left
       ~name:(name ^ "_arg")
       ~create_body:(fun args ->
-        name_expr (Prim (p, args, Debuginfo.none)) ~name)
+        name_expr (Prim (p, args, default_debuginfo debuginfo)) ~name)
   | Lswitch (arg, sw) ->
     let scrutinee = Variable.create "switch" in
     let aux (i, lam) = i, close t env lam in
@@ -484,7 +480,13 @@ and close t env (lam : Lambda.lambda) : Flambda.t =
     let new_value_var = Variable.create "new_value" in
     Flambda.create_let new_value_var (Expr (close t env new_value))
       (Assign { being_assigned; new_value = new_value_var; })
-  | Levent (lam, ev) -> add_debug_info ev (close t env lam)
+  | Levent (lam, ev) -> begin
+      match ev.lev_kind with
+      | Lev_after _ ->
+          close t env ~debuginfo:(Debuginfo.from_call ev) lam
+      | _ ->
+          close t env lam
+    end
   | Lifused _ ->
     (* [Lifused] is used to mark that this expression should be alive only if
        an identifier is.  Every use should have been removed by

testsuite/tests/backtrace/pr6920_why_at.ml

@@ -1,8 +1,8 @@
-let why : unit -> unit = fun () -> raise Exit
+let why : unit -> unit = fun () -> raise Exit [@@inline never]
 let f () =
   why @@ ();
   ignore (3 + 2);
-  ()
+  () [@@inline never]
 
 let () =
   Printexc.record_backtrace true;

testsuite/tests/backtrace/pr6920_why_swallow.ml

@@ -1,10 +1,10 @@
-let why : unit -> unit = fun () -> raise Exit
+let why : unit -> unit = fun () -> raise Exit [@@inline never]
 let f () =
   for i = 1 to 10 do
     why @@ ();
   done;
   ignore (3 + 2);
-  ()
+  () [@@inline never]
 
 let () =
   Printexc.record_backtrace true;

testsuite/tests/letrec/evaluation_order_2.ml

@@ -11,15 +11,16 @@
 (***********************************************************************)
 
 (* A variant of evaluation_order_1.ml where the side-effects
-   are inside the blocks. Note that this changes the evaluation
-   order, as y is considered recursive.
+   are inside the blocks.
+   Effect are not named to allow different evaluation orders (flambda
+   and clambda differ on this point).
 *)
 type tree = Tree of tree list
 
 let test =
-  let rec x = (Tree [(print_endline "x"; y); z])
-  and y = Tree (print_endline "y"; [])
-  and z = Tree (print_endline "z"; [x])
+  let rec x = (Tree [(print_endline "effect"; y); z])
+  and y = Tree (print_endline "effect"; [])
+  and z = Tree (print_endline "effect"; [x])
   in
   match (x, y, z) with
     | (Tree [y1; z1], Tree[], Tree[x1]) ->

testsuite/tests/letrec/evaluation_order_2.reference

@@ -1,3 +1,3 @@
-x
-y
-z
+effect
+effect
+effect

testsuite/tests/letrec/float_block_1.ml

@@ -10,12 +10,12 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* a bug in cmmgen.ml provokes a change in compilation order between
-   ocamlc and ocamlopt in certain letrec-bindings involving float
-   arrays *)
+(* Effect are not named to allow different evaluation orders (flambda
+   and clambda differ on this point).
+ *)
 let test =
-  let rec x = print_endline "x"; [| 1; 2; 3 |]
-      and y = print_endline "y"; [| 1.; 2.; 3. |]
+  let rec x = print_endline "effect"; [| 1; 2; 3 |]
+      and y = print_endline "effect"; [| 1.; 2.; 3. |]
   in
   assert (x = [| 1; 2; 3 |]);
   assert (y = [| 1.; 2.; 3. |]);

testsuite/tests/letrec/float_block_1.reference

@@ -1,2 +1,2 @@
-x
-y
+effect
+effect

testsuite/tests/misc/ephetest.ml

@@ -40,11 +40,13 @@ let is_key_unset test eph =
 let is_data_unset test eph =
   is_false test "data unset" (K1.check_data eph)
 
-let ra = ref (ref 1)
-let rb = ref (ref (ref 2))
+let make_ra () = ref (ref 1) [@@inline never]
+let make_rb () = ref (ref (ref 2)) [@@inline never]
+let ra = make_ra ()
+let rb = make_rb ()
 
 (** test: key alive data dangling *)
-let () =
+let test1 () =
   let test = "test1" in
   Gc.minor ();
   Gc.full_major ();
@@ -63,9 +65,10 @@ let () =
   Gc.full_major ();
   is_key_unset test eph;
   is_data_unset test eph
+let () = (test1 [@inlined never]) ()
 
 (** test: key dangling data dangling *)
-let () =
+let test2 () =
   let test = "test2" in
   Gc.minor ();
   Gc.full_major ();
@@ -78,10 +81,10 @@ let () =
   Gc.minor ();
   is_key_unset test eph;
   is_data_unset test eph
-
+let () = (test2 [@inlined never]) ()
 
 (** test: key dangling data alive *)
-let () =
+let test3 () =
   let test = "test3" in
   Gc.minor ();
   Gc.full_major ();
@@ -94,9 +97,10 @@ let () =
   Gc.minor ();
   is_key_unset test eph;
   is_data_unset test eph
+let () = (test3 [@inlined never]) ()
 
 (** test: key alive but one away, data dangling *)
-let () =
+let test4 () =
   let test = "test4" in
   Gc.minor ();
   Gc.full_major ();
@@ -110,9 +114,10 @@ let () =
   Gc.minor ();
   is_key_value test eph 3;
   is_data_value test eph 43
+let () = (test4 [@inlined never]) ()
 
 (** test: key dangling but one away, data dangling *)
-let () =
+let test5 () =
   let test = "test5" in
   Gc.minor ();
   Gc.full_major ();
@@ -127,9 +132,10 @@ let () =
   Gc.minor ();
   is_key_unset test eph;
   is_data_unset test eph
+let () = (test5 [@inlined never]) ()
 
 (** test: key accessible from data but all dangling *)
-let () =
+let test6 () =
   let test = "test6" in
   Gc.minor ();
   Gc.full_major ();
@@ -143,6 +149,7 @@ let () =
   Gc.full_major ();
   is_key_unset test eph;
   is_data_unset test eph
+let () = (test6 [@inlined never]) ()
 
 (** test: ephemeron accessible from data but they are dangling *)
 type t =
@@ -151,7 +158,7 @@ type t =
 
 let rc = ref No
 
-let () =
+let test7 () =
   let test = "test7" in
   Gc.minor ();
   Gc.full_major ();
@@ -170,3 +177,4 @@ let () =
   Gc.full_major ();
   Gc.full_major ();
   is_false test "after" (Weak.check weak 0)
+let () = (test7 [@inlined never]) ()

testsuite/tests/regression/pr3612/pr3612.ml

@@ -23,10 +23,11 @@ let test s =
     ignore (Marshal.from_string s 0)
   done
 
-let () =
+let f () =
   init ();
   let s = Marshal.to_string (test_alloc ()) [] in
   test s;
   Gc.full_major ();
   print_int (get_counter ());
   print_newline ()
+let () = (f [@inline never]) ()

testsuite/tests/regression/pr5233/pr5233.ml

@@ -45,18 +45,21 @@ let check o =
      printf " ok\n";
 ;;
 
-Weak.set !smuggle 0 (Some (String.make size ' '));;
+let f () =
+  Weak.set !smuggle 0 (Some (String.make size ' '));
 
-(* Check the data just to make sure. *)
-check (Weak.get !smuggle 0);;
+  (* Check the data just to make sure. *)
+  check (Weak.get !smuggle 0);
 
-(* Get a dangling pointer in W. *)
-Gc.full_major ();;
+  (* Get a dangling pointer in W. *)
+  Gc.full_major ();
 
-(* Fill the heap with other stuff. *)
-let rec fill n accu = if n = 0 then accu else fill (n-1) (123 :: accu);;
-let r = fill ((Gc.stat ()).Gc.heap_words / 3) [];;
-Gc.minor ();;
+  (* Fill the heap with other stuff. *)
+  let rec fill n accu = if n = 0 then accu else fill (n-1) (123 :: accu) in
+  let _r : int list = fill ((Gc.stat ()).Gc.heap_words / 3) [] in
+  Gc.minor ();
 
-(* Now follow the dangling pointer and exhibit the problem. *)
-check (Weak.get !smuggle 0);;
+  (* Now follow the dangling pointer and exhibit the problem. *)
+  check (Weak.get !smuggle 0)
+
+let () = (f [@inlined never]) ()

testsuite/tests/typing-extension-constructor/test.ml

@@ -16,6 +16,10 @@ type t += A;;
 [%extension_constructor A];;
 ([%extension_constructor A] : extension_constructor);;
 
-type extension_constructor = int;;
+module M = struct
+  type extension_constructor = int
+end;;
+
+open M;;
 
 ([%extension_constructor A] : extension_constructor);;

testsuite/tests/typing-extension-constructor/test.ml.reference

@@ -3,11 +3,10 @@
 # type t += A
 #   - : extension_constructor = <abstr>
 # - : extension_constructor = <abstr>
-#   type extension_constructor = int
-#   Characters 2-28:
+#       module M : sig type extension_constructor = int end
+#   #   Characters 2-28:
   ([%extension_constructor A] : extension_constructor);;
    ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type extension_constructor/16
-       but an expression was expected of type
-         extension_constructor/1210 = int
+Error: This expression has type extension_constructor
+       but an expression was expected of type M.extension_constructor = int
 # 

testsuite/tests/warnings/Makefile

@@ -32,6 +32,15 @@ run-all:
 	    && echo " => passed" || echo " => failed"; \
 	  fi \
 	done;
+	@for file in *.opt_backend.ml; do \
+	  printf " ... testing '$$file' with ocamlopt:"; \
+	  if $(BYTECODE_ONLY); then echo " => skipped"; else \
+	    F="`basename $$file .ml`"; \
+	    $(OCAMLOPT) $(FLAGS) -c $$file 2>$$F.$(BACKEND).opt_result; \
+	    $(DIFF) $$F.$(BACKEND).opt_reference $$F.$(BACKEND).opt_result >/dev/null \
+	    && echo " => passed" || echo " => failed"; \
+	  fi \
+	done;
 
 promote: defaultpromote
 
@@ -39,3 +48,9 @@ clean: defaultclean
 	@rm -f *.result *.opt_result
 
 include $(BASEDIR)/makefiles/Makefile.common
+
+ifeq "$(FLAMBDA)" "true"
+BACKEND=flambda
+else
+BACKEND=clambda
+endif

testsuite/tests/warnings/w55.opt_backend.flambda.opt_reference

@@ -0,0 +1,6 @@
+File "w55.opt_backend.ml", line 12, characters 10-26:
+Warning 55: Inlining impossible in this context: [@inlined] attributes may not be used on partial applications
+File "w55.opt_backend.ml", line 8, characters 10-27:
+Warning 55: Inlining impossible in this context: [@inlined] attribute was not used on this function application (the optimizer did not know what function was being applied)
+File "w55.opt_backend.ml", line 18, characters 12-30:
+Warning 55: Inlining impossible in this context: [@inlined] attribute was not used on this function application (the optimizer did not know what function was being applied)