Compiler: reduce memory consumption

CHANGES.md

@@ -3,6 +3,7 @@
 ## Features/Changes
 * Compiler: change control-flow compilation strategy (#1496)
 * Compiler: Dead code elimination of unused references (#2076)
+* Compiler: reduce memory consumption (#1516)
 * Lib: add download attribute to anchor element
 * Misc: switch CI to OCaml 5.1
 * Misc: preliminary support for OCaml 5.2

compiler/bin-js_of_ocaml/cmd_arg.ml

@@ -365,7 +365,7 @@ let options =
   let t =
     Term.(
       const build_t
-      $ Jsoo_cmdline.Arg.t
+      $ Lazy.force Jsoo_cmdline.Arg.t
       $ set_param
       $ set_env
       $ dynlink
@@ -604,7 +604,7 @@ let options_runtime_only =
   let t =
     Term.(
       const build_t
-      $ Jsoo_cmdline.Arg.t
+      $ Lazy.force Jsoo_cmdline.Arg.t
       $ toplevel
       $ no_cmis
       $ set_param

compiler/bin-js_of_ocaml/link.ml

@@ -126,7 +126,7 @@ let options =
   let t =
     Term.(
       const build_t
-      $ Jsoo_cmdline.Arg.t
+      $ Lazy.force Jsoo_cmdline.Arg.t
       $ no_sourcemap
       $ sourcemap
       $ sourcemap_inline_in_js

compiler/bin-jsoo_minify/cmd_arg.ml

@@ -42,7 +42,9 @@ let options =
   let build_t common files output_file use_stdin =
     `Ok { common; use_stdin; output_file; files }
   in
-  let t = Term.(const build_t $ Jsoo_cmdline.Arg.t $ files $ output_file $ use_stdin) in
+  let t =
+    Term.(const build_t $ Lazy.force Jsoo_cmdline.Arg.t $ files $ output_file $ use_stdin)
+  in
   Term.ret t
 
 let info =

compiler/lib-cmdline/arg.ml

@@ -35,28 +35,31 @@ type t =
   }
 
 let debug =
-  let doc = "enable debug [$(docv)]." in
-  let all = List.map (Debug.available ()) ~f:(fun s -> s, s) in
-  let arg =
-    Arg.(value & opt_all (list (enum all)) [] & info [ "debug" ] ~docv:"SECTION" ~doc)
-  in
-  Term.(const List.flatten $ arg)
+  lazy
+    (let doc = "enable debug [$(docv)]." in
+     let all = List.map (Debug.available ()) ~f:(fun s -> s, s) in
+     let arg =
+       Arg.(value & opt_all (list (enum all)) [] & info [ "debug" ] ~docv:"SECTION" ~doc)
+     in
+     Term.(const List.flatten $ arg))
 
 let enable =
-  let doc = "Enable optimization [$(docv)]." in
-  let all = List.map (Config.Flag.available ()) ~f:(fun s -> s, s) in
-  let arg =
-    Arg.(value & opt_all (list (enum all)) [] & info [ "enable" ] ~docv:"OPT" ~doc)
-  in
-  Term.(const List.flatten $ arg)
+  lazy
+    (let doc = "Enable optimization [$(docv)]." in
+     let all = List.map (Config.Flag.available ()) ~f:(fun s -> s, s) in
+     let arg =
+       Arg.(value & opt_all (list (enum all)) [] & info [ "enable" ] ~docv:"OPT" ~doc)
+     in
+     Term.(const List.flatten $ arg))
 
 let disable =
-  let doc = "Disable optimization [$(docv)]." in
-  let all = List.map (Config.Flag.available ()) ~f:(fun s -> s, s) in
-  let arg =
-    Arg.(value & opt_all (list (enum all)) [] & info [ "disable" ] ~docv:"OPT" ~doc)
-  in
-  Term.(const List.flatten $ arg)
+  lazy
+    (let doc = "Disable optimization [$(docv)]." in
+     let all = List.map (Config.Flag.available ()) ~f:(fun s -> s, s) in
+     let arg =
+       Arg.(value & opt_all (list (enum all)) [] & info [ "disable" ] ~docv:"OPT" ~doc)
+     in
+     Term.(const List.flatten $ arg))
 
 let pretty =
   let doc = "Pretty print the output." in
@@ -86,31 +89,32 @@ let custom_header =
   Arg.(value & opt (some string) None & info [ "custom-header" ] ~doc)
 
 let t =
-  Term.(
-    const (fun debug enable disable pretty debuginfo noinline quiet werror c_header ->
-        let enable = if pretty then "pretty" :: enable else enable in
-        let enable = if debuginfo then "debuginfo" :: enable else enable in
-        let disable = if noinline then "inline" :: disable else disable in
-        let disable_if_pretty name disable =
-          if pretty && not (List.mem name ~set:enable) then name :: disable else disable
-        in
-        let disable = disable_if_pretty "shortvar" disable in
-        let disable = disable_if_pretty "share" disable in
-        { debug = { enable = debug; disable = [] }
-        ; optim = { enable; disable }
-        ; quiet
-        ; werror
-        ; custom_header = c_header
-        })
-    $ debug
-    $ enable
-    $ disable
-    $ pretty
-    $ debuginfo
-    $ noinline
-    $ is_quiet
-    $ is_werror
-    $ custom_header)
+  lazy
+    Term.(
+      const (fun debug enable disable pretty debuginfo noinline quiet werror c_header ->
+          let enable = if pretty then "pretty" :: enable else enable in
+          let enable = if debuginfo then "debuginfo" :: enable else enable in
+          let disable = if noinline then "inline" :: disable else disable in
+          let disable_if_pretty name disable =
+            if pretty && not (List.mem name ~set:enable) then name :: disable else disable
+          in
+          let disable = disable_if_pretty "shortvar" disable in
+          let disable = disable_if_pretty "share" disable in
+          { debug = { enable = debug; disable = [] }
+          ; optim = { enable; disable }
+          ; quiet
+          ; werror
+          ; custom_header = c_header
+          })
+      $ Lazy.force debug
+      $ Lazy.force enable
+      $ Lazy.force disable
+      $ pretty
+      $ debuginfo
+      $ noinline
+      $ is_quiet
+      $ is_werror
+      $ custom_header)
 
 let on_off on off t =
   List.iter ~f:on t.enable;

compiler/lib-cmdline/arg.mli

@@ -30,6 +30,6 @@ type t =
   ; custom_header : string option
   }
 
-val t : t Cmdliner.Term.t
+val t : t Cmdliner.Term.t Lazy.t
 
 val eval : t -> unit

compiler/lib/flow_lexer.ml

@@ -14,17 +14,6 @@ module Lex_mode = struct
     | REGEXP
 end
 
-module Loc = struct
-  (* line numbers are 1-indexed; column numbers are 0-indexed *)
-
-  type t =
-    { source : string option
-    ; start : Lexing.position
-    ; _end : Lexing.position
-    }
-  [@@ocaml.warning "-69"]
-end
-
 module Parse_error = struct
   type t =
     | Unexpected of string
@@ -45,28 +34,20 @@ module Lex_env = struct
   type lex_state = { lex_errors_acc : (Loc.t * Parse_error.t) list } [@@ocaml.unboxed]
 
   type t =
-    { lex_source : string option
-    ; lex_lb : Sedlexing.lexbuf
+    { lex_lb : Sedlexing.lexbuf
     ; lex_state : lex_state
     ; lex_mode_stack : Lex_mode.t list
+    ; lex_last_loc : Loc.t ref
     }
   [@@ocaml.warning "-69"]
 
-  let source env = env.lex_source
-
   let empty_lex_state = { lex_errors_acc = [] }
 
   let create lex_lb =
-    let s, _ = Sedlexing.lexing_positions lex_lb in
-    let lex_source =
-      match s.pos_fname with
-      | "" -> None
-      | s -> Some s
-    in
-    { lex_source
-    ; lex_lb
+    { lex_lb
     ; lex_state = empty_lex_state
     ; lex_mode_stack = [ Lex_mode.NORMAL ]
+    ; lex_last_loc = ref (Loc.create Lexing.dummy_pos Lexing.dummy_pos)
     }
 end
 
@@ -84,7 +65,7 @@ let pop_mode env =
 module Lex_result = struct
   type t =
     { lex_token : Js_token.t
-    ; lex_loc : Lexing.position * Lexing.position
+    ; lex_loc : Loc.t
     ; lex_errors : (Loc.t * Parse_error.t) list
     }
   [@@ocaml.warning "-69"]
@@ -239,9 +220,9 @@ let is_valid_identifier_name s =
   | js_id_start, Star js_id_continue, eof -> true
   | _ -> false
 
-let loc_of_lexbuf env (lexbuf : Sedlexing.lexbuf) =
+let loc_of_lexbuf _env (lexbuf : Sedlexing.lexbuf) =
   let start_offset, stop_offset = Sedlexing.lexing_positions lexbuf in
-  { Loc.source = Lex_env.source env; start = start_offset; _end = stop_offset }
+  Loc.create start_offset stop_offset
 
 let lex_error (env : Lex_env.t) loc err : Lex_env.t =
   let lex_errors_acc = (loc, err) :: env.lex_state.lex_errors_acc in
@@ -821,27 +802,30 @@ let wrap f =
     let start, _ = Sedlexing.lexing_positions env.Lex_env.lex_lb in
     let t = f env env.Lex_env.lex_lb in
     let _, stop = Sedlexing.lexing_positions env.Lex_env.lex_lb in
-    t, (start, stop)
+    t, Loc.create ~last_line:(Loc.line_end' !(env.lex_last_loc)) start stop
   in
   let rec helper comments env =
     Sedlexing.start env.Lex_env.lex_lb;
-    match f env with
-    | Token (env, t), lex_loc ->
+    let res, lex_loc = f env in
+    match res with
+    | Token (env, t) ->
+        env.lex_last_loc := lex_loc;
         let lex_token = t in
         let lex_errors_acc = env.lex_state.lex_errors_acc in
         if lex_errors_acc = []
         then env, { Lex_result.lex_token; lex_loc; lex_errors = [] }
         else
           ( { env with lex_state = Lex_env.empty_lex_state }
           , { Lex_result.lex_token; lex_loc; lex_errors = List.rev lex_errors_acc } )
-    | Comment (env, comment), lex_loc ->
+    | Comment (env, comment) ->
+        env.lex_last_loc := lex_loc;
         let lex_errors_acc = env.lex_state.lex_errors_acc in
         ( env
         , { Lex_result.lex_token = TComment comment
           ; lex_loc
           ; lex_errors = List.rev lex_errors_acc
           } )
-    | Continue env, _ -> helper comments env
+    | Continue env -> helper comments env
   in
   fun env -> helper [] env
 

compiler/lib/flow_lexer.mli

@@ -18,14 +18,6 @@ module Parse_error : sig
   val to_string : t -> string
 end
 
-module Loc : sig
-  type t =
-    { source : string option
-    ; start : Lexing.position
-    ; _end : Lexing.position
-    }
-end
-
 module Lex_env : sig
   type t
 
@@ -37,7 +29,7 @@ module Lex_result : sig
 
   val token : t -> Js_token.t
 
-  val loc : t -> Lexing.position * Lexing.position
+  val loc : t -> Loc.t
 
   val errors : t -> (Loc.t * Parse_error.t) list
 end

compiler/lib/js_parser.mly

@@ -217,19 +217,22 @@ T_BACKQUOTE
 (* Macros *)
 (*************************************************************************)
 
-listc(X):
+listc_rev(X):
  | X              { [$1] }
- | listc(X) "," X { $1 @ [$3] }
+ | listc_rev(X) "," X { $3 :: $1 }
 
-listc_with_empty_trail(X):
- | e=elision               { (List.map (fun () -> None) e) }
- | x=X e=elision           { Some x :: (List.map (fun () -> None) e) }
- | listc_with_empty_trail(X) x=X e=elision { $1 @ [Some x] @ (List.map (fun () -> None) e) }
+%inline listc(X):
+ | listc_rev(X) { List.rev $1 }
+
+listc_with_empty_trail_rev(X):
+ | e=elision               { (List.rev_map (fun () -> None) e) }
+ | x=X e=elision           { List.rev_append (List.rev_map (fun () -> None) e) [ Some x ]   }
+ | listc_with_empty_trail_rev(X) x=X e=elision { List.rev_append (List.rev_map (fun () -> None) e) (Some x :: $1) }
 
 listc_with_empty(X):
   | X                           { [ Some $1 ] }
-  | listc_with_empty_trail(X)   { $1 }
-  | listc_with_empty_trail(X) X { $1 @ [Some $2 ] }
+  | listc_with_empty_trail_rev(X)   { List.rev $1 }
+  | listc_with_empty_trail_rev(X) X { List.rev ((Some $2) :: $1) }
 optl(X):
  | (* empty *) { [] }
  | X           { $1 }

compiler/lib/js_traverse.ml

@@ -779,18 +779,33 @@ class free =
         }
 
     method use_var x =
-      let n = try IdentMap.find x !count with Not_found -> 0 in
-      count := IdentMap.add x (succ n) !count;
+      count :=
+        IdentMap.update
+          x
+          (function
+            | None -> Some 1
+            | Some n -> Some (succ n))
+          !count;
       state_ <- { state_ with use = IdentSet.add x state_.use }
 
     method def_var x =
-      let n = try IdentMap.find x !count with Not_found -> 0 in
-      count := IdentMap.add x (succ n) !count;
+      count :=
+        IdentMap.update
+          x
+          (function
+            | None -> Some 1
+            | Some n -> Some (succ n))
+          !count;
       state_ <- { state_ with def_var = IdentSet.add x state_.def_var }
 
     method def_local x =
-      let n = try IdentMap.find x !count with Not_found -> 0 in
-      count := IdentMap.add x (succ n) !count;
+      count :=
+        IdentMap.update
+          x
+          (function
+            | None -> Some 1
+            | Some n -> Some (succ n))
+          !count;
       state_ <- { state_ with def_local = IdentSet.add x state_.def_local }
 
     method fun_decl (k, params, body, nid) =