flambda-backend: Punboxed_float_comp lambda primitive (#2062)

.depend

@@ -3937,6 +3937,7 @@ lambda/lambda.cmi : \
     typing/types.cmi \
     typing/subst.cmi \
     typing/primitive.cmi \
+    typing/typedtree.cmi \
     typing/path.cmi \
     parsing/location.cmi \
     typing/ident.cmi \

asmcomp/cmmgen.ml

@@ -663,7 +663,7 @@ let rec transl env e =
          | Pufloatfield _ | Psetufloatfield (_, _)
          | Praise _ | Pdivint _ | Pmodint _ | Pintcomp _ | Poffsetint _
          | Pcompare_ints | Pcompare_floats | Pcompare_bints _
-         | Poffsetref _ | Pfloatcomp _ | Parraylength _
+         | Poffsetref _ | Pfloatcomp _ | Punboxed_float_comp _ | Parraylength _
          | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _
          | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _
          | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _
@@ -1021,7 +1021,7 @@ and transl_prim_1 env p arg dbg =
     | Pmakeufloatblock (_, _)
     | Psetfloatfield (_, _) | Pduprecord (_, _) | Pccall _ | Pdivint _
     | Psetufloatfield (_, _)
-    | Pmodint _ | Pintcomp _ | Pfloatcomp _ | Pmakearray (_, _, _)
+    | Pmodint _ | Pintcomp _ | Pfloatcomp _ | Punboxed_float_comp _ | Pmakearray (_, _, _)
     | Pcompare_ints | Pcompare_floats | Pcompare_bints _
     | Pduparray (_, _) | Parrayrefu _ | Parraysetu _
     | Parrayrefs _ | Parraysets _ | Paddbint _ | Psubbint _ | Pmulbint _
@@ -1131,6 +1131,11 @@ and transl_prim_2 env p arg1 arg2 dbg =
                   [transl_unbox_float dbg env arg1;
                    transl_unbox_float dbg env arg2],
                   dbg)) dbg
+  | Punboxed_float_comp cmp ->
+      tag_int(Cop(Ccmpf cmp,
+                  [transl env arg1;
+                   transl env arg2],
+                  dbg)) dbg
 
   (* String operations *)
   | Pstringrefu | Pbytesrefu ->
@@ -1311,7 +1316,8 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
   | Pmakeufloatblock (_, _) | Pufloatfield _ | Psetufloatfield (_, _)
   | Pduprecord (_, _) | Pccall _ | Praise _ | Pdivint _ | Pmodint _ | Pintcomp _
   | Pcompare_ints | Pcompare_floats | Pcompare_bints _
-  | Poffsetint _ | Poffsetref _ | Pfloatcomp _ | Pmakearray (_, _, _)
+  | Poffsetint _ | Poffsetref _ | Pfloatcomp _ | Punboxed_float_comp _
+  | Pmakearray (_, _, _)
   | Pduparray (_, _) | Parraylength _ | Parrayrefu _ | Parrayrefs _
   | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _
   | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _

bytecomp/bytegen.ml

@@ -128,7 +128,8 @@ let preserve_tailcall_for_prim = function
   | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat
   | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _
   | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
-  | Pdivfloat _ | Pfloatcomp _ | Pstringlength | Pstringrefu  | Pstringrefs
+  | Pdivfloat _ | Pfloatcomp _| Punboxed_float_comp _
+  | Pstringlength | Pstringrefu  | Pstringrefs
   | Pcompare_ints | Pcompare_floats | Pcompare_bints _
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
   | Pmakearray _ | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _
@@ -578,7 +579,7 @@ let comp_primitive stack_info p sz args =
   | Pnot | Psequand | Psequor
   | Praise _
   | Pmakearray _ | Pduparray _
-  | Pfloatcomp _
+  | Pfloatcomp _ | Punboxed_float_comp _
   | Pmakeblock _
   | Pmakefloatblock _
   | Pmakeufloatblock _
@@ -877,7 +878,7 @@ let rec comp_expr stack_info env exp sz cont =
       let nargs = List.length args - 1 in
       comp_args stack_info env args sz
         (comp_primitive stack_info p (sz + nargs - 1) args :: cont)
