flambda-backend: Implement unboxed float literals (#2025)

* implement unboxed float literals

* fix test

* allocation test

* remove unused error

* make unboxed literals alpha

* add native test

* clean up test output

* pass args for alloc test

* remove print_flush

* refactor Untypeast.constant

* add comment

* add missing build_other case

Author: alanechang

boot/menhir/parser.ml

@@ -1187,7 +1187,7 @@ end = struct
 
   let assert_unboxed_literals ~loc =
     Language_extension.(
-      Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Beta)
+      Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Alpha)
 
   let unboxed ~loc x =
     assert_unboxed_literals ~loc:(make_loc loc);

lambda/matching.ml

@@ -1172,6 +1172,7 @@ let can_group discr pat =
   | Constant (Const_char _), Constant (Const_char _)
   | Constant (Const_string _), Constant (Const_string _)
   | Constant (Const_float _), Constant (Const_float _)
+  | Constant (Const_unboxed_float _), Constant (Const_unboxed_float _)
   | Constant (Const_int32 _), Constant (Const_int32 _)
   | Constant (Const_int64 _), Constant (Const_int64 _)
   | Constant (Const_nativeint _), Constant (Const_nativeint _) ->
@@ -1195,7 +1196,7 @@ let can_group discr pat =
       ( Any
       | Constant
           ( Const_int _ | Const_char _ | Const_string _ | Const_float _
-          | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
+          | Const_unboxed_float _ | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
       | Construct _ | Tuple _ | Record _ | Array _ | Variant _ | Lazy ) ) ->
       false
 
@@ -2399,7 +2400,7 @@ let rec do_tests_fail value_kind loc fail tst arg = function
   | [] -> fail
   | (c, act) :: rem ->
       Lifthenelse
