flambda-backend: Change lambda constant type to support native unboxed float (#2071)

* change lambda constant type

* fix upstream

* fix test

* remove the transl_constant function

* define declare_const_result type

* better error messages

Author: alanechang

bytecomp/emitcode.ml

@@ -17,7 +17,6 @@
 
 open Config
 open Misc
-open Asttypes
 open Lambda
 open Instruct
 open Opcodes

bytecomp/symtable.ml

@@ -18,7 +18,6 @@
 (* To assign numbers to globals and primitives *)
 
 open Misc
-open Asttypes
 open Lambda
 open Cmo_format
 
@@ -149,7 +148,8 @@ let rec transl_const = function
     Const_base(Const_int i) -> Obj.repr i
   | Const_base(Const_char c) -> Obj.repr c
   | Const_base(Const_string (s, _, _)) -> Obj.repr s
-  | Const_base(Const_float f) -> Obj.repr (float_of_string f)
+  | Const_base(Const_float f)
+  | Const_base(Const_unboxed_float f) -> Obj.repr (float_of_string f)
   | Const_base(Const_int32 i) -> Obj.repr i
   | Const_base(Const_int64 i) -> Obj.repr i
   | Const_base(Const_nativeint i) -> Obj.repr i

lambda/lambda.ml

@@ -16,6 +16,8 @@
 open Misc
 open Asttypes
 
+type constant = Typedtree.constant
+
 type mutable_flag = Immutable | Immutable_unique | Mutable
 
 type compile_time_constant =
@@ -1094,19 +1096,6 @@ let transl_prim mod_name name =
   | exception Not_found ->
       fatal_error ("Primitive " ^ name ^ " not found.")
 
-(* Translation of constants *)
-
-let transl_constant loc (cst : Typedtree.constant) = 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))], loc)
-
 (* Compile a sequence of expressions *)
 
 let rec make_sequence fn = function
@@ -1546,13 +1535,14 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Patomic_fetch_add
   | Pdls_get -> None
 
-let constant_layout = function
+let constant_layout: constant -> layout = function
   | Const_int _ | Const_char _ -> Pvalue Pintval
   | Const_string _ -> Pvalue Pgenval
   | Const_int32 _ -> Pvalue (Pboxedintval Pint32)
   | Const_int64 _ -> Pvalue (Pboxedintval Pint64)
   | Const_nativeint _ -> Pvalue (Pboxedintval Pnativeint)
   | Const_float _ -> Pvalue Pfloatval
+  | Const_unboxed_float _ -> Punboxed_float
 
 let structured_constant_layout = function
   | Const_base const -> constant_layout const

lambda/lambda.mli

@@ -17,6 +17,8 @@
 
 open Asttypes
 
+type constant = Typedtree.constant
+
 (* Overriding Asttypes.mutable_flag *)
 type mutable_flag = Immutable | Immutable_unique | Mutable
 
@@ -665,8 +667,6 @@ val transl_prim: string -> string -> lambda
     ]}
 *)
 
-val transl_constant : scoped_location -> Typedtree.constant -> lambda
-
 val free_variables: lambda -> Ident.Set.t
 
 val transl_module_path: scoped_location -> Env.t -> Path.t -> lambda

lambda/matching.ml

@@ -2400,7 +2400,7 @@ let rec do_tests_fail value_kind loc fail tst arg = function
   | [] -> fail
   | (c, act) :: rem ->
       Lifthenelse
