Add try..finally

analysis/reanalyze/src/arnold.ml

@@ -996,11 +996,13 @@ module Compile = struct
           expression ~ctx e)
       |> Command.unordered_sequence
     | Texp_assert _ -> Command.nothing
-    | Texp_try (e, cases) ->
+    | Texp_try (e, cases, finally) -> (
       let c_e = e |> expression ~ctx in
       let c_cases = cases |> List.map (case ~ctx) |> Command.nondet in
       let open Command in
-      c_e +++ c_cases
+      match finally with
+      | None -> c_e +++ c_cases
+      | Some finally -> c_e +++ c_cases +++ expression ~ctx finally)
     | Texp_variant (_label, e_opt) -> e_opt |> expression_opt ~ctx
     | Texp_while _ ->
       not_implemented "Texp_while";

analysis/reanalyze/src/exception.ml

@@ -394,18 +394,23 @@ let traverse_ast ~file ~values_builder ~checks_builder () =
             kind = Throws;
           }
           :: !current_events
-    | Texp_try (e, cases) ->
-      let exceptions =
-        cases
-        |> List.map (fun case -> case.Typedtree.c_lhs.pat_desc)
-        |> exceptions_of_patterns
-      in
-      let old_events = !current_events in
-      current_events := [];
-      e |> iter_expr self;
-      current_events :=
-        {Event.exceptions; loc; kind = Catches !current_events} :: old_events;
-      cases |> iter_cases self
+    | Texp_try (e, cases, finally) ->
+      (* Catches with no exceptions means a catch-all, so a try without catch
+         cases must not record one. *)
+      if cases <> [] then (
+        let exceptions =
+          cases
+          |> List.map (fun case -> case.Typedtree.c_lhs.pat_desc)
+          |> exceptions_of_patterns
+        in
+        let old_events = !current_events in
+        current_events := [];
+        e |> iter_expr self;
+        current_events :=
+          {Event.exceptions; loc; kind = Catches !current_events} :: old_events)
+      else e |> iter_expr self;
+      cases |> iter_cases self;
+      finally |> iter_expr_opt self
     | _ -> super.expr self expr |> ignore);
     (if is_does_no_throw then
        let nested_events = !current_events in

analysis/reanalyze/src/side_effects.ml

@@ -49,8 +49,10 @@ let rec expr_no_side_effects (expr : Typedtree.expression) =
     partial = Total && e |> expr_no_side_effects
     && cases |> List.for_all case_no_side_effects
   | Texp_letmodule _ -> false
-  | Texp_try (e, cases) ->
-    e |> expr_no_side_effects && cases |> List.for_all case_no_side_effects
+  | Texp_try (e, cases, finally) ->
+    e |> expr_no_side_effects
+    && cases |> List.for_all case_no_side_effects
+    && finally |> expr_opt_no_side_effects
   | Texp_tuple el -> el |> List.for_all expr_no_side_effects
   | Texp_variant (_lbl, eo) -> eo |> expr_opt_no_side_effects
   | Texp_field (e, _lid, _ld) -> e |> expr_no_side_effects

changes/try-finally.feature.md

@@ -0,0 +1 @@
+- Add `try ... finally { ... }` and `try ... catch { ... } finally { ... }`, compiled to JavaScript `finally` blocks.

compiler/core/js_dump.ml

@@ -1564,10 +1564,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_analysis.ml

@@ -121,6 +121,8 @@ let rec no_side_effects (lam : Lambda.t) : bool =
   *)
   | Ltrywith (body, _exn, handler) ->
     no_side_effects body && no_side_effects handler
+  | Ltryfinally (body, finally) ->
+    no_side_effects body && no_side_effects finally
   | 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
@@ -210,7 +212,7 @@ let size_upto ~limit (lam : Lambda.t) =
       add 1;
       List.iter size ls
     | Lstaticcatch _ -> add too_big
