Add try..finally syntax

analysis/reanalyze/src/Arnold.ml

@@ -967,11 +967,13 @@ module Compile = struct
     | Texp_tuple expressions | Texp_array expressions ->
       expressions |> List.map (expression ~ctx) |> Command.unorderedSequence
     | Texp_assert _ -> Command.nothing
-    | Texp_try (e, cases) ->
+    | Texp_try (e, cases, finally_expr) -> (
       let cE = e |> expression ~ctx in
       let cCases = cases |> List.map (case ~ctx) |> Command.nondet in
       let open Command in
-      cE +++ cCases
+      match finally_expr with
+      | Some finally -> cE +++ cCases +++ (finally |> expression ~ctx)
+      | None -> cE +++ cCases)
     | Texp_variant (_label, eOpt) -> eOpt |> expressionOpt ~ctx
     | Texp_while _ ->
       notImplemented "Texp_while";

analysis/reanalyze/src/Exception.ml

@@ -335,7 +335,7 @@ let traverseAst () =
             kind = Raises;
           }
           :: !currentEvents
-    | Texp_try (e, cases) ->
+    | Texp_try (e, cases, finally_expr) ->
       let exceptions =
         cases
         |> List.map (fun case -> case.Typedtree.c_lhs.pat_desc)
@@ -346,7 +346,8 @@ let traverseAst () =
       e |> iterExpr self;
       currentEvents :=
         {Event.exceptions; loc; kind = Catches !currentEvents} :: oldEvents;
-      cases |> iterCases self
+      cases |> iterCases self;
+      finally_expr |> iterExprOpt self
     | _ -> super.expr self expr |> ignore);
     (if isDoesNoRaise then
        let nestedEvents = !currentEvents in

analysis/reanalyze/src/SideEffects.ml

@@ -45,8 +45,10 @@ let rec exprNoSideEffects (expr : Typedtree.expression) =
     partial = Total && e |> exprNoSideEffects
     && cases |> List.for_all caseNoSideEffects
   | Texp_letmodule _ -> false
-  | Texp_try (e, cases) ->
-    e |> exprNoSideEffects && cases |> List.for_all caseNoSideEffects
+  | Texp_try (e, cases, finally_expr) ->
+    e |> exprNoSideEffects
+    && cases |> List.for_all caseNoSideEffects
+    && finally_expr |> exprOptNoSideEffects
   | Texp_tuple el -> el |> List.for_all exprNoSideEffects
   | Texp_variant (_lbl, eo) -> eo |> exprOptNoSideEffects
   | Texp_field (e, _lid, _ld) -> e |> exprNoSideEffects

analysis/src/ProcessCmt.ml

@@ -700,14 +700,15 @@ and scanLetModules ~env (e : Typedtree.expression) =
     | Some g -> scanLetModules ~env g
     | None -> ());
     scanLetModules ~env c_rhs
