+2

.depend

reviewed

··· 4438 4438 typing/ident.cmi \ 4439 4439 typing/env.cmi \ 4440 4440 lambda/debuginfo.cmi \ 4441 4441 + utils/config.cmi \ 4441 4442 utils/clflags.cmi \ 4442 4443 parsing/asttypes.cmi \ 4443 4444 lambda/lambda.cmi ··· 4451 4452 typing/ident.cmx \ 4452 4453 typing/env.cmx \ 4453 4454 lambda/debuginfo.cmx \ 4455 4455 + utils/config.cmx \ 4454 4456 utils/clflags.cmx \ 4455 4457 parsing/asttypes.cmx \ 4456 4458 lambda/lambda.cmi

+4

Changes

reviewed

··· 484 484 type annotations. 485 485 (Chris Casinghino, review by Florian Angeletti and Gabriel Scherer) 486 486 487 487 + - #13867: Fix bug with some recursive bindings of lazy values. 488 488 + (Guillaume Bury and Vincent Laviron, review by Stefan Muenzel 489 489 + and Gabriel Scherer) 490 490 + 487 491 - #13875, #13878: Add dedicated constructor for mutable variable access in 488 492 Cmm to prevent bugs linked to incorrect handling of coeffects. 489 493 (Vincent Laviron, review by Gabriel Scherer)

+6 -1

asmcomp/cmmgen.ml

reviewed

··· 590 590 | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ 591 591 | Pasrbint _ | Pbintcomp (_, _) | Pstring_load _ | Pbytes_load _ 592 592 | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _ 593 593 - | Pbbswap _ | Ppoll ), _) 593 593 + | Pbbswap _ | Ppoll | Pmakelazyblock _ ), _) 594 594 -> 595 595 fatal_error "Cmmgen.transl:prim" 596 596 end ··· 829 829 Popaque -> 830 830 opaque (transl env arg) dbg 831 831 (* Heap operations *) 832 832 + | Pmakelazyblock tag -> 833 833 + make_alloc dbg (Lambda.tag_of_lazy_tag tag) [transl env arg] 832 834 | Pfield(n, imm_or_pointer, mut) -> 833 835 get_field env imm_or_pointer mut (transl env arg) n dbg 834 836 | Pfloatfield n -> ··· 1096 1098 | Parraysets _ | Pbintofint _ | Pintofbint _ | Pcvtbint (_, _) 1097 1099 | Pnegbint _ | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) 1098 1100 | Pbigarraydim _ | Pbytes_set _ | Pbigstring_set _ | Pbbswap _ | Ppoll 1101 1101 + | Pmakelazyblock _ 1099 1102 -> 1100 1103 fatal_errorf "Cmmgen.transl_prim_2: %a" 1101 1104 Printclambda_primitives.primitive p ··· 1170 1173 | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _) 1171 1174 | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _ 1172 1175 | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _ | Ppoll 1176 1176 + | Pmakelazyblock _ 1173 1177 -> 1174 1178 fatal_errorf "Cmmgen.transl_prim_3: %a" 1175 1179 Printclambda_primitives.primitive p ··· 1203 1207 | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _) 1204 1208 | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _ 1205 1209 | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _ | Ppoll 1210 1210 + | Pmakelazyblock _ 1206 1211 -> 1207 1212 fatal_errorf "Cmmgen.transl_prim_3: %a" 1208 1213 Printclambda_primitives.primitive p

+6 -1

bytecomp/bytegen.ml

reviewed