-    | Ltrywith _ -> add too_big
+    | Ltrywith _ | Ltryfinally _ -> add too_big
     | Lifthenelse (l1, l2, l3) ->
       add 1;
       size l1;

compiler/core/lam_arity_analysis.ml

@@ -120,6 +120,7 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lambda.t) : Lam_arity.t =
     | 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]
+  | Ltryfinally (body, _) -> get_arity meta body
   | 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

@@ -154,6 +154,10 @@ let rewrite (map : _ Hash_ident.t) (lam : Lambda.t) : Lambda.t =
       let v = rebind v in
       let l2 = aux l2 in
       Lambda.try_ l1 v l2
+    | Ltryfinally (l1, l2) ->
+      let l1 = aux l1 in
+      let l2 = aux l2 in
+      Lambda.try_finally l1 l2
     | Lifthenelse (l1, l2, l3) ->
       let l1 = aux l1 in
       let l2 = aux l2 in

compiler/core/lam_check.ml

@@ -92,7 +92,7 @@ let check ~file ~pass lam =
     | Lstaticcatch (e1, (j, _vars), e2) ->
       check_staticfails e1 (Set_int.add j cxt);
       check_staticfails e2 cxt
-    | Ltrywith (e1, _exn, e2) ->
+    | Ltrywith (e1, _, e2) | Ltryfinally (e1, e2) ->
       check_staticfails e1 cxt;
       check_staticfails e2 cxt
     | Lifthenelse (e1, e2, e3) -> check_list [e1; e2; e3] cxt
@@ -142,6 +142,9 @@ let check ~file ~pass lam =
       iter e1;
       def exn;
       iter e2
+    | Ltryfinally (e1, e2) ->
+      iter e1;
+      iter e2
     | Lifthenelse (e1, e2, e3) ->
       iter e1;
       iter e2;

compiler/core/lam_closure.ml

@@ -117,7 +117,7 @@ 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, _, e2) | Ltryfinally (e1, e2) ->
       iter top e1;
       iter sink_pos e2
     | Lifthenelse (e1, e2, e3) ->

compiler/core/lam_compile.ml

@@ -42,7 +42,8 @@ let rec source_loc_of_lam (lam : Lambda.t) =
     | None -> source_loc_of_lam body)
   | Lletrec (_, body) | Lsequence (_, body) -> source_loc_of_lam body
   | Lifthenelse (_, then_, _) -> source_loc_of_lam then_
-  | Lstaticcatch (body, _, _) | Ltrywith (body, _, _) -> source_loc_of_lam body
+  | Lstaticcatch (body, _, _) | Ltrywith (body, _, _) | Ltryfinally (body, _) ->
+    source_loc_of_lam body
   | Lstringswitch (_, cases, default) -> (
     match cases with
     | (_, body) :: _ -> source_loc_of_lam body
@@ -1345,16 +1346,37 @@ let compile output_prefix =
    }
    ]}
 *)
-  and compile_trywith lam id catch (lambda_cxt : Lam_compile_context.t) =
+  and compile_try lam (catch : (Ident.t * Lambda.t) option)
+      (finally : Lambda.t option) (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 *)
+         #1701, try should prevent tailcall.
+         A finally block runs after the catch handler, so the handler is not
+         in tail position either. *)
+      let with_context =
+        match finally with
+        | None -> with_context
+        | Some _ -> body_context
+      in
       [
         S.try_
           (Js_output.output_as_block (compile_lambda body_context lam))
-          ~with_:
-            (id, Js_output.output_as_block (compile_lambda with_context catch));
+          ?with_:
+            (Option.map
+               (fun (id, catch) ->
+                 ( id,
+                   Js_output.output_as_block (compile_lambda with_context catch)
+                 ))
+               catch)
+          ?finally:
+            (Option.map
+               (fun finally ->
+                 Js_output.output_as_block
+                   (compile_lambda
+                      {lambda_cxt with continuation = EffectCall Not_tail}
+                      finally))
+               finally);
       ]
     in
     match lambda_cxt.continuation with