-  | Texp_try (e, cases) ->
+  | Texp_try (e, cases, finally_expr) ->
     scanLetModules ~env e;
     cases
     |> List.iter (fun {Typedtree.c_lhs = _; c_guard; c_rhs} ->
            (match c_guard with
            | Some g -> scanLetModules ~env g
            | None -> ());
-           scanLetModules ~env c_rhs)
+           scanLetModules ~env c_rhs);
+    finally_expr |> Option.iter (scanLetModules ~env)
   | Texp_ifthenelse (e1, e2, e3Opt) -> (
     scanLetModules ~env e1;
     scanLetModules ~env e2;

compiler/core/js_dump.ml

@@ -1581,10 +1581,10 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt =
         match fin with
         | None -> cxt
         | Some b ->
-          P.group f 1 (fun _ ->
-              P.string f L.finally;
-              P.space f;
-              brace_block cxt f b))
+          P.space f;
+          P.string f L.finally;
+          P.space f;
+          brace_block cxt f b)
 
 and function_body ?directive (cxt : cxt) f ~return_unit (b : J.block) : unit =
   (match directive with

compiler/core/lam.ml

@@ -101,7 +101,7 @@ module Types = struct
     | Lstringswitch of t * (string * t) list * t option
     | Lstaticraise of int * t list
     | Lstaticcatch of t * (int * ident list) * t
-    | Ltrywith of t * ident * t
+    | Ltrywith of t * ident * t option * t option
     | Lifthenelse of t * t * t
     | Lsequence of t * t
     | Lwhile of t * t
@@ -153,7 +153,7 @@ module X = struct
     | Lstringswitch of t * (string * t) list * t option
     | Lstaticraise of int * t list
     | Lstaticcatch of t * (int * ident list) * t
-    | Ltrywith of t * ident * t
+    | Ltrywith of t * ident * t option * t option
     | Lifthenelse of t * t * t
     | Lsequence of t * t
     | Lwhile of t * t
@@ -224,10 +224,11 @@ let inner_map (l : t) (f : t -> X.t) : X.t =
     let e1 = f e1 in
     let e2 = f e2 in
     Lstaticcatch (e1, vars, e2)
-  | Ltrywith (e1, exn, e2) ->
+  | Ltrywith (e1, exn, e2, finally_expr) ->
     let e1 = f e1 in
-    let e2 = f e2 in
-    Ltrywith (e1, exn, e2)
+    let e2 = Ext_option.map e2 f in
+    let finally_expr = Ext_option.map finally_expr f in
+    Ltrywith (e1, exn, e2, finally_expr)
   | Lifthenelse (e1, e2, e3) ->
     let e1 = f e1 in
     let e2 = f e2 in
@@ -457,7 +458,8 @@ let function_ ~attr ~arity ~params ~body : t =
 let let_ kind id e body : t = Llet (kind, id, e, body)
 let letrec bindings body : t = Lletrec (bindings, body)
 let while_ a b : t = Lwhile (a, b)
-let try_ body id handler : t = Ltrywith (body, id, handler)
+let try_ body id handler finally_expr : t =
+  Ltrywith (body, id, handler, finally_expr)
 let for_ v e1 e2 dir e3 : t = Lfor (v, e1, e2, dir, e3)
 let assign v l : t = Lassign (v, l)
 let staticcatch a b c : t = Lstaticcatch (a, b, c)

compiler/core/lam.mli

@@ -74,7 +74,7 @@ and t = private
   | Lstringswitch of t * (string * t) list * t option
   | Lstaticraise of int * t list
   | Lstaticcatch of t * (int * ident list) * t
-  | Ltrywith of t * ident * t
+  | Ltrywith of t * ident * t option * t option
   | Lifthenelse of t * t * t
   | Lsequence of t * t
   | Lwhile of t * t
@@ -151,7 +151,7 @@ val seq : t -> t -> t
 val while_ : t -> t -> t
 
 (* val event : t -> Lambda.lambda_event -> t   *)
-val try_ : t -> ident -> t -> t
+val try_ : t -> ident -> t option -> t option -> t
 
 val assign : ident -> t -> t
 

compiler/core/lam_analysis.ml

@@ -109,8 +109,10 @@ let rec no_side_effects (lam : Lam.t) : bool =
       for example [String.contains],
       [Format.make_queue_elem]
   *)
-  | Ltrywith (body, _exn, handler) ->
-    no_side_effects body && no_side_effects handler
+  | Ltrywith (body, _exn, handler, finally_expr) ->
+    no_side_effects body
+    && Option.fold ~none:true ~some:no_side_effects handler
+    && Option.fold ~none:true ~some:no_side_effects finally_expr
   | Lifthenelse (a, b, c) ->
     no_side_effects a && no_side_effects b && no_side_effects c
   | Lsequence (a, b) -> no_side_effects a && no_side_effects b
@@ -174,7 +176,10 @@ let rec size (lam : Lam.t) =
     | Lstaticraise (_i, ls) ->
       Ext_list.fold_left ls 1 (fun acc x -> size x + acc)
     | Lstaticcatch _ -> really_big ()