-  | Lprim (Pfloatcomp cmp, args, _) ->
+  | Lprim (Pfloatcomp cmp, args, _) | Lprim (Punboxed_float_comp cmp, args, _) ->
       let cont =
         match cmp with
         | CFeq -> Kccall("caml_eq_float", 2) :: cont

lambda/lambda.ml

@@ -181,6 +181,7 @@ type primitive =
   | Paddfloat of alloc_mode | Psubfloat of alloc_mode
   | Pmulfloat of alloc_mode | Pdivfloat of alloc_mode
   | Pfloatcomp of float_comparison
+  | Punboxed_float_comp of float_comparison
   (* String operations *)
   | Pstringlength | Pstringrefu  | Pstringrefs
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
@@ -1093,6 +1094,19 @@ 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
@@ -1471,7 +1485,7 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Pnegfloat m | Pabsfloat m
   | Paddfloat m | Psubfloat m
   | Pmulfloat m | Pdivfloat m -> Some m
-  | Pfloatcomp _ -> None
+  | Pfloatcomp _ | Punboxed_float_comp _ -> None
   | Pstringlength | Pstringrefu  | Pstringrefs
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets -> None
   | Pmakearray (_, _, m) -> Some m
@@ -1593,7 +1607,7 @@ let primitive_result_layout (p : primitive) =
   | Plslint | Plsrint | Pasrint
   | Pintcomp _
   | Pcompare_ints | Pcompare_floats | Pcompare_bints _
-  | Poffsetint _ | Pintoffloat | Pfloatcomp _
+  | Poffsetint _ | Pintoffloat | Pfloatcomp _ | Punboxed_float_comp _
   | Pstringlength | Pstringrefu | Pstringrefs
   | Pbyteslength | Pbytesrefu | Pbytesrefs
   | Parraylength _ | Pisint _ | Pisout | Pintofbint _

lambda/lambda.mli

@@ -140,6 +140,7 @@ type primitive =
   | Paddfloat of alloc_mode | Psubfloat of alloc_mode
   | Pmulfloat of alloc_mode | Pdivfloat of alloc_mode
   | Pfloatcomp of float_comparison
+  | Punboxed_float_comp of float_comparison
   (* String operations *)
   | Pstringlength | Pstringrefu  | Pstringrefs
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
@@ -664,6 +665,8 @@ 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

@@ -2828,16 +2828,7 @@ 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 transl_const = transl_constant loc in
   let lambda1 =
     match cst with
     | Const_int _ ->
@@ -2880,10 +2871,9 @@ let combine_constant value_kind loc arg cst partial ctx def
           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
+          (Punboxed_float_comp CFneq)
+          (Punboxed_float_comp CFlt)
+          arg const_lambda_list transl_const
     | Const_int32 _ ->
         make_test_sequence value_kind loc fail
           (Pbintcomp (Pint32, Cne))

lambda/printlambda.ml

@@ -399,6 +399,7 @@ let primitive ppf = function
   | Pmulfloat m -> fprintf ppf "*.%s" (alloc_kind m)
   | Pdivfloat m -> fprintf ppf "/.%s" (alloc_kind m)
   | Pfloatcomp(cmp) -> float_comparison ppf cmp
+  | Punboxed_float_comp(cmp) -> fprintf ppf "%a (unboxed)" float_comparison cmp
   | Pstringlength -> fprintf ppf "string.length"
   | Pstringrefu -> fprintf ppf "string.unsafe_get"
   | Pstringrefs -> fprintf ppf "string.get"
@@ -621,6 +622,7 @@ let name_of_primitive = function
   | Pmulfloat _ -> "Pmulfloat"
   | Pdivfloat _ -> "Pdivfloat"
   | Pfloatcomp _ -> "Pfloatcomp"
+  | Punboxed_float_comp _ -> "Punboxed_float_comp"
   | Pstringlength -> "Pstringlength"
   | Pstringrefu -> "Pstringrefu"
   | Pstringrefs -> "Pstringrefs"

lambda/tmc.ml

@@ -890,7 +890,7 @@ let rec choice ctx t =
     | Pintoffloat | Pfloatofint _
     | Pnegfloat _ | Pabsfloat _
     | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _
-    | Pfloatcomp _
+    | Pfloatcomp _ | Punboxed_float_comp _
     | Pstringlength | Pstringrefu  | Pstringrefs
     | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
     | Parraylength _ | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _

