change lambda constant type

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,7 @@ 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 _) -> Misc.fatal_error "XXX unboxed float not supported in closure"
         | 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,7 @@ 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 _) -> Misc.fatal_error "XXX unboxed float not supported in flambda1"
   | Const_base (Const_string (s, _, _)) ->
     let const, name =
       (Flambda.Allocated_const (Immutable_string s),

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -88,19 +88,25 @@ 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 * [> `Field of Field_of_static_block.t] * 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
+    * [ `Field of Field_of_static_block.t
+      | `Unboxed_float of Numeric_types.Float_by_bit_pattern.t ]
+    * 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,11 @@ 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_error
+              "Unboxed floats are not allowed inside of Const_block")
         acc consts
     in
     let const : SC.t =
@@ -153,13 +163,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 =
@@ -1096,16 +1098,7 @@ let transl_prim mod_name name =
 
 (* 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)
+let transl_constant (cst : Typedtree.constant) = Lconst(Const_base cst)
 
 (* Compile a sequence of expressions *)
 
@@ -1546,13 +1539,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,7 +667,7 @@ val transl_prim: string -> string -> lambda
     ]}
 *)
 
-val transl_constant : scoped_location -> Typedtree.constant -> lambda
+val transl_constant : Typedtree.constant -> lambda
 
 val free_variables: lambda -> Ident.Set.t
 

ocaml/lambda/matching.ml

@@ -2828,7 +2828,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 +2867,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 transl_constant
     | 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 transl_constant
     | 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 transl_constant
     | 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 transl_constant
     | 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 transl_constant
   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
+      | _ -> assert false
+    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 -> transl_constant 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

@@ -1028,6 +1028,7 @@ 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 _) -> Misc.fatal_error "XXX unboxed float not supported in closure"
         | 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,7 @@ 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 _) -> Misc.fatal_error "XXX unboxed float not supported in flambda1"
   | Const_base (Const_string (s, _, _)) ->
     let const, name =
       (Flambda.Allocated_const (Immutable_string s),