-    | Ltrywith _ -> really_big ()
+    | Ltrywith (body, _exn, handler, finally_expr) ->
+      size body
+      + Option.fold ~none:0 ~some:size handler
+      + Option.fold ~none:0 ~some:size finally_expr
     | Lifthenelse (l1, l2, l3) -> 1 + size l1 + size l2 + size l3
     | Lsequence (l1, l2) -> size l1 + size l2
     | Lwhile _ -> really_big ()

compiler/core/lam_arity_analysis.ml

@@ -125,7 +125,12 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t =
     | None -> all_lambdas meta (Ext_list.map sw snd)
     | Some v -> all_lambdas meta (v :: Ext_list.map sw snd))
   | Lstaticcatch (_, _, handler) -> get_arity meta handler
-  | Ltrywith (l1, _, l2) -> all_lambdas meta [l1; l2]
+  | Ltrywith (l1, _, Some l2, Some finally_expr) ->
+    all_lambdas meta [l1; l2; finally_expr]
+  | Ltrywith (l1, _, Some l2, None) -> all_lambdas meta [l1; l2]
+  | Ltrywith (l1, _, None, Some finally_expr) ->
+    all_lambdas meta [l1; finally_expr]
+  | Ltrywith (l1, _, None, None) -> all_lambdas meta [l1]
   | Lifthenelse (_, l2, l3) -> all_lambdas meta [l2; l3]
   | Lsequence (_, l2) -> get_arity meta l2
   | Lstaticraise _ (* since it will not be in tail position *) -> Lam_arity.na

compiler/core/lam_bounded_vars.ml

@@ -136,11 +136,12 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t =
       let l = aux l in
       Lam.stringswitch l (Ext_list.map_snd sw aux) (option_map d)
     | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux)
-    | Ltrywith (l1, v, l2) ->
+    | Ltrywith (l1, v, l2, finally_expr) ->
       let l1 = aux l1 in
       let v = rebind v in
-      let l2 = aux l2 in
-      Lam.try_ l1 v l2
+      let l2 = option_map l2 in
+      let finally_expr = option_map finally_expr in
+      Lam.try_ l1 v l2 finally_expr
     | Lifthenelse (l1, l2, l3) ->
       let l1 = aux l1 in
       let l2 = aux l2 in

compiler/core/lam_check.ml

@@ -81,9 +81,10 @@ let check file lam =
     | Lstaticcatch (e1, (j, _vars), e2) ->
       check_staticfails e1 (Set_int.add cxt j);
       check_staticfails e2 cxt
-    | Ltrywith (e1, _exn, e2) ->
+    | Ltrywith (e1, _exn, e2, finally_expr) ->
       check_staticfails e1 cxt;
-      check_staticfails e2 cxt
+      Ext_option.iter e2 (fun expr -> check_staticfails expr cxt);
+      Ext_option.iter finally_expr (fun expr -> check_staticfails expr cxt)
     | Lifthenelse (e1, e2, e3) -> check_list [e1; e2; e3] cxt
     | Lsequence (e1, e2) -> check_list [e1; e2] cxt
     | Lassign (_id, e) -> check_staticfails e cxt
@@ -127,10 +128,11 @@ let check file lam =
       iter e1;
       List.iter def vars;
       iter e2
-    | Ltrywith (e1, exn, e2) ->
+    | Ltrywith (e1, exn, e2, finally_expr) ->
       iter e1;
       def exn;
-      iter e2
+      Ext_option.iter e2 iter;
+      Ext_option.iter finally_expr iter
     | Lifthenelse (e1, e2, e3) ->
       iter e1;
       iter e2;

compiler/core/lam_closure.ml

@@ -115,9 +115,10 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t)
       iter sink_pos e1;
       local_add_list vars;
       iter sink_pos e2
-    | Ltrywith (e1, _exn, e2) ->
+    | Ltrywith (e1, _exn, e2, finally_expr) ->
       iter top e1;
-      iter sink_pos e2
+      Ext_option.iter e2 (iter sink_pos);
+      Ext_option.iter finally_expr (iter sink_pos)
     | Lifthenelse (e1, e2, e3) ->
       iter top e1;
       let top = Lam_var_stats.new_position_after_lam e1 top in