@@ -1944,8 +1966,11 @@ let compile output_prefix =
       compile_for_await_of id iterable body lambda_cxt
     | Lassign (id, lambda) -> compile_assign id lambda lambda_cxt
     | Ltrywith (lam, id, catch) ->
-      (* generate documentation *)
-      compile_trywith lam id catch lambda_cxt
+      compile_try lam (Some (id, catch)) None lambda_cxt
+    | Ltryfinally (Ltrywith (lam, id, catch), finally) ->
+      compile_try lam (Some (id, catch)) (Some finally) lambda_cxt
+    | Ltryfinally (lam, finally) ->
+      compile_try lam None (Some finally) lambda_cxt
   in
 
   (compile_recursive_lets, compile_lambda)

compiler/core/lam_exit_count.ml

@@ -92,7 +92,7 @@ let count_helper (lam : Lambda.t) : collection option =
         count l;
         Ext_list.iter_snd sw.sw_consts count;
         Ext_list.iter_snd sw.sw_blocks count
-      | Ltrywith (l1, _v, l2) ->
+      | Ltrywith (l1, _, l2) | Ltryfinally (l1, l2) ->
         count l1;
         count l2
       | Lifthenelse (l1, l2, l3) ->

compiler/core/lam_hit.ml

@@ -38,7 +38,7 @@ 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, _, e2) | Ltryfinally (e1, e2) -> hit e1 || hit e2
     | Lfunction {body; params = _} -> hit body
     | Llet (_str, _id, arg, body) -> hit arg || hit body
     | Lletrec (decl, body) -> hit body || hit_list_snd decl
@@ -75,7 +75,7 @@ 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, _, e2) | Ltryfinally (e1, e2) -> hit e1 || hit e2
     | 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_pass_collect.ml

@@ -116,7 +116,7 @@ let collect_info (meta : Lam_stats.t) (lam : Lambda.t) =
     | Lstaticcatch (l1, (_, _), l2) ->
       collect l1;
       collect l2
-    | Ltrywith (l1, _, l2) ->
+    | Ltrywith (l1, _, l2) | Ltryfinally (l1, l2) ->
       collect l1;
       collect l2
     | Lifthenelse (l1, l2, l3) ->

compiler/core/lam_pass_count.ml

@@ -163,7 +163,7 @@ let collect_occurs lam : occ_tbl =
     | Lstaticcatch (l1, (_i, _), l2) ->
       count bv l1;
       count bv l2
-    | Ltrywith (l1, _v, l2) ->
+    | Ltrywith (l1, _, l2) | Ltryfinally (l1, l2) ->
       count bv l1;
       count bv l2
     | Lifthenelse (l1, l2, l3) ->

compiler/core/lam_pass_exits.ml

@@ -55,7 +55,7 @@ and no_bounded_variables (l : Lambda.t) =
   | Lfunction {body; params} -> params = [] && no_bounded_variables body
   | Lfor _ -> false
   | Lfor_of _ | Lfor_await_of _ -> false
-  | Ltrywith _ -> false
+  | Ltrywith _ | Ltryfinally _ -> false
   | Llet _ -> false
   | Lletrec (decl, body) -> decl = [] && no_bounded_variables body
 

compiler/ext/config.ml

@@ -1,10 +1,10 @@
-let cmi_magic_number = "Caml1999I039"
+let cmi_magic_number = "Caml1999I040"
 
 (* Magic numbers for marshaled values of the *current* parsetree, whose layout
    changes across compiler versions. *)
-and ast_impl_magic_number = "ResImpl01317"
+and ast_impl_magic_number = "ResImpl01318"
 
