From 29228319515bf71f869f5c4c2650c84a589225dd Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Mon, 17 Nov 2014 12:21:49 +0000 Subject: [PATCH] New primitive: caml_alloc_dummy_function ... caml_alloc_dummy_function takes the function arity as a second argument. This new information can be used by js_of_ocaml to perform better optimization. From: Hugo Heuzard git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@15592 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- bytecomp/bytegen.ml | 13 ++++++++++--- byterun/alloc.c | 6 ++++++ 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 64c290804..dab866750 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -128,6 +128,7 @@ type rhs_kind = | RHS_block of int | RHS_floatblock of int | RHS_nonrec + | RHS_function of int * int ;; let rec check_recordwith_updates id e = @@ -140,7 +141,7 @@ let rec check_recordwith_updates id e = let rec size_of_lambda = function | Lfunction(kind, params, body) as funct -> - RHS_block (1 + IdentSet.cardinal(free_variables funct)) + RHS_function (1 + IdentSet.cardinal(free_variables funct), List.length params) | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body) when check_recordwith_updates id body -> begin match kind with @@ -540,19 +541,25 @@ let rec comp_expr env exp sz cont = Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy", 1) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem + | (id, exp, RHS_function (blocksize,arity)) :: rem -> + Kconst(Const_base(Const_int arity)) :: + Kpush :: + Kconst(Const_base(Const_int blocksize)) :: + Kccall("caml_alloc_dummy_function", 2) :: Kpush :: + comp_init (add_var id (sz+1) new_env) (sz+1) rem | (id, exp, RHS_nonrec) :: rem -> Kconst(Const_base(Const_int 0)) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem and comp_nonrec new_env sz i = function | [] -> comp_rec new_env sz ndecl decl_size - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) :: rem -> comp_nonrec new_env sz (i-1) rem | (id, exp, RHS_nonrec) :: rem -> comp_expr new_env exp sz (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem) and comp_rec new_env sz i = function | [] -> comp_expr new_env body sz (add_pop ndecl cont) - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) :: rem -> comp_expr new_env exp sz (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) :: comp_rec new_env sz (i-1) rem) diff --git a/byterun/alloc.c b/byterun/alloc.c index 1fc33b55a..00ca43ccc 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -153,6 +153,12 @@ CAMLprim value caml_alloc_dummy(value size) return caml_alloc (wosize, 0); } +CAMLprim value caml_alloc_dummy_function(value size,value arity) +{ + /* the arity argument is used by the js_of_ocaml runtime */ + return caml_alloc_dummy(size); +} + CAMLprim value caml_alloc_dummy_float (value size) { mlsize_t wosize = Int_val(size) * Double_wosize;