lambda/translcore.ml

@@ -389,19 +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 ->
-    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_constant cst -> transl_constant (of_location ~scopes e.exp_loc) 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/translprim.ml

@@ -1040,7 +1040,8 @@ let lambda_primitive_needs_event_after = function
   | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
   | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat
   | Pcompare_ints | Pcompare_floats
-  | Pfloatcomp _ | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu
+  | Pfloatcomp _ | Punboxed_float_comp _
+  | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu
   | Pbytessetu | Pmakearray ((Pintarray | Paddrarray | Pfloatarray), _, _)
   | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisout
   | Pprobe_is_enabled _

middle_end/clambda_primitives.ml

@@ -74,6 +74,7 @@ type primitive =
   | Paddfloat of alloc_mode | Psubfloat of alloc_mode
   | Pmulfloat of alloc_mode | Pdivfloat of alloc_mode
   | Pfloatcomp of float_comparison
+  | Punboxed_float_comp of float_comparison
   (* String operations *)
   | Pstringlength | Pstringrefu  | Pstringrefs
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
@@ -246,7 +247,7 @@ let result_layout (p : primitive) =
   | Plslint | Plsrint | Pasrint
   | Pintcomp _
   | Pcompare_ints | Pcompare_floats | Pcompare_bints _
-  | Poffsetint _ | Pintoffloat | Pfloatcomp _
+  | Poffsetint _ | Pintoffloat | Pfloatcomp _ | Punboxed_float_comp _
   | Pstringlength | Pstringrefu | Pstringrefs
   | Pbyteslength | Pbytesrefu | Pbytesrefs
   | Parraylength _ | Pisint | Pisout | Pintofbint _

middle_end/clambda_primitives.mli

@@ -74,6 +74,7 @@ type primitive =
   | Paddfloat of alloc_mode | Psubfloat of alloc_mode
   | Pmulfloat of alloc_mode | Pdivfloat of alloc_mode
   | Pfloatcomp of float_comparison
+  | Punboxed_float_comp of float_comparison
   (* String operations *)
   | Pstringlength | Pstringrefu  | Pstringrefs
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets

middle_end/convert_primitives.ml

@@ -87,6 +87,7 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
   | Pmulfloat m -> Pmulfloat m
   | Pdivfloat m -> Pdivfloat m
   | Pfloatcomp comp -> Pfloatcomp comp
+  | Punboxed_float_comp comp -> Punboxed_float_comp comp
   | Pstringlength -> Pstringlength
   | Pstringrefu -> Pstringrefu
   | Pstringrefs -> Pstringrefs

middle_end/internal_variable_names.ml

@@ -119,6 +119,7 @@ let pduprecord = "Pduprecord"
 let pfield = "Pfield"
 let pfield_computed = "Pfield_computed"
 let pfloatcomp = "Pfloatcomp"
+let punboxed_float_comp = "Punboxed_float_comp"
 let pfloatfield = "Pfloatfield"
 let pufloatfield = "Pufloatfield"
 let pfloatofint = "Pfloatofint"
@@ -242,6 +243,7 @@ let pduprecord_arg = "Pduprecord_arg"
 let pfield_arg = "Pfield_arg"
 let pfield_computed_arg = "Pfield_computed_arg"
 let pfloatcomp_arg = "Pfloatcomp_arg"
+let punboxed_float_comp_arg = "Punboxed_float_comp_arg"
 let pfloatfield_arg = "Pfloatfield_arg"
 let pufloatfield_arg = "Pufloatfield_arg"
 let pfloatofint_arg = "Pfloatofint_arg"
@@ -419,6 +421,7 @@ let of_primitive : Lambda.primitive -> string = function
   | Pmulfloat _ -> pmulfloat
   | Pdivfloat _ -> pdivfloat
   | Pfloatcomp _ -> pfloatcomp
+  | Punboxed_float_comp _ -> punboxed_float_comp
   | Pstringlength -> pstringlength
   | Pstringrefu -> pstringrefu
   | Pstringrefs -> pstringrefs
