fix(compiler): Reduce stack usage when allocating lists (#2214)

compiler/src/middle_end/linearize.re

@@ -266,6 +266,42 @@ let reorder_arguments = (args, order) => {
   List.rev(reorder([], args, order));
 };
 
+type constuctor_meta = {
+  imm_type_hash: imm_expression,
+  imm_tytag: imm_expression,
+  imm_tag: imm_expression,
+};
+
+let constructor_meta = (~loc, ~env, typ, cstr_tag) => {
+  let (_, typath, tydecl) = Ctype.extract_concrete_typedecl(env, typ);
+  let ty_id = get_type_id(typath, env);
+  let compiled_tag = compile_constructor_tag(cstr_tag);
+  let type_hash =
+    switch (cstr_tag) {
+    | CstrExtension(_) => exception_type_hash
+    | _ => get_type_hash(tydecl)
+    };
+  let imm_type_hash =
+    Imm.const(
+      ~loc,
+      ~env,
+      Const_number(Const_number_int(Int64.of_int(type_hash))),
+    );
+  let imm_tytag =
+    Imm.const(
+      ~loc,
+      ~env,
+      Const_number(Const_number_int(Int64.of_int(ty_id))),
+    );
+  let imm_tag =
+    Imm.const(
+      ~loc,
+      ~env,
+      Const_number(Const_number_int(Int64.of_int(compiled_tag))),
+    );
+  {imm_type_hash, imm_tytag, imm_tag};
+};
+
 let transl_const =
     (~loc=Location.dummy_loc, ~env=Env.empty, c: Types.constant)
     : Either.t(imm_expression, (ident, list(anf_bind))) => {
@@ -851,8 +887,58 @@ let rec transl_imm =
       List.concat(new_setup)
       @ [BLet(tmp, Comp.tuple(~loc, ~env, new_args), Nonglobal)],
     );
+  | TExpList({items: args, spread}) =>
+    let (args, arg_setup) = List.split(List.map(transl_imm, args));
+    let (spread_arg, spread_setup) =
+      switch (spread) {
+      | Some(imm) => transl_imm(imm)
+      | None =>
+        let empty =
+          Env.find_constructor(PIdent(Builtin_types.ident_empty_cstr), env);
+        let {imm_type_hash, imm_tytag, imm_tag} =
+          constructor_meta(~loc, ~env, typ, empty.cstr_tag);
+        let cstr = gensym("empty");
+        (
+          Imm.id(~loc, ~env, cstr),
+          [
+            BLet(
+              cstr,
+              Comp.adt(~loc, ~env, imm_type_hash, imm_tytag, imm_tag, []),
+              Nonglobal,
+            ),
+          ],
+        );
+      };
+    let cons =
+      Env.find_constructor(PIdent(Builtin_types.ident_cons_cstr), env);
+    let {imm_type_hash, imm_tytag, imm_tag} =
+      constructor_meta(~loc, ~env, typ, cons.cstr_tag);
+    let (list_imm, list_setup) =
+      List.fold_left_map(
+        (rest_imm, arg) => {
+          let cstr = gensym("cons");
+          (
+            Imm.id(~loc, ~env, cstr),
+            BLet(
+              cstr,
+              Comp.adt(
+                ~loc,
+                ~env,
+                imm_type_hash,
+                imm_tytag,
+                imm_tag,
+                [arg, rest_imm],
+              ),
+              Nonglobal,
+            ),
+          );
+        },
+        spread_arg,
+        List.rev(args),
+      );
+    (list_imm, List.concat(arg_setup) @ spread_setup @ list_setup);
   | TExpArray(args) =>
-    let tmp = gensym("tup");
+    let tmp = gensym("array");
     let (new_args, new_setup) = List.split(List.map(transl_imm, args));
     (
       Imm.id(~loc, ~env, tmp),
@@ -1065,9 +1151,6 @@ let rec transl_imm =
     );
   | TExpConstruct(_, {cstr_name, cstr_tag}, arg) =>
     let tmp = gensym("adt");
-    let (_, typath, tydecl) = Ctype.extract_concrete_typedecl(env, typ);
-    let ty_id = get_type_id(typath, env);
-    let compiled_tag = compile_constructor_tag(cstr_tag);
     let (new_args, new_setup) =
       switch (arg) {
       | TExpConstrRecord(fields) =>
@@ -1084,29 +1167,8 @@ let rec transl_imm =
         )
       | TExpConstrTuple(args) => List.split(List.map(transl_imm, args))
       };
-    let type_hash =
-      switch (cstr_tag) {
-      | CstrExtension(_) => exception_type_hash
-      | _ => get_type_hash(tydecl)
-      };
-    let imm_type_hash =
-      Imm.const(
-        ~loc,
-        ~env,
-        Const_number(Const_number_int(Int64.of_int(type_hash))),
-      );
-    let imm_tytag =
-      Imm.const(
-        ~loc,
-        ~env,
-        Const_number(Const_number_int(Int64.of_int(ty_id))),
-      );
-    let imm_tag =
-      Imm.const(
-        ~loc,
-        ~env,
-        Const_number(Const_number_int(Int64.of_int(compiled_tag))),
-      );
+    let {imm_type_hash, imm_tytag, imm_tag} =
+      constructor_meta(~loc, ~env, typ, cstr_tag);
     let adt =
       Comp.adt(~loc, ~env, imm_type_hash, imm_tytag, imm_tag, new_args);
     (

compiler/src/typed/typecore.re

@@ -802,7 +802,6 @@ and type_expect_ =
     (~in_function=?, ~recarg=Rejected, env, sexp, ty_expected_explained) => {
   let {ty: ty_expected, explanation} = ty_expected_explained;
   let loc = sexp.pexp_loc;
-  let core_loc = sexp.pexp_core_loc;
   let attributes = Typetexp.type_attributes(sexp.pexp_attributes);
   /* Record the expression type before unifying it with the expected type */
   let type_expect = type_expect(~in_function?);
@@ -863,57 +862,51 @@ and type_expect_ =
       exp_env: env,
     });
   | PExpList(es) =>