··· 145 145 | Prunstack | Pperform | Presume | Preperform | Ppoll -> 146 146 true 147 147 | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _ 148 148 - | Pmakeblock _ | Pfield _ | Pfield_computed | Psetfield _ 148 148 + | Pmakeblock _ | Pmakelazyblock _ | Pfield _ | Pfield_computed | Psetfield _ 149 149 | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ 150 150 | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint 151 151 | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint ··· 501 501 | Pmakearray _ | Pduparray _ 502 502 | Pfloatcomp _ 503 503 | Pmakeblock _ 504 504 + | Pmakelazyblock _ 504 505 | Pfloatfield _ 505 506 -> 506 507 fatal_error "Bytegen.comp_primitive" ··· 769 770 let cont = add_pseudo_event loc !compunit_name cont in 770 771 comp_args stack_info env args sz 771 772 (Kmakeblock(List.length args, tag) :: cont) 773 773 + | Lprim(Pmakelazyblock tag, [arg], loc) -> 774 774 + let cont = add_pseudo_event loc !compunit_name cont in 775 775 + comp_args stack_info env [arg] sz 776 776 + (Kmakeblock(1, Lambda.tag_of_lazy_tag tag) :: cont) 772 777 | Lprim(Pfloatfield n, args, loc) -> 773 778 let cont = add_pseudo_event loc !compunit_name cont in 774 779 comp_args stack_info env args sz (Kgetfloatfield n :: cont)

+9

lambda/lambda.ml

reviewed

··· 39 39 | Safe 40 40 | Unsafe 41 41 42 42 + type lazy_block_tag = 43 43 + | Lazy_tag 44 44 + | Forward_tag 45 45 + 46 46 + let tag_of_lazy_tag = function 47 47 + | Lazy_tag -> Config.lazy_tag 48 48 + | Forward_tag -> Obj.forward_tag 49 49 + 42 50 type primitive = 43 51 | Pbytes_to_string 44 52 | Pbytes_of_string ··· 48 56 | Psetglobal of Ident.t 49 57 (* Operations on heap blocks *) 50 58 | Pmakeblock of int * mutable_flag * block_shape 59 59 + | Pmakelazyblock of lazy_block_tag 51 60 | Pfield of int * immediate_or_pointer * mutable_flag 52 61 | Pfield_computed 53 62 | Psetfield of int * immediate_or_pointer * initialization_or_assignment

+7

lambda/lambda.mli

reviewed

··· 47 47 | Safe 48 48 | Unsafe 49 49 50 50 + type lazy_block_tag = 51 51 + | Lazy_tag 52 52 + | Forward_tag 53 53 + 50 54 type primitive = 51 55 | Pbytes_to_string 52 56 | Pbytes_of_string ··· 56 60 | Psetglobal of Ident.t 57 61 (* Operations on heap blocks *) 58 62 | Pmakeblock of int * mutable_flag * block_shape 63 63 + | Pmakelazyblock of lazy_block_tag 59 64 | Pfield of int * immediate_or_pointer * mutable_flag 60 65 | Pfield_computed 61 66 | Psetfield of int * immediate_or_pointer * initialization_or_assignment ··· 496 501 maximal length of the [params] list of a [lfunction] record. 497 502 This is unlimited ([max_int]) for bytecode, but limited 498 503 (currently to 126) for native code. *) 504 504 + 505 505 + val tag_of_lazy_tag : lazy_block_tag -> int 499 506 500 507 (***********************) 501 508 (* For static failures *)

+5

lambda/printlambda.ml

reviewed

··· 156 156 fprintf ppf "makeblock %i%a" tag block_shape shape 157 157 | Pmakeblock(tag, Mutable, shape) -> 158 158 fprintf ppf "makemutable %i%a" tag block_shape shape 159 159 + | Pmakelazyblock Lazy_tag -> 160 160 + fprintf ppf "makelazyblock" 161 161 + | Pmakelazyblock Forward_tag -> 162 162 + fprintf ppf "makeforwardblock" 159 163 | Pfield(n, ptr, mut) -> 160 164 let instr = 161 165 match ptr, mut with ··· 362 366 | Pgetglobal _ -> "Pgetglobal" 363 367 | Psetglobal _ -> "Psetglobal" 364 368 | Pmakeblock _ -> "Pmakeblock" 369 369 + | Pmakelazyblock _ -> "Pmakelazyblock" 365 370 | Pfield _ -> "Pfield" 366 371 | Pfield_computed -> "Pfield_computed" 367 372 | Psetfield _ -> "Psetfield"

