diff options
| -rw-r--r-- | bytecomp/lambda.mli | 2 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 25 |
2 files changed, 25 insertions, 2 deletions
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 8710902e6..d3c8bfc8f 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -93,7 +93,7 @@ val name_lambda: lambda -> (Ident.t -> lambda) -> lambda val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda val is_guarded: lambda -> bool -module IdentSet: Set.S with elt = Ident.t +module IdentSet: Set.S with type elt = Ident.t val free_variables: lambda -> IdentSet.t type compilenv diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index e1415947d..e58fcc2c8 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -235,6 +235,10 @@ let array_kind arg = | _ -> Pgenarray (* This can happen with abbreviations that we can't expand here because the typing environment is lost *) +let prim_makearray = + { prim_name = "make_vect"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false } + let transl_prim prim args = try let (gencomp, intcomp, floatcomp, stringcomp) = @@ -400,7 +404,26 @@ let rec transl_exp env e = | Record_float -> Psetfloatfield lbl.lbl_pos in Lprim(access, [transl_exp env arg; transl_exp env newval]) | Texp_array expr_list -> - Lprim(Pmakearray(array_kind e), transl_list env expr_list) + let kind = array_kind e in + let len = List.length expr_list in + if len <= Config.max_young_wosize then + Lprim(Pmakearray kind, transl_list env expr_list) + else begin + let v = Ident.new "makearray" in + let rec fill_fields pos = function + [] -> + Lvar v + | arg :: rem -> + Lsequence(Lprim(Parraysetu kind, + [Lvar v; + Lconst(Const_base(Const_int pos)); + transl_exp env arg]), + fill_fields (pos+1) rem) in + Llet(v, Lprim(Pccall prim_makearray, + [Lconst(Const_base(Const_int len)); + transl_exp env (List.hd expr_list)]), + fill_fields 1 (List.tl expr_list)) + end | Texp_ifthenelse(cond, ifso, Some ifnot) -> Lifthenelse(transl_exp env cond, transl_exp env ifso, transl_exp env ifnot) |