@@ -553,6 +556,7 @@ let of_primitive_arg : Lambda.primitive -> string = function
   | Pmulfloat _ -> pmulfloat_arg
   | Pdivfloat _ -> pdivfloat_arg
   | Pfloatcomp _ -> pfloatcomp_arg
+  | Punboxed_float_comp _ -> punboxed_float_comp_arg
   | Pstringlength -> pstringlength_arg
   | Pstringrefu -> pstringrefu_arg
   | Pstringrefs -> pstringrefs_arg

middle_end/printclambda_primitives.ml

@@ -207,6 +207,8 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
   | Pmulfloat m -> fprintf ppf "*.%s" (alloc_kind m)
   | Pdivfloat m -> fprintf ppf "/.%s" (alloc_kind m)
   | Pfloatcomp(cmp) -> Printlambda.float_comparison ppf cmp
+  | Punboxed_float_comp(cmp) ->
+    fprintf ppf "%a (unboxed)" Printlambda.float_comparison cmp
   | Pstringlength -> fprintf ppf "string.length"
   | Pstringrefu -> fprintf ppf "string.unsafe_get"
   | Pstringrefs -> fprintf ppf "string.get"

middle_end/semantics_of_primitives.ml

@@ -75,7 +75,8 @@ let for_primitive (prim : Clambda_primitives.primitive) =
   | Poffsetref _ -> Arbitrary_effects, Has_coeffects
   | Punbox_float | Punbox_int _
   | Pintoffloat
-  | Pfloatcomp _ -> No_effects, No_coeffects
+  | Pfloatcomp _
+  | Punboxed_float_comp _ -> No_effects, No_coeffects
   | Pbox_float m | Pbox_int (_, m)
   | Pfloatofint m
   | Pnegfloat m
@@ -215,7 +216,8 @@ let may_locally_allocate (prim:Clambda_primitives.primitive) : bool =
   | Poffsetref _ -> false
   | Punbox_float | Punbox_int _
   | Pintoffloat
-  | Pfloatcomp _ -> false
+  | Pfloatcomp _
+  | Punboxed_float_comp _ -> false
   | Pbox_float m | Pbox_int (_, m)
   | Pfloatofint m
   | Pnegfloat m

otherlibs/dynlink/Makefile

@@ -117,6 +117,7 @@ COMPILERLIBS_SOURCES=\
   typing/jkind.ml \
   typing/primitive.ml \
   typing/types.ml \
+  typing/typedtree.ml \
   typing/btype.ml \
   typing/subst.ml \
   typing/predef.ml \

otherlibs/dynlink/dune

@@ -104,6 +104,7 @@
     symtable
     asttypes
     parsetree
+    typedtree
     outcometree
     cmo_format
     cmxs_format
@@ -178,6 +179,7 @@
 (copy_files ../../typing/subst.ml)
 (copy_files ../../typing/predef.ml)
 (copy_files ../../typing/datarepr.ml)
+(copy_files ../../typing/typedtree.ml)
 (copy_files ../../file_formats/cmi_format.ml)
 (copy_files ../../typing/persistent_env.ml)
 (copy_files ../../typing/env.ml)
@@ -240,6 +242,7 @@
 (copy_files ../../typing/subst.mli)
 (copy_files ../../typing/predef.mli)
 (copy_files ../../typing/datarepr.mli)
+(copy_files ../../typing/typedtree.mli)
 (copy_files ../../file_formats/cmi_format.mli)
 (copy_files ../../typing/persistent_env.mli)
 (copy_files ../../typing/env.mli)

testsuite/tests/typing-layouts/literals_native.ml

@@ -59,3 +59,18 @@ let f x =
 ;;
 
 test "result" (f #7.);;
+
+let f x =
+  match x with
+  | #4. -> #0.
+  | #5. -> #1.
+  | #6. -> #2.
+  | #7. -> #3.
+  | #8. -> #4.
+  | #9. -> #5.
+  | #10. -> #6.
+  | #11. -> #7.
+  | x ->  x
+;;
+
+test "larger match result" (f #7.);;

testsuite/tests/typing-layouts/literals_native.reference

@@ -11,3 +11,4 @@ one_billion: 1000000000.000000
 one_twenty_seven_point_two_five_in_floating_hex: 127.250000
 five_point_three_seven_five_in_floating_hexponent: 5.375000
 result: 7.000000
+larger match result: 3.000000