-and ast_intf_magic_number = "ResIntf01317"
+and ast_intf_magic_number = "ResIntf01318"
 
 (* Magic numbers of the frozen Parsetree0 (OCaml 4.06) layout used on the
    external-PPX wire. They must never be written in front of a
@@ -13,7 +13,7 @@ and ast0_impl_magic_number = "Caml1999M022"
 
 and ast0_intf_magic_number = "Caml1999N022"
 
-and cmt_magic_number = "Caml1999T047"
+and cmt_magic_number = "Caml1999T048"
 
 let get_load_path () = (Compiler_request_state.current ()).load_path
 let set_load_path path = (Compiler_request_state.current ()).load_path <- path

compiler/ml/ast_helper.ml

@@ -163,7 +163,7 @@ module Exp = struct
       =
     mk ?loc ?attrs (Pexp_apply {funct; args; partial; transformed_jsx})
   let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
-  let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b))
+  let try_ ?loc ?attrs ?finally a b = mk ?loc ?attrs (Pexp_try (a, b, finally))
   let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a)
   let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b))
   let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b))

compiler/ml/ast_helper.mli

@@ -142,7 +142,13 @@ module Exp : sig
     (arg_label * expression) list ->
     expression
   val match_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
-  val try_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
+  val try_ :
+    ?loc:loc ->
+    ?attrs:attrs ->
+    ?finally:expression ->
+    expression ->
+    case list ->
+    expression
   val tuple : ?loc:loc -> ?attrs:attrs -> expression list -> expression
   val construct :
     ?loc:loc ->

compiler/ml/ast_iterator.ml

@@ -329,9 +329,10 @@ module E = struct
     | Pexp_match (e, pel) ->
       sub.expr sub e;
       sub.cases sub pel
-    | Pexp_try (e, pel) ->
+    | Pexp_try (e, pel, finally) ->
       sub.expr sub e;
-      sub.cases sub pel
+      sub.cases sub pel;
+      iter_opt (sub.expr sub) finally
     | Pexp_tuple el -> List.iter (sub.expr sub) el
     | Pexp_construct (lid, {txt = args; loc = args_loc}) ->
       iter_loc sub lid;

compiler/ml/ast_mapper.ml

@@ -347,7 +347,10 @@ module E = struct
         (List.map (map_snd (sub.expr sub)) l)
     | Pexp_match (e, pel) ->
       match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
-    | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_try (e, pel, finally) ->
+      try_ ~loc ~attrs
+        ?finally:(map_opt (sub.expr sub) finally)
+        (sub.expr sub e) (sub.cases sub pel)
     | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
     | Pexp_construct (lid, {txt = args; loc = args_loc}) ->
       construct ~loc ~attrs (map_loc sub lid)

compiler/ml/ast_mapper_from0.ml

@@ -219,6 +219,7 @@ let raw_source_from0 sub = function
 
 let for_of_attr_name = "_res.for_of"
 let for_await_of_attr_name = "_res.for_await_of"
+let finally_attr_name = "_res.finally"
 
 let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
 
@@ -694,6 +695,21 @@ module E = struct
         | _ -> None)
       attrs
 
+  let extract_finally_attribute attrs =
+    List.find_map
+      (function
+        | {Location.txt}, Pt.PPat (_, Some expr) when txt = finally_attr_name ->
+          Some expr
+        | _ -> None)
+      attrs
+
+  let remove_finally_attribute attrs =
+    List.filter
+      (function
+        | {Location.txt}, _ when txt = finally_attr_name -> false
+        | _ -> true)
+      attrs
+
   let remove_for_of_attribute attrs =
     List.filter
       (function
@@ -1099,7 +1115,10 @@ module E = struct
            l)
     | Pexp_match (e, pel) ->
       match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
-    | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+    | Pexp_try (e, pel) ->
+      let finally = extract_finally_attribute attrs in
+      let attrs = remove_finally_attribute attrs in
+      try_ ~loc ~attrs ?finally (sub.expr sub e) (sub.cases sub pel)
     | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
     (* <></> *)
     | Pexp_construct ({txt = Longident.Lident "[]" | Longident.Lident "::"}, _)