diff --git a/boot/ocamlc b/boot/ocamlc index 48c91d11ceb..b480100daa4 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamllex b/boot/ocamllex index 395148c8ca7..84f92d84de3 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 602a70d683e..b2e56fc9ab8 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -112,7 +112,8 @@ let preserve_tailcall_for_prim = function Pidentity | Popaque | Pdirapply | Prevapply | Psequor | Psequand -> true | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _ - | Pmakeblock _ | Pfield _ | Pfield_computed | Psetfield _ + | Pmakeblock _ | Pmakefloatblock _ + | Pfield _ | Pfield_computed | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint @@ -210,7 +211,8 @@ let rec size_of_lambda env = function | Lprim(Pmakeblock _, args, _) -> RHS_block (List.length args) | Lprim (Pmakearray ((Paddrarray|Pintarray), _), args, _) -> RHS_block (List.length args) - | Lprim (Pmakearray (Pfloatarray, _), args, _) -> + | Lprim (Pmakearray (Pfloatarray, _), args, _) + | Lprim (Pmakefloatblock _, args, _) -> RHS_floatblock (List.length args) | Lprim (Pmakearray (Pgenarray, _), _, _) -> (* Pgenarray is excluded from recursive bindings by the @@ -736,6 +738,9 @@ let rec comp_expr env exp sz cont = (Kpush:: Kconst (Const_base (Const_int n)):: Kaddint::cont) + | Lprim (Pmakefloatblock _mut, args, loc) -> + let cont = add_pseudo_event loc !compunit_name cont in + comp_args env args sz (Kmakefloatblock (List.length args) :: cont) | Lprim(Pmakearray (kind, _), args, loc) -> let cont = add_pseudo_event loc !compunit_name cont in begin match kind with diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 189604371a0..da36358cb96 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -232,7 +232,7 @@ let rec transl_const = function (fun c -> Obj.set_field block !pos (transl_const c); incr pos) fields; block - | Const_float_array fields -> + | Const_float_block fields | Const_float_array fields -> let res = Array.Floatarray.create (List.length fields) in List.iteri (fun i f -> Array.Floatarray.set res i (float_of_string f)) fields; diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 476bbc352f9..ce63aca36ea 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -51,6 +51,7 @@ type primitive = | Psetglobal of Ident.t (* Operations on heap blocks *) | Pmakeblock of int * mutable_flag * block_shape + | Pmakefloatblock of mutable_flag | Pfield of int | Pfield_computed | Psetfield of int * immediate_or_pointer * initialization_or_assignment @@ -212,6 +213,7 @@ type structured_constant = | Const_block of int * structured_constant list | Const_float_array of string list | Const_immstring of string + | Const_float_block of string list type tailcall_attribute = | Tailcall_expectation of bool diff --git a/lambda/lambda.mli b/lambda/lambda.mli index 3130882baf3..c0cfcebdfa1 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -57,6 +57,7 @@ type primitive = | Psetglobal of Ident.t (* Operations on heap blocks *) | Pmakeblock of int * mutable_flag * block_shape + | Pmakefloatblock of mutable_flag | Pfield of int | Pfield_computed | Psetfield of int * immediate_or_pointer * initialization_or_assignment @@ -203,6 +204,7 @@ type structured_constant = | Const_block of int * structured_constant list | Const_float_array of string list | Const_immstring of string + | Const_float_block of string list type tailcall_attribute = | Tailcall_expectation of bool diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index a57ed7a7437..b5668c96431 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -35,6 +35,12 @@ let rec struct_const ppf = function let sconsts ppf scl = List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl + | Const_float_block [] -> + fprintf ppf "[|b |]" + | Const_float_block (f1 :: fl) -> + let floats ppf fl = + List.iter (fun f -> fprintf ppf "@ %s" f) fl in + fprintf ppf "@[<1>[|b@[%s%a@]|]@]" f1 floats fl | Const_float_array [] -> fprintf ppf "[| |]" | Const_float_array (f1 :: fl) -> @@ -159,6 +165,8 @@ let primitive ppf = function fprintf ppf "makeblock %i%a" tag block_shape shape | Pmakeblock(tag, Mutable, shape) -> fprintf ppf "makemutable %i%a" tag block_shape shape + | Pmakefloatblock Immutable -> fprintf ppf "makefloatblock Immutable" + | Pmakefloatblock Mutable -> fprintf ppf "makefloatblock Mutable" | Pfield n -> fprintf ppf "field %i" n | Pfield_computed -> fprintf ppf "field_computed" | Psetfield(n, ptr, init) -> @@ -355,6 +363,7 @@ let name_of_primitive = function | Pgetglobal _ -> "Pgetglobal" | Psetglobal _ -> "Psetglobal" | Pmakeblock _ -> "Pmakeblock" + | Pmakefloatblock _ -> "Pmakefloatblock" | Pfield _ -> "Pfield" | Pfield_computed -> "Pfield_computed" | Psetfield _ -> "Psetfield" diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 4c49e8e1b21..d19345fffa9 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -1032,7 +1032,7 @@ and transl_record ~scopes loc env fields repres opt_init_expr = | Record_inlined tag -> Lconst(Const_block(tag, cl)) | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false) | Record_float -> - Lconst(Const_float_array(List.map extract_float cl)) + Lconst(Const_float_block(List.map extract_float cl)) | Record_extension _ -> raise Not_constant with Not_constant -> @@ -1044,7 +1044,7 @@ and transl_record ~scopes loc env fields repres opt_init_expr = Lprim(Pmakeblock(tag, mut, Some shape), ll, loc) | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false) | Record_float -> - Lprim(Pmakearray (Pfloatarray, mut), ll, loc) + Lprim(Pmakefloatblock mut, ll, loc) | Record_extension path -> let slot = transl_extension_path loc env path in Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc) diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 6cfff539ebc..f7741018ced 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -760,7 +760,8 @@ let lambda_primitive_needs_event_after = function | Pbbswap _ -> true | Pidentity | Pbytes_to_string | Pbytes_of_string | Pignore | Psetglobal _ - | Pgetglobal _ | Pmakeblock _ | Pfield _ | Pfield_computed | Psetfield _ + | Pgetglobal _ | Pmakeblock _ | Pmakefloatblock _ + | Pfield _ | Pfield_computed | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Praise _ | Psequor | Psequand | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 52b459d1114..d156aa7c29a 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -895,6 +895,9 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = | Const_base(Const_char c) -> Uconst_int (Char.code c) | Const_block (tag, fields) -> str (Uconst_block (tag, List.map transl fields)) + | Const_float_block sl -> + (* CR mshinwell: Add [Uconst_float_block]? *) + str (Uconst_float_array (List.map float_of_string sl)) | Const_float_array sl -> (* constant float arrays are really immutable *) str (Uconst_float_array (List.map float_of_string sl)) diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml index dbb9477ba9f..135eb1f27a9 100644 --- a/middle_end/convert_primitives.ml +++ b/middle_end/convert_primitives.ml @@ -26,6 +26,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = match prim with | Pmakeblock (tag, mutability, shape) -> Pmakeblock (tag, mutability, shape) + | Pmakefloatblock mutability -> + Pmakearray (Pfloatarray, mutability) | Pfield field -> Pfield field | Pfield_computed -> Pfield_computed | Psetfield (field, imm_or_pointer, init_or_assign) -> diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index 1037b2c1d4a..8f94247e21a 100644 --- a/middle_end/flambda/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml @@ -141,7 +141,7 @@ let rec declare_const t (const : Lambda.structured_constant) | Const_immstring c -> register_const t (Allocated_const (Immutable_string c)) Names.const_immstring - | Const_float_array c -> + | Const_float_array c | Const_float_block c -> register_const t (Allocated_const (Immutable_float_array (List.map float_of_string c))) Names.const_float_array diff --git a/middle_end/flambda/simplify_primitives.ml b/middle_end/flambda/simplify_primitives.ml index c7344db23c4..1452e6543c8 100644 --- a/middle_end/flambda/simplify_primitives.ml +++ b/middle_end/flambda/simplify_primitives.ml @@ -123,6 +123,7 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs) | Pmakearray(_, _) when is_empty approxs -> Prim (Pmakeblock(0, Asttypes.Immutable, Some []), [], dbg), A.value_block (Tag.create_exn 0) [||], C.Benefit.zero + (* CR mshinwell: Work out what to do here with [Pmakefloatblock] *) | Pmakearray (Pfloatarray, Mutable) -> let approx = A.value_mutable_float_array ~size:(List.length args) diff --git a/middle_end/internal_variable_names.ml b/middle_end/internal_variable_names.ml index a9daade1bb4..674d6625219 100644 --- a/middle_end/internal_variable_names.ml +++ b/middle_end/internal_variable_names.ml @@ -136,6 +136,7 @@ let plsrbint = "Plsrbint" let plsrint = "Plsrint" let pmakearray = "Pmakearray" let pmakeblock = "Pmakeblock" +let pmakefloatblock = "Pmakefloatblock" let pmodbint = "Pmodbint" let pmodint = "Pmodint" let pmulbint = "Pmulbint" @@ -239,6 +240,7 @@ let plsrbint_arg = "Plsrbint_arg" let plsrint_arg = "Plsrint_arg" let pmakearray_arg = "Pmakearray_arg" let pmakeblock_arg = "Pmakeblock_arg" +let pmakefloatblock_arg = "Pmakefloatblock_arg" let pmodbint_arg = "Pmodbint_arg" let pmodint_arg = "Pmodint_arg" let pmulbint_arg = "Pmulbint_arg" @@ -322,6 +324,7 @@ let of_primitive : Lambda.primitive -> string = function | Pgetglobal _ -> pgetglobal | Psetglobal _ -> psetglobal | Pmakeblock _ -> pmakeblock + | Pmakefloatblock _ -> pmakefloatblock | Pfield _ -> pfield | Pfield_computed -> pfield_computed | Psetfield _ -> psetfield @@ -429,6 +432,7 @@ let of_primitive_arg : Lambda.primitive -> string = function | Pgetglobal _ -> pgetglobal_arg | Psetglobal _ -> psetglobal_arg | Pmakeblock _ -> pmakeblock_arg + | Pmakefloatblock _ -> pmakefloatblock_arg | Pfield _ -> pfield_arg | Pfield_computed -> pfield_computed_arg | Psetfield _ -> psetfield_arg diff --git a/testsuite/tests/translprim/ref_spec.compilers.reference b/testsuite/tests/translprim/ref_spec.compilers.reference index 8e27f04bb96..3a404ae68fd 100644 --- a/testsuite/tests/translprim/ref_spec.compilers.reference +++ b/testsuite/tests/translprim/ref_spec.compilers.reference @@ -17,7 +17,7 @@ cst_rec = (makemutable 0 0 0) gen_rec = (makemutable 0 0 0) flt_rec = (makemutable 0 (*,float) 0 0.) - flt_rec' = (makearray[float] 0. 0.)) + flt_rec' = (makefloatblock Mutable 0. 0.)) (seq (setfield_imm 1 int_rec 2) (setfield_imm 1 var_rec 66) (setfield_ptr 1 vargen_rec [0: 66 0]) (setfield_ptr 1 vargen_rec 67) (setfield_imm 1 cst_rec 1) diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index bb683afba52..01aff4396b9 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -103,6 +103,10 @@ let rec print_struct_const = function List.iter (fun a -> printf ", "; print_struct_const a) al; printf ")" end + | Const_float_block a -> + printf "[|b "; + List.iter (fun f -> print_float f; printf "; ") a; + printf "|]" | Const_float_array a -> printf "[|"; List.iter (fun f -> print_float f; printf "; ") a;