2626
2727module E = Js_exp_make
2828
29- let splice_fn_apply fn args =
29+ let splice_apply fn args =
3030 E. runtime_call Js_runtime_modules. caml_splice_call " spliceApply"
3131 [ fn; E. array Immutable args ]
3232
33- let splice_obj_fn_apply obj name args =
33+ let splice_new_apply fn args =
34+ E. runtime_call Js_runtime_modules. caml_splice_call " spliceNewApply"
35+ [ fn; E. array Immutable args ]
36+
37+ let splice_obj_apply obj name args =
3438 E. runtime_call Js_runtime_modules. caml_splice_call " spliceObjApply"
3539 [ obj; E. str name; E. array Immutable args ]
3640
@@ -253,7 +257,7 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
253257 if splice then
254258 let args, eff, dynamic = assemble_args_has_splice arg_types args in
255259 add_eff eff
256- (if dynamic then splice_fn_apply fn args
260+ (if dynamic then splice_apply fn args
257261 else E. call ~info: { arity = Full ; call_info = Call_na } fn args)
258262 else
259263 let args, eff = assemble_args_no_splice arg_types args in
@@ -265,13 +269,13 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
265269 let args, eff, dynamic = assemble_args_has_splice arg_types args in
266270 (* TODO: fix in rest calling convention *)
267271 add_eff eff
268- (if dynamic then splice_fn_apply fn args
272+ (if dynamic then splice_apply fn args
269273 else E. call ~info: { arity = Full ; call_info = Call_na } fn args)
270274 else
271275 let args, eff = assemble_args_no_splice arg_types args in
272276 (* TODO: fix in rest calling convention *)
273277 add_eff eff (E. call ~info: { arity = Full ; call_info = Call_na } fn args)
274- | Js_new { external_module_name = module_name ; name = fn ; scopes } ->
278+ | Js_new { external_module_name = module_name ; name = fn ; splice; scopes } ->
275279 (* handle [@@new]*)
276280 (* This has some side effect, it will
277281 mark its identifier (If it has) as an object,
@@ -281,15 +285,25 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
281285 TODO: we should propagate this property
282286 as much as we can(in alias table)
283287 *)
284- let args, eff = assemble_args_no_splice arg_types args in
285- let fn = translate_scoped_module_val module_name fn scopes in
286- add_eff eff
287- ((match cxt.continuation with
288+ let mark () =
289+ match cxt.continuation with
288290 | Declare (_ , id ) | Assign id ->
289291 (* Format.fprintf Format.err_formatter "%a@."Ident.print id; *)
290292 Ext_ident. make_js_object id
291- | EffectCall _ | NeedValue _ -> () );
292- E. new_ fn args)
293+ | EffectCall _ | NeedValue _ -> ()
294+ in
295+ if splice then
296+ let args, eff, dynamic = assemble_args_has_splice arg_types args in
297+ let fn = translate_scoped_module_val module_name fn scopes in
298+ add_eff eff
299+ (mark () ;
300+ if dynamic then splice_new_apply fn args
301+ else E. new_ fn args)
302+ else
303+ let args, eff = assemble_args_no_splice arg_types args in
304+ let fn = translate_scoped_module_val module_name fn scopes in
305+ add_eff eff
306+ (mark () ; E. new_ fn args)
293307 | Js_send { splice; name; js_send_scopes } -> (
294308 match args with
295309 | self :: args ->
@@ -300,7 +314,7 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types
300314 let args, eff, dynamic = assemble_args_has_splice arg_types args in
301315 add_eff eff
302316 (let self = translate_scoped_access js_send_scopes self in
303- if dynamic then splice_obj_fn_apply self name args
317+ if dynamic then splice_obj_apply self name args
304318 else
305319 E. call
306320 ~info: { arity = Full ; call_info = Call_na }
0 commit comments