compiler/core/lam_compile.ml

@@ -1211,17 +1211,27 @@ let compile output_prefix =
    }
    ]}
 *)
-  and compile_trywith lam id catch (lambda_cxt : Lam_compile_context.t) =
+  and compile_trywith lam id catch finally_expr
+      (lambda_cxt : Lam_compile_context.t) =
     let aux (with_context : Lam_compile_context.t)
         (body_context : Lam_compile_context.t) =
       (* should_return is passed down
          #1701, try should prevent tailcall *)
-      [
-        S.try_
-          (Js_output.output_as_block (compile_lambda body_context lam))
-          ~with_:
-            (id, Js_output.output_as_block (compile_lambda with_context catch));
-      ]
+      let body = Js_output.output_as_block (compile_lambda body_context lam) in
+      let with_ =
+        Ext_option.map catch (fun catch_lam ->
+            ( id,
+              Js_output.output_as_block (compile_lambda with_context catch_lam)
+            ))
+      in
+      let finally =
+        Ext_option.map finally_expr (fun finally_lam ->
+            let finally_cxt =
+              {lambda_cxt with continuation = EffectCall Not_tail}
+            in
+            Js_output.output_as_block (compile_lambda finally_cxt finally_lam))
+      in
+      [S.try_ body ?with_ ?finally]
     in
     match lambda_cxt.continuation with
     | Declare (kind, id) ->
@@ -1825,9 +1835,9 @@ let compile output_prefix =
           (if direction = Upto then Upto else Downto)
           body lambda_cxt)
     | Lassign (id, lambda) -> compile_assign id lambda lambda_cxt
-    | Ltrywith (lam, id, catch) ->
+    | Ltrywith (lam, id, catch, finally_expr) ->
       (* generate documentation *)
-      compile_trywith lam id catch lambda_cxt
+      compile_trywith lam id catch finally_expr lambda_cxt
   in
 
   (compile_recursive_lets, compile_lambda)

compiler/core/lam_convert.ml

@@ -84,7 +84,8 @@ let exception_id_destructed (l : Lam.t) (fv : Ident.t) : bool =
     | Lvar id -> Ident.same id fv
     | Lassign (id, e) -> Ident.same id fv || hit e
     | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2
-    | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2
+    | Ltrywith (e1, _exn, e2, finally_expr) ->
+      hit e1 || Ext_option.exists e2 hit || Ext_option.exists finally_expr hit
     | Lfunction {body; params = _} -> hit body
     | Llet (_str, _id, arg, body) -> hit arg || hit body
     | Lletrec (decl, body) -> hit body || hit_list_snd decl
@@ -491,16 +492,20 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) :
       convert_aux b
     | Lstaticcatch (b, (i, ids), handler) ->
       Lam.staticcatch (convert_aux b) (i, ids) (convert_aux handler)
-    | Ltrywith (b, id, handler) ->
+    | Ltrywith (b, id, handler, finally) -> (
       let body = convert_aux b in
-      let handler = convert_aux handler in
-      if exception_id_destructed handler id then
+      let handler = Ext_option.map handler convert_aux in
+      let converted_finally = Ext_option.map finally convert_aux in
+      match handler with
+      | Some handler when exception_id_destructed handler id ->
         let new_id = Ident.create ("raw_" ^ id.name) in
         Lam.try_ body new_id
-          (Lam.let_ StrictOpt id
-             (prim ~primitive:Pwrap_exn ~args:[Lam.var new_id] Location.none)
-             handler)
-      else Lam.try_ body id handler
+          (Some
+             (Lam.let_ StrictOpt id
+                (prim ~primitive:Pwrap_exn ~args:[Lam.var new_id] Location.none)
+                handler))
+          converted_finally
+      | _ -> Lam.try_ body id handler converted_finally)
     | Lifthenelse (b, then_, else_) ->
       Lam.if_ (convert_aux b) (convert_aux then_) (convert_aux else_)
     | Lsequence (a, b) -> Lam.seq (convert_aux a) (convert_aux b)

