@@ -1834,6 +1834,59 @@ let compile output_prefix =
18341834 in
18351835 Js_output. output_of_block_and_expression lambda_cxt.continuation args_code
18361836 exp
1837+ and collect_dup_overrides (copy_id : Ident.t ) (lam : Lam.t )
1838+ (acc : (Lam_compat.set_field_dbg_info * Lam.t) list ) :
1839+ (Lam_compat. set_field_dbg_info * Lam. t ) list option =
1840+ match lam with
1841+ | Lsequence
1842+ ( Lprim
1843+ {primitive = Psetfield (_, fld_info); args = [Lvar id'; value]; _},
1844+ rest )
1845+ when Ident. same id' copy_id ->
1846+ collect_dup_overrides copy_id rest ((fld_info, value) :: acc)
1847+ | Lvar id' when Ident. same id' copy_id -> Some acc
1848+ | _ -> None
1849+ and try_compile_record_spread (lambda_cxt : Lam_compile_context.t )
1850+ (id : Ident.t ) (arg : Lam.t ) (body : Lam.t ) : Js_output.t option =
1851+ match arg with
1852+ | Lprim {primitive = Pduprecord ; args = [init]; _} -> (
1853+ match collect_dup_overrides id body [] with
1854+ | None -> None
1855+ | Some overrides ->
1856+ let need_value_cxt =
1857+ {lambda_cxt with continuation = NeedValue Not_tail }
1858+ in
1859+ let init_output = compile_lambda need_value_cxt init in
1860+ let init_val =
1861+ match init_output.value with
1862+ | Some v -> v
1863+ | None -> assert false
1864+ in
1865+ let blocks, props =
1866+ List. fold_left
1867+ (fun (blocks , props )
1868+ ((fld_info : Lam_compat.set_field_dbg_info ), value_lam ) ->
1869+ let val_output = compile_lambda need_value_cxt value_lam in
1870+ let val_val =
1871+ match val_output.value with
1872+ | Some v -> v
1873+ | None -> assert false
1874+ in
1875+ let name =
1876+ match fld_info with
1877+ | Fld_record_set name
1878+ | Fld_record_inline_set name
1879+ | Fld_record_extension_set name ->
1880+ name
1881+ in
1882+ (blocks @ val_output.block, (Js_op. Lit name, val_val) :: props))
1883+ (init_output.block, [] ) (List. rev overrides)
1884+ in
1885+ Some
1886+ (Js_output. output_of_block_and_expression lambda_cxt.continuation
1887+ blocks
1888+ (E. obj ~dup: init_val props)))
1889+ | _ -> None
18371890 and compile_lambda (lambda_cxt : Lam_compile_context.t ) (cur_lam : Lam.t ) :
18381891 Js_output. t =
18391892 match cur_lam with
@@ -1859,14 +1912,17 @@ let compile output_prefix =
18591912 }
18601913 body)))
18611914 | Lapply appinfo -> compile_apply appinfo lambda_cxt
1862- | Llet (let_kind , id , arg , body ) ->
1863- (* Order matters.. see comment below in [Lletrec] *)
1864- let args_code =
1865- compile_lambda
1866- {lambda_cxt with continuation = Declare (let_kind, id)}
1867- arg
1868- in
1869- Js_output. append_output args_code (compile_lambda lambda_cxt body)
1915+ | Llet (let_kind , id , arg , body ) -> (
1916+ match try_compile_record_spread lambda_cxt id arg body with
1917+ | Some output -> output
1918+ | None ->
1919+ (* Order matters.. see comment below in [Lletrec] *)
1920+ let args_code =
1921+ compile_lambda
1922+ {lambda_cxt with continuation = Declare (let_kind, id)}
1923+ arg
1924+ in
1925+ Js_output. append_output args_code (compile_lambda lambda_cxt body))
18701926 | Lletrec (id_args , body ) ->
18711927 (* There is a bug in our current design,
18721928 it requires compile args first (register that some objects are jsidentifiers)
0 commit comments