-        ( Lprim (tst, [ arg; c ], loc),
+        ( Lprim (tst, [ arg; Lconst (Const_base c) ], loc),
           do_tests_fail value_kind loc fail tst arg rem,
           act, value_kind )
 
@@ -2409,16 +2409,15 @@ let rec do_tests_nofail value_kind loc tst arg = function
   | [ (_, act) ] -> act
   | (c, act) :: rem ->
       Lifthenelse
-        ( Lprim (tst, [ arg; c ], loc),
+        ( Lprim (tst, [ arg; Lconst (Const_base 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 transl_const =
+let make_test_sequence value_kind loc fail tst lt_tst arg const_lambda_list =
   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
@@ -2431,7 +2430,7 @@ let make_test_sequence value_kind loc fail tst lt_tst arg const_lambda_list tran
       rev_split_at (List.length const_lambda_list / 2) const_lambda_list
     in
     Lifthenelse
-      ( Lprim (lt_tst, [ arg; fst (List.hd list2) ], loc),
+      ( Lprim (lt_tst, [ arg; Lconst (Const_base (fst (List.hd list2))) ], loc),
         make_test_sequence list1,
         make_test_sequence list2, value_kind )
   in
@@ -2828,7 +2827,6 @@ 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 = transl_constant loc in
   let lambda1 =
     match cst with
     | Const_int _ ->
@@ -2868,27 +2866,27 @@ 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 transl_const
+          const_lambda_list
     | Const_unboxed_float _ ->
         make_test_sequence value_kind loc fail
           (Punboxed_float_comp CFneq)
           (Punboxed_float_comp CFlt)
-          arg const_lambda_list transl_const
+          arg const_lambda_list
     | Const_int32 _ ->
         make_test_sequence value_kind loc fail
           (Pbintcomp (Pint32, Cne))
           (Pbintcomp (Pint32, Clt))
-          arg const_lambda_list transl_const
+          arg const_lambda_list
     | Const_int64 _ ->
         make_test_sequence value_kind loc fail
           (Pbintcomp (Pint64, Cne))
           (Pbintcomp (Pint64, Clt))
-          arg const_lambda_list transl_const
+          arg const_lambda_list
     | Const_nativeint _ ->
         make_test_sequence value_kind loc fail
           (Pbintcomp (Pnativeint, Cne))
           (Pbintcomp (Pnativeint, Clt))
-          arg const_lambda_list transl_const
+          arg const_lambda_list
   in
   (lambda1, Jumps.union local_jumps total)
 

lambda/printlambda.ml

@@ -26,6 +26,14 @@ let rec struct_const ppf = function
   | Const_base(Const_string (s, _, _)) -> fprintf ppf "%S" s
   | Const_immstring s -> fprintf ppf "#%S" s
   | Const_base(Const_float f) -> fprintf ppf "%s" f
+  | Const_base(Const_unboxed_float f) ->
+    let s =
+      match String.split_on_char '-' f with
+      | [""; f] -> "-#" ^ f
+      | [f] -> "#" ^ f
+      | _ -> Misc.fatal_errorf "Invalid Const_unboxed_float constant: %s" f
+    in
+    fprintf ppf "%s" s
   | Const_base(Const_int32 n) -> fprintf ppf "%lil" n
   | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n
   | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n

lambda/simplif.ml

@@ -16,7 +16,6 @@
 (* Elimination of useless Llet(Alias) bindings.
    Also transform let-bound references into variables. *)
 
-open Asttypes
 open Lambda
 open Debuginfo.Scoped_location
 

lambda/translcore.ml

@@ -389,7 +389,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
   | Texp_ident(path, _, desc, kind, _) ->
       transl_ident (of_location ~scopes e.exp_loc)
         e.exp_env e.exp_type path desc kind
-  | Texp_constant cst -> transl_constant (of_location ~scopes e.exp_loc) cst
+  | Texp_constant cst -> Lconst (Const_base cst)
   | 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

lambda/translobj.ml

@@ -13,7 +13,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Asttypes
 open Lambda
 
 (* Get oo primitives identifiers *)

lambda/translprim.ml

@@ -15,7 +15,6 @@
 
 (* Translation of primitives *)
 
-open Asttypes
 open Primitive
 open Types
 open Typedtree

middle_end/closure/closure.ml

@@ -16,7 +16,6 @@
 (* Introduction of closures, uncurrying, recognition of direct calls *)
 
 open Misc
-open Asttypes
 open Primitive
 open Lambda
 open Switch
@@ -1028,6 +1027,9 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env)
         | Const_base (Const_string (s, _, _)) ->
             str (Uconst_string s)
         | Const_base(Const_float x) -> str (Uconst_float (float_of_string x))
+        | Const_base(Const_unboxed_float _) ->
+            (* CR alanechang: implement unboxed float constants in closure *)
+            Misc.fatal_error "Unboxed float constants are not supported in closure. Consider using flambda2."
         | Const_base(Const_int32 x) -> str (Uconst_int32 x)
         | Const_base(Const_int64 x) -> str (Uconst_int64 x)
         | Const_base(Const_nativeint x) -> str (Uconst_nativeint x)

middle_end/flambda/closure_conversion.ml

@@ -123,6 +123,9 @@ let rec declare_const t (const : Lambda.structured_constant)
   match const with
   | Const_base (Const_int c) -> (Const (Int c), Names.const_int)
   | Const_base (Const_char c) -> (Const (Char c), Names.const_char)
+  | Const_base (Const_unboxed_float _) ->
+    (* CR alanechang: implement unboxed float constants in flambda *)
+    Misc.fatal_error "Unboxed float constants are not supported in flambda. Consider using flambda2."
   | Const_base (Const_string (s, _, _)) ->
     let const, name =
       (Flambda.Allocated_const (Immutable_string s),

testsuite/tests/typing-layouts/literals_native.ml

@@ -1,7 +1,8 @@
 (* TEST
+   * flambda2
    flags = "-extension layouts_alpha"
-   * native
-   * bytecode
+   ** native
+   ** bytecode
 *)
 
 (*****************************************)