compiler/core/lam_exit_count.ml

@@ -79,9 +79,10 @@ let count_helper (lam : Lam.t) : collection =
       count l;
       Ext_list.iter_snd sw.sw_consts count;
       Ext_list.iter_snd sw.sw_blocks count
-    | Ltrywith (l1, _v, l2) ->
+    | Ltrywith (l1, _v, l2, finally_expr) ->
       count l1;
-      count l2
+      Ext_option.iter l2 count;
+      Ext_option.iter finally_expr count
     | Lifthenelse (l1, l2, l3) ->
       count l1;
       count l2;

compiler/core/lam_free_variables.ml

@@ -37,10 +37,11 @@ let pass_free_variables (l : Lam.t) : Set_ident.t =
       free e1;
       free e2;
       Ext_list.iter vars (fun id -> fv := Set_ident.remove !fv id)
-    | Ltrywith (e1, exn, e2) ->
+    | Ltrywith (e1, exn, e2, finally_expr) ->
       free e1;
-      free e2;
-      fv := Set_ident.remove !fv exn
+      Ext_option.iter e2 free;
+      fv := Set_ident.remove !fv exn;
+      Ext_option.iter finally_expr free
     | Lfunction {body; params} ->
       free body;
       Ext_list.iter params (fun param -> fv := Set_ident.remove !fv param)

compiler/core/lam_hit.ml

@@ -38,7 +38,8 @@ let hit_variables (fv : Set_ident.t) (l : t) : bool =
     | Lvar id -> hit_var id
     | Lassign (id, e) -> hit_var id || hit e
     | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2
-    | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2
+    | Ltrywith (e1, _exn, e2, finally_expr) ->
+      hit e1 || Ext_option.exists e2 hit || Ext_option.exists finally_expr hit
     | Lfunction {body; params = _} -> hit body
     | Llet (_str, _id, arg, body) -> hit arg || hit body
     | Lletrec (decl, body) -> hit body || hit_list_snd decl
@@ -73,7 +74,8 @@ let hit_variable (fv : Ident.t) (l : t) : bool =
     | Lvar id -> hit_var id
     | Lassign (id, e) -> hit_var id || hit e
     | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2
-    | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2
+    | Ltrywith (e1, _exn, e2, finally_expr) ->
+      hit e1 || Ext_option.exists e2 hit || Ext_option.exists finally_expr hit
     | Lfunction {body; params = _} -> hit body
     | Llet (_str, _id, arg, body) -> hit arg || hit body
     | Lletrec (decl, body) -> hit body || hit_list_snd decl

compiler/core/lam_iter.ml

@@ -62,9 +62,10 @@ let inner_iter (l : t) (f : t -> unit) : unit =
   | Lstaticcatch (e1, _vars, e2) ->
     f e1;
     f e2
-  | Ltrywith (e1, _exn, e2) ->
+  | Ltrywith (e1, _exn, e2, finally_expr) ->
     f e1;
-    f e2
+    Ext_option.iter e2 f;
+    Ext_option.iter finally_expr f
   | Lifthenelse (e1, e2, e3) ->
     f e1;
     f e2;
@@ -107,7 +108,8 @@ let inner_exists (l : t) (f : t -> bool) : bool =
   | Lprim {args; primitive = _; loc = _} -> Ext_list.exists args f
   | Lstaticraise (_id, args) -> Ext_list.exists args f
   | Lstaticcatch (e1, _vars, e2) -> f e1 || f e2
-  | Ltrywith (e1, _exn, e2) -> f e1 || f e2
+  | Ltrywith (e1, _exn, e2, finally_expr) ->
+    f e1 || Ext_option.exists e2 f || Ext_option.exists finally_expr f
   | Lifthenelse (e1, e2, e3) -> f e1 || f e2 || f e3
   | Lsequence (e1, e2) -> f e1 || f e2
   | Lwhile (e1, e2) -> f e1 || f e2