-        ( Lprim (tst, [ arg; Lconst (Const_base c) ], loc),
+        ( Lprim (tst, [ arg; c ], loc),
           do_tests_fail value_kind loc fail tst arg rem,
           act, value_kind )
 
@@ -2408,15 +2409,16 @@ let rec do_tests_nofail value_kind loc tst arg = function
   | [ (_, act) ] -> act
   | (c, act) :: rem ->
       Lifthenelse
-        ( Lprim (tst, [ arg; Lconst (Const_base c) ], loc),
+        ( Lprim (tst, [ arg; c ], loc),
           do_tests_nofail value_kind loc tst arg rem,
           act, value_kind )
 
-let make_test_sequence value_kind loc fail tst lt_tst arg const_lambda_list =
+let make_test_sequence value_kind loc fail tst lt_tst arg const_lambda_list transl_const =
   let const_lambda_list = sort_lambda_list const_lambda_list in
   let hs, const_lambda_list, fail =
     share_actions_tree value_kind const_lambda_list fail
   in
+  let const_lambda_list = List.map (fun (c, l) -> transl_const c, l) const_lambda_list in
   let rec make_test_sequence const_lambda_list =
     if List.length const_lambda_list >= 4 && lt_tst <> Pignore then
       split_sequence const_lambda_list
@@ -2429,7 +2431,7 @@ let make_test_sequence value_kind loc fail tst lt_tst arg const_lambda_list =
       rev_split_at (List.length const_lambda_list / 2) const_lambda_list
     in
     Lifthenelse
-      ( Lprim (lt_tst, [ arg; Lconst (Const_base (fst (List.hd list2))) ], loc),
+      ( Lprim (lt_tst, [ arg; fst (List.hd list2) ], loc),
         make_test_sequence list1,
         make_test_sequence list2, value_kind )
   in
@@ -2826,6 +2828,16 @@ let mk_failaction_pos partial seen ctx defs =
 let combine_constant value_kind loc arg cst partial ctx def
     (const_lambda_list, total, _pats) =
   let fail, local_jumps = mk_failaction_neg partial ctx def in
+  let transl_const = function
+  | Const_int c -> Lconst(Const_base (Const_int c))
+  | Const_char c -> Lconst(Const_base (Const_char c))
+  | Const_string (s,loc,d) -> Lconst(Const_base (Const_string (s,loc,d)))
+  | Const_float c -> Lconst(Const_base (Const_float c))
+  | Const_int32 c -> Lconst(Const_base (Const_int32 c))
+  | Const_int64 c -> Lconst(Const_base (Const_int64 c))
+  | Const_nativeint c -> Lconst(Const_base (Const_nativeint c))
+  | Const_unboxed_float f -> Lconst (Const_base (Const_float f))
+  in
   let lambda1 =
     match cst with
     | Const_int _ ->
@@ -2865,22 +2877,28 @@ let combine_constant value_kind loc arg cst partial ctx def
     | Const_float _ ->
         make_test_sequence value_kind loc fail (Pfloatcomp CFneq)
           (Pfloatcomp CFlt) arg
-          const_lambda_list
+          const_lambda_list transl_const
+    | Const_unboxed_float _ ->
+        make_test_sequence value_kind loc fail
+          (Pfloatcomp CFneq)
+          (Pfloatcomp CFlt)
+          (Lprim (Pbox_float Lambda.alloc_local, [arg], loc))
+          const_lambda_list transl_const
     | Const_int32 _ ->
         make_test_sequence value_kind loc fail
           (Pbintcomp (Pint32, Cne))
           (Pbintcomp (Pint32, Clt))
-          arg const_lambda_list
+          arg const_lambda_list transl_const
     | Const_int64 _ ->
         make_test_sequence value_kind loc fail
           (Pbintcomp (Pint64, Cne))
           (Pbintcomp (Pint64, Clt))
-          arg const_lambda_list
+          arg const_lambda_list transl_const
     | Const_nativeint _ ->
         make_test_sequence value_kind loc fail
           (Pbintcomp (Pnativeint, Cne))
           (Pbintcomp (Pnativeint, Clt))
-          arg const_lambda_list
+          arg const_lambda_list transl_const
   in
   (lambda1, Jumps.union local_jumps total)
 

lambda/translcore.ml

@@ -390,7 +390,18 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
       transl_ident (of_location ~scopes e.exp_loc)
         e.exp_env e.exp_type path desc kind
   | Texp_constant cst ->
-      Lconst(Const_base cst)
+    begin match cst with
+    | Const_int c -> Lconst(Const_base (Const_int c))
+    | Const_char c -> Lconst(Const_base (Const_char c))
+    | Const_string (s,loc,d) -> Lconst(Const_base (Const_string (s,loc,d)))
+    | Const_float c -> Lconst(Const_base (Const_float c))
+    | Const_int32 c -> Lconst(Const_base (Const_int32 c))
+    | Const_int64 c -> Lconst(Const_base (Const_int64 c))
+    | Const_nativeint c -> Lconst(Const_base (Const_nativeint c))
+    | Const_unboxed_float f ->
+      Lprim (Punbox_float, [Lconst (Const_base (Const_float f))],
+        of_location ~scopes e.exp_loc)
+    end
   | Texp_let(rec_flag, pat_expr_list, body) ->
       let return_layout = layout_exp sort body in
       transl_let ~scopes ~return_layout rec_flag pat_expr_list

parsing/parser.mly

@@ -962,7 +962,7 @@ end = struct
 
   let assert_unboxed_literals ~loc =
     Language_extension.(
-      Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Beta)
+      Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Alpha)
 
   let unboxed ~loc x =
     assert_unboxed_literals ~loc:(make_loc loc);

testsuite/tests/typing-layouts-float64/alloc.ml

@@ -1,6 +1,6 @@
 (* TEST
    * flambda2
-   flags = "-extension layouts_beta"
+   flags = "-extension layouts_alpha"
    ** native
 *)
 
@@ -167,3 +167,18 @@ let _ =
   let _ = measure_alloc_value (fun () -> cse_test false r) in
   let allocs = get_exact_allocations () in
   Printf.printf "CSE test (0 bytes):\n  allocated bytes: %.2f\n" allocs
+
+let[@inline never] literal_test x y =
+  let open Float_u in
+  (#1. + x) * (y - #4.) / (#3. ** #1.)
+
+let print_allocs s =
+  let allocs = get_exact_allocations () in
+  Printf.printf
+    "%s:\n  allocated bytes: %.2f\n"
+    s allocs
+
+let _ =
+  let r = measure_alloc (fun () -> literal_test #2. #3.) in
+  assert (Float_u.equal r (-#1.));
+  print_allocs "Float literals";

testsuite/tests/typing-layouts-float64/alloc.reference

@@ -18,3 +18,5 @@ Manipulation (0 bytes):
   d: 45.14
 CSE test (0 bytes):
   allocated bytes: 0.00
+Float literals:
+  allocated bytes: 0.00