+7

lambda/tmc.ml

reviewed

··· 882 882 | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ 883 883 | Pbintcomp _ 884 884 885 885 + (* Lazy blocks should never contain a recursive call directly: 886 886 + either it's a closure (Lazy_tag), or a variable (Forward_tag). 887 887 + The case 'let foo = recursive_call in lazy foo' could be translated to 888 888 + use tmc in the cases where 'foo' might be of type lazy or float, but 889 889 + given the fragility of such a transformation we choose not to. *) 890 890 + | Pmakelazyblock _ 891 891 + 885 892 (* more common cases... *) 886 893 | Pbigarrayref _ | Pbigarrayset _ 887 894 | Pbigarraydim _

+4 -17

lambda/translcore.ml

reviewed

··· 525 525 (* A constant expr (of type <> float if [Config.flat_float_array] is 526 526 true) gets compiled as itself. *) 527 527 transl_exp ~scopes e 528 528 - | `Float_that_cannot_be_shortcut -> 529 529 - (* We don't need to wrap with Popaque: this forward 530 530 - block will never be shortcutted since it points to a float 531 531 - and Config.flat_float_array is true. *) 532 532 - Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), 533 533 - [transl_exp ~scopes e], of_location ~scopes e.exp_loc) 528 528 + | `Float_that_cannot_be_shortcut 534 529 | `Identifier `Forward_value -> 535 535 - (* CR-someday mshinwell: Consider adding a new primitive 536 536 - that expresses the construction of forward_tag blocks. 537 537 - We need to use [Popaque] here to prevent unsound 538 538 - optimisation in Flambda, but the concept of a mutable 539 539 - block doesn't really match what is going on here. This 540 540 - value may subsequently turn into an immediate... *) 541 541 - Lprim (Popaque, 542 542 - [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), 543 543 - [transl_exp ~scopes e], 544 544 - of_location ~scopes e.exp_loc)], 530 530 + Lprim (Pmakelazyblock Forward_tag, 531 531 + [transl_exp ~scopes e], 545 532 of_location ~scopes e.exp_loc) 546 533 | `Identifier `Other -> 547 534 transl_exp ~scopes e ··· 557 544 ~attr:function_attribute_disallowing_arity_fusion 558 545 ~loc:(of_location ~scopes e.exp_loc) 559 546 ~body:(transl_exp ~scopes e) in 560 560 - Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], 547 547 + Lprim(Pmakelazyblock Lazy_tag, [fn], 561 548 of_location ~scopes e.exp_loc) 562 549 end 563 550 | Texp_object (cs, meths) ->

+1

lambda/translprim.ml

reviewed

··· 827 827 | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint | Pisout 828 828 | Patomic_load 829 829 | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque | Pdls_get 830 830 + | Pmakelazyblock _ 830 831 -> false 831 832 832 833 (* Determine if a primitive should be surrounded by an "after" debug event *)

+2

lambda/value_rec_compiler.ml

reviewed

··· 219 219 Note that flat float arrays/records use Pmakearray, so we don't need 220 220 to check the tag here. *) 221 221 Block (Regular_block (List.length args)) 222 222 + | Pmakelazyblock _ -> 223 223 + Block (Regular_block 1) 222 224 | Pmakearray (kind, _) -> 223 225 let size = List.length args in 224 226 begin match kind with

+3

middle_end/clambda_primitives.ml

reviewed

··· 30 30 | Thirty_two 31 31 | Sixty_four 32 32 33 33 + type lazy_block_tag = Lambda.lazy_block_tag 34 34 + 33 35 type primitive = 34 36 | Pread_symbol of string 35 37 (* Operations on heap blocks *) 36 38 | Pmakeblock of int * mutable_flag * block_shape 39 39 + | Pmakelazyblock of lazy_block_tag 37 40 | Pfield of int * immediate_or_pointer * mutable_flag 38 41 | Pfield_computed 39 42 | Psetfield of int * immediate_or_pointer * initialization_or_assignment

+3

middle_end/clambda_primitives.mli

reviewed

··· 30 30 | Thirty_two 31 31 | Sixty_four 32 32 33 33 + type lazy_block_tag = Lambda.lazy_block_tag 34 34 + 33 35 type primitive = 34 36 | Pread_symbol of string 35 37 (* Operations on heap blocks *) 36 38 | Pmakeblock of int * mutable_flag * block_shape 39 39 + | Pmakelazyblock of lazy_block_tag 37 40 | Pfield of int * immediate_or_pointer * mutable_flag 38 41 | Pfield_computed 39 42 | Psetfield of int * immediate_or_pointer * initialization_or_assignment

+1

middle_end/closure/closure.ml

reviewed

··· 108 108 match prim with 109 109 | Pread_symbol _ -> 1 110 110 | Pmakeblock _ -> 5 + List.length args 111 111 + | Pmakelazyblock _ -> 6 111 112 | Pfield _ -> 1 112 113 | Psetfield(_f, isptr, init) -> 113 114 begin match init with

+2

middle_end/convert_primitives.ml

reviewed

··· 26 26 match prim with 27 27 | Pmakeblock (tag, mutability, shape) -> 28 28 Pmakeblock (tag, mutability, shape) 29 29 + | Pmakelazyblock tag -> 30 30 + Pmakelazyblock tag 29 31 | Pfield (field, imm_or_pointer, mutability) -> 30 32 Pfield (field, imm_or_pointer, mutability) 31 33 | Pfield_computed -> Pfield_computed

+3 -1

middle_end/flambda/inlining_cost.ml

reviewed

··· 22 22 let prim_size (prim : Clambda_primitives.primitive) args = 23 23 match prim with 24 24 | Pmakeblock _ -> 5 + List.length args 25 25 + | Pmakelazyblock _ -> 6 25 26 | Pfield _ -> 1 26 27 | Psetfield (_, isptr, init) -> 27 28 begin match init with ··· 269 270 let remove_code_helper_named b (named : Flambda.named) = 270 271 match named with 271 272 | Set_of_closures _ 272 272 - | Prim ((Pmakearray _ | Pmakeblock _ | Pduprecord _), _, _) -> 273 273 + | Prim ((Pmakearray _ | Pmakeblock _ 274 274 + | Pmakelazyblock _ | Pduprecord _), _, _) -> 273 275 b := remove_alloc !b 274 276 (* CR-soon pchambart: should we consider that boxed integer and float 275 277 operations are allocations ? *)

+4

middle_end/internal_variable_names.ml

reviewed

··· 134 134 let plsrint = "Plsrint" 135 135 let pmakearray = "Pmakearray" 136 136 let pmakeblock = "Pmakeblock" 137 137 + let pmakelazyblock = "Pmakelazyblock" 137 138 let pmodbint = "Pmodbint" 138 139 let pmodint = "Pmodint" 139 140 let pmulbint = "Pmulbint" ··· 241 242 let plsrint_arg = "Plsrint_arg" 242 243 let pmakearray_arg = "Pmakearray_arg" 243 244 let pmakeblock_arg = "Pmakeblock_arg" 245 245 + let pmakelazyblock_arg = "Pmakelazyblock_arg" 244 246 let pmodbint_arg = "Pmodbint_arg" 245 247 let pmodint_arg = "Pmodint_arg" 246 248 let pmulbint_arg = "Pmulbint_arg" ··· 326 328 | Pgetglobal _ -> pgetglobal 327 329 | Psetglobal _ -> psetglobal 328 330 | Pmakeblock _ -> pmakeblock 331 331 + | Pmakelazyblock _ -> pmakelazyblock 329 332 | Pfield _ -> pfield 330 333 | Pfield_computed -> pfield_computed 331 334 | Psetfield _ -> psetfield ··· 436 439 | Pgetglobal _ -> pgetglobal_arg 437 440 | Psetglobal _ -> psetglobal_arg 438 441 | Pmakeblock _ -> pmakeblock_arg 442 442 + | Pmakelazyblock _ -> pmakelazyblock_arg 439 443 | Pfield _ -> pfield_arg 440 444 | Pfield_computed -> pfield_computed_arg 441 445 | Psetfield _ -> psetfield_arg

+4

middle_end/printclambda_primitives.ml

reviewed

··· 61 61 fprintf ppf "makeblock %i%a" tag Printlambda.block_shape shape 62 62 | Pmakeblock(tag, Mutable, shape) -> 63 63 fprintf ppf "makemutable %i%a" tag Printlambda.block_shape shape 64 64 + | Pmakelazyblock Lazy_tag -> 65 65 + fprintf ppf "makelazyblock" 66 66 + | Pmakelazyblock Forward_tag -> 67 67 + fprintf ppf "makeforwardblock" 64 68 | Pfield(n, ptr, mut) -> 65 69 let instr = 66 70 match ptr, mut with

+1 -1

middle_end/semantics_of_primitives.ml

reviewed

··· 21 21 22 22 let for_primitive (prim : Clambda_primitives.primitive) = 23 23 match prim with 24 24 - | Pmakeblock _ 24 24 + | Pmakeblock _ | Pmakelazyblock _ 25 25 | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects 26 26 | Pmakearray (_, Immutable) -> No_effects, No_coeffects 27 27 | Pduparray (_, Immutable) ->

+21

testsuite/tests/lazy/lazy10.ml

reviewed

··· 1 1 + (* TEST *) 2 2 + 3 3 + (* This test checks that we're not propagating the approximation of 4 4 + a lazy block down the path where it has been shortcut *) 5 5 + 6 6 + let[@inline never][@local never] run () = 7 7 + let l = lazy (Sys.opaque_identity None) in 8 8 + let check () = 9 9 + match Lazy.force l with 10 10 + | None -> print_endline "Ok" 11 11 + | Some _ -> print_endline "Error" 12 12 + in 13 13 + (* First force the lazy value *) 14 14 + check (); 15 15 + (* Then trigger a minor GC to shortcut the evaluated lazy value *) 16 16 + Gc.minor (); 17 17 + (* Now check that the code above can cope with [l] being an immediate 18 18 + instead of a pointer *) 19 19 + check () 20 20 + 21 21 + let () = run ()

+2

testsuite/tests/lazy/lazy10.reference

reviewed

··· 1 1 + Ok 2 2 + Ok

+36

testsuite/tests/lazy/lazy9.ml

reviewed

··· 1 1 + (* TEST *) 2 2 + 3 3 + (* In some situations, these code snippets would cause the 4 4 + let-rec size computation to raise a fatal error. *) 5 5 + 6 6 + (* *) 7 7 + type t = 8 8 + | C of t Lazy.t Lazy.t 9 9 + 10 10 + let rec x = 11 11 + let y = (lazy (C x)) in 12 12 + lazy y 13 13 + 14 14 + (* *) 15 15 + let todo () : float = 16 16 + let rec l = 17 17 + let x = lazy (Lazy.force (Lazy.force l)) in 18 18 + lazy x 19 19 + in 20 20 + Lazy.force (Lazy.force l) 21 21 + 22 22 + (* *) 23 23 + let () = 24 24 + begin match Lazy.force (Lazy.force x) with 25 25 + | C _ -> () 26 26 + end; 27 27 + begin match todo () with 28 28 + | f -> 29 29 + (* trying to get the actual value of the float will cause a segfault *) 30 30 + let f' = f +. 1. in 31 31 + print_float f'; 32 32 + print_newline () 33 33 + | exception CamlinternalLazy.Undefined -> 34 34 + (* this is what should happen if `todo` is compiled correctly *) 35 35 + () 36 36 + end;

testsuite/tests/lazy/lazy9.reference

reviewed

This is a binary file and will not be displayed.