Implement try..finally syntax

Author: cknitt

analysis/reanalyze/src/Arnold.ml

@@ -967,11 +967,12 @@ 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 cFinally = finally_expr |> expressionOpt ~ctx in
       let open Command in
-      cE +++ cCases
+      cE +++ cCases +++ cFinally
     | 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