Change lambda constant type to support native unboxed float

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
@@ -1055,6 +1054,9 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env)
                  that one could modify our string literal.  *)
             str ~shared:true (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

@@ -124,6 +124,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),

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -47,6 +47,10 @@ type close_functions_result =
   | Lifted of (Symbol.t * Env.value_approximation) Function_slot.Lmap.t
   | Dynamic of Set_of_closures.t * Env.value_approximation Function_slot.Map.t
 
+type declare_const_result =
+  | Field of Field_of_static_block.t
+  | Unboxed_float of Numeric_types.Float_by_bit_pattern.t
+
 let manufacture_symbol acc proposed_name =
   let acc, linkage_name =
     if Flambda_features.Expert.shorten_symbol_names ()
@@ -88,19 +92,21 @@ let register_const0 acc constant name =
     acc, symbol
   | symbol -> acc, symbol
 
-let register_const acc constant name : Acc.t * Field_of_static_block.t * string
-    =
+let register_const acc constant name : Acc.t * declare_const_result * string =
   let acc, symbol = register_const0 acc constant name in
-  acc, Symbol symbol, name
+  acc, Field (Symbol symbol), name
 
 let rec declare_const acc (const : Lambda.structured_constant) :
-    Acc.t * Field_of_static_block.t * string =
+    Acc.t * declare_const_result * string =
   let module SC = Static_const in
   match const with
   | Const_base (Const_int c) ->
-    acc, Tagged_immediate (Targetint_31_63.of_int c), "int"
+    acc, Field (Tagged_immediate (Targetint_31_63.of_int c)), "int"
   | Const_base (Const_char c) ->
-    acc, Tagged_immediate (Targetint_31_63.of_char c), "char"
+    acc, Field (Tagged_immediate (Targetint_31_63.of_char c)), "char"
+  | Const_base (Const_unboxed_float c) ->
+    let c = Numeric_types.Float_by_bit_pattern.create (float_of_string c) in
+    acc, Unboxed_float c, "unboxed_float"
   | Const_base (Const_string (s, _, _)) ->
     register_const acc (SC.immutable_string s) "immstring"
   | Const_base (Const_float c) ->
@@ -142,7 +148,12 @@ let rec declare_const acc (const : Lambda.structured_constant) :
       List.fold_left_map
         (fun acc c ->
           let acc, f, _ = declare_const acc c in
-          acc, f)
+          match f with
+          | Field f -> acc, f
+          | Unboxed_float _ ->
+            Misc.fatal_errorf
+              "Unboxed floats are not allowed inside of Const_block: %a"
+              Printlambda.structured_constant const)
         acc consts
     in
     let const : SC.t =
@@ -153,13 +164,19 @@ let rec declare_const acc (const : Lambda.structured_constant) :
 let close_const0 acc (const : Lambda.structured_constant) =
   let acc, const, name = declare_const acc const in
   match const with
-  | Tagged_immediate i ->
+  | Field (Tagged_immediate i) ->
     ( acc,
       Simple.const (Reg_width_const.tagged_immediate i),
       name,
       Flambda_kind.With_subkind.tagged_immediate )
-  | Symbol s -> acc, Simple.symbol s, name, Flambda_kind.With_subkind.any_value
-  | Dynamically_computed _ ->
+  | Unboxed_float f ->
+    ( acc,
+      Simple.const (Reg_width_const.naked_float f),
+      name,
+      Flambda_kind.With_subkind.naked_float )
+  | Field (Symbol s) ->
+    acc, Simple.symbol s, name, Flambda_kind.With_subkind.any_value
+  | Field (Dynamically_computed _) ->
     Misc.fatal_errorf "Declaring a computed constant %s" name
 
 let close_const acc const =

middle_end/flambda2/from_lambda/dissect_letrec.ml

@@ -14,7 +14,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Asttypes
 open Lambda
 
 (* Converts let-rec containing values into an initialization then assignment

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -752,8 +752,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation)
       (Flambda_arity.Component_for_creation.Singleton kind)
   | Lconst const ->
     apply_cps_cont_simple k acc env ccenv [IR.Const const]
-      (* CR mshinwell: improve layout here *)
-      (Singleton Flambda_kind.With_subkind.any_value)
+      (Singleton
+         (Flambda_kind.With_subkind.from_lambda_values_and_unboxed_numbers_only
+            (Lambda.structured_constant_layout const)))
   | Lapply
       { ap_func;
         ap_args;
@@ -814,17 +815,12 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation)
     in
     let_expr acc ccenv
   | Llet ((Strict | Alias | StrictOpt), layout, id, Lconst const, body) ->
-    let value_kind =
-      match layout with
-      | Pvalue value_kind -> value_kind
-      | Ptop | Pbottom | Punboxed_float | Punboxed_int _ | Punboxed_vector _
-      | Punboxed_product _ ->
-        Misc.fatal_errorf "Constant with non-value layout: %a %a"
-          Printlambda.structured_constant const Printlambda.layout layout
-    in
     (* This case avoids extraneous continuations. *)
     let body acc ccenv = cps acc env ccenv body k k_exn in
-    let kind = Flambda_kind.With_subkind.from_lambda_value_kind value_kind in
+    let kind =
+      Flambda_kind.With_subkind.from_lambda_values_and_unboxed_numbers_only
+        layout
+    in
     CC.close_let acc ccenv
       [id, kind]
       (is_user_visible env id) (Simple (Const const)) ~body

ocaml/bytecomp/emitcode.ml

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

ocaml/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

ocaml/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

ocaml/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

ocaml/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)
 

ocaml/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

ocaml/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
 

ocaml/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

ocaml/lambda/translobj.ml

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

ocaml/lambda/translprim.ml

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

ocaml/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)

ocaml/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),

ocaml/testsuite/tests/typing-layouts/literals_native.ml

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