-    let convert_list = (~loc, ~core_loc, ~attributes=?, a) => {
-      open Ast_helper;
-      let empty =
-        Expression.tuple_construct(~loc, ~core_loc, ident_empty, []);
-      let list =
-        switch (List.rev(a)) {
-        | [] => empty
-        | [base, ...rest] =>
-          let base =
-            switch (base) {
-            | ListItem(expr) =>
-              Expression.tuple_construct(
-                ~loc,
-                ~core_loc,
-                ~attributes?,
-                ident_cons,
-                [expr, empty],
-              )
-            | ListSpread(expr, _) => expr
-            };
+    let (args, spread) =
+      switch (List.rev(es)) {
+      | [] => ([], None)
+      | [base, ...rest] =>
+        let (items, spread) =
+          switch (base) {
+          | ListItem(expr) => ([expr], None)
+          | ListSpread(expr, _) => ([], Some(expr))
+          };
+        let items =
           List.fold_left(
-            (acc, expr) => {
-              switch (expr) {
-              | ListItem(expr) =>
-                Expression.tuple_construct(
-                  ~loc,
-                  ~core_loc,
-                  ~attributes?,
-                  ident_cons,
-                  [expr, acc],
-                )
+            (items, arg) =>
+              switch (arg) {
+              | ListItem(expr) => [expr, ...items]
               | ListSpread(_, loc) =>
                 raise(
-                  SyntaxError(
+                  Ast_helper.SyntaxError(
                     loc,
                     "A list spread can only appear at the end of a list.",
                   ),
                 )
-              }
-            },
-            base,
+              },
+            items,
             rest,
           );
-        };
-      {...list, pexp_loc: loc};
-    };
-    type_expect(
-      env,
-      convert_list(~loc, ~core_loc, ~attributes=sexp.pexp_attributes, es),
-      ty_expected_explained,
-    );
+        (items, spread);
+      };
+    let ty = newgenvar();
+    let to_unify = Builtin_types.type_list(ty);
+    with_explanation(() => unify_exp_types(loc, env, to_unify, ty_expected));
+    let items =
+      List.map(sarg => type_expect(env, sarg, mk_expected(ty)), args);
+    let spread =
+      Option.map(
+        expr => type_expect(env, expr, mk_expected(to_unify)),
+        spread,
+      );
+    re({
+      exp_desc: TExpList({items, spread}),
+      exp_loc: loc,
+      exp_extra: [],
+      exp_attributes: attributes,
+      exp_type: instance(env, ty_expected),
+      exp_env: env,
+    });
   | PExpArray(es) =>
     let ty = newgenvar();
     let to_unify = Builtin_types.type_array(ty);

compiler/src/typed/typedtree.re

@@ -465,6 +465,10 @@ and expression_desc =
   | TExpIdent(Path.t, loc(Identifier.t), Types.value_description)
   | TExpConstant(constant)
   | TExpTuple(list(expression))
+  | TExpList({
+      items: list(expression),
+      spread: option(expression),
+    })
   | TExpArray(list(expression))
   | TExpArrayGet(expression, expression)
   | TExpArraySet({

compiler/src/typed/typedtree.rei

@@ -432,6 +432,10 @@ and expression_desc =
   | TExpIdent(Path.t, loc(Identifier.t), Types.value_description)
   | TExpConstant(constant)
   | TExpTuple(list(expression))
+  | TExpList({
+      items: list(expression),
+      spread: option(expression),
+    })
   | TExpArray(list(expression))
   | TExpArrayGet(expression, expression)
   | TExpArraySet({

compiler/src/typed/typedtreeIter.re

@@ -233,6 +233,9 @@ module MakeIterator =
     | TExpRecordSet(e1, _, _, e2) =>
       iter_expression(e1);
       iter_expression(e2);
+    | TExpList({items: args, spread}) =>
+      List.iter(iter_expression, args);
+      Option.iter(iter_expression, spread);
     | TExpTuple(args)
     | TExpArray(args)
     | TExpBlock(args)

compiler/src/typed/typedtreeMap.re

@@ -232,6 +232,11 @@ module MakeMap =
       | TExpMatch(value, branches, p) =>
         TExpMatch(map_expression(value), map_match_branches(branches), p)
       | TExpTuple(args) => TExpTuple(List.map(map_expression, args))
+      | TExpList({items, spread}) =>
+        TExpList({
+          items: List.map(map_expression, items),
+          spread: Option.map(map_expression, spread),
+        })
       | TExpArray(args) => TExpArray(List.map(map_expression, args))
       | TExpArrayGet(a1, a2) =>
         TExpArrayGet(map_expression(a1), map_expression(a2))