oxcaml · riaqn · May 29, 2025 · May 30, 2025 · May 30, 2025 · May 30, 2025
diff --git a/jane/doc/extensions/_04-modes/reference.md b/jane/doc/extensions/_04-modes/reference.md
@@ -46,3 +46,37 @@ can construct the lazy value at `many` even if the thunk is `once` (e.g., closin
 let r = { x = 0 } in
 let l @ many = lazy (overwrite_ r with { x = 42 })
 ```
+
+# Exception
+Currently the exception type `exn` crosses portability and contention. To make
+that safe, exception constructors are assigned a portability. Such a constructor
+is portable iff all of its arguments cross portability and contention. A
+portable function cannot close over a nonportable constructor, whether for
+constructing or matching exceptions.
+
+In the following example, `Foo` is nonportable because its argument doesn't
+cross contention; similarly, `Bar` is nonportable because its argument doesn't
+cross portability. As a result, neither of `foo` and `bar` can be marked as
+portable.
+```ocaml
+exception Foo of int ref
+exception Bar of unit -> unit
+
+let (foo @ portable) () =
+    try () with
+    Foo _ -> ()
+
+let (bar @ portable) () =
+    try () with
+    Bar _ -> ()
+```
+
+In the following example, `Baz` is nonportable, but `foo` doesn't close over
+`Baz` and can be portable.
+```ocaml
+let (foo @ portable) () =
+    let module M = struct
+        exception Baz of int ref * (unit -> unit)
+    end in
+    raise (M.Baz (ref 42, fun () -> ()))
+```
diff --git a/stdlib/effect.ml b/stdlib/effect.ml
@@ -27,7 +27,9 @@ let () =
         Some msg
     | _ -> None
   in
-  Printexc.Safe.register_printer printer
+  (* need magic because jkind doesn't know [t] crosses portability and
+    contention  *)
+  Printexc.Safe.register_printer (Obj.magic_portable printer)
 
 (* Register the exceptions so that the runtime can access it *)
 type _ t += Should_not_see_this__ : unit t

diff --git a/testsuite/tests/backtrace/backtrace_effects.reference b/testsuite/tests/backtrace/backtrace_effects.reference
@@ -1,7 +1,7 @@
 (** get_callstack **)
 Raised by primitive operation at Backtrace_effects.bar in file "backtrace_effects.ml", line 20, characters 13-39
 Called from Backtrace_effects.foo in file "backtrace_effects.ml", line 27, characters 12-17
-Called from Stdlib__Effect.Must_not_enter_gc.with_stack in file "stdlib/effect.ml", line 80, characters 4-47
+Called from Stdlib__Effect.Must_not_enter_gc.with_stack in file "stdlib/effect.ml", line 82, characters 4-47
 Called from Backtrace_effects.baz in file "backtrace_effects.ml" (inlined), lines 31-41, characters 2-401
 Called from Backtrace_effects in file "backtrace_effects.ml", line 43, characters 8-14
 (** get_continuation_callstack **)
@@ -11,6 +11,6 @@ Called from Backtrace_effects.foo in file "backtrace_effects.ml", line 27, chara
 Fatal error: exception Stdlib.Exit
 Raised at Backtrace_effects.bar in file "backtrace_effects.ml", line 17, characters 4-14
 Re-raised at Backtrace_effects.baz.(fun) in file "backtrace_effects.ml", line 33, characters 21-28
-Called from Stdlib__Effect.Must_not_enter_gc.with_stack in file "stdlib/effect.ml", line 80, characters 4-47
+Called from Stdlib__Effect.Must_not_enter_gc.with_stack in file "stdlib/effect.ml", line 82, characters 4-47
 Called from Backtrace_effects.baz in file "backtrace_effects.ml" (inlined), lines 31-41, characters 2-401
 Called from Backtrace_effects in file "backtrace_effects.ml", line 43, characters 8-14
diff --git a/testsuite/tests/backtrace/backtrace_effects_nested.flambda.reference b/testsuite/tests/backtrace/backtrace_effects_nested.flambda.reference
@@ -1,5 +1,5 @@
 Raised by primitive operation at Backtrace_effects_nested.blorp in file "backtrace_effects_nested.ml", line 24, characters 2-11
-Called from Stdlib__Effect.Deep.continue in file "stdlib/effect.ml" (inlined), line 99, characters 21-64
+Called from Stdlib__Effect.Deep.continue in file "stdlib/effect.ml" (inlined), line 101, characters 21-64
 Called from Backtrace_effects_nested.baz.(fun) in file "backtrace_effects_nested.ml", line 32, characters 16-29
-Called from Stdlib__Effect.Must_not_enter_gc.with_stack in file "stdlib/effect.ml", line 80, characters 4-47
+Called from Stdlib__Effect.Must_not_enter_gc.with_stack in file "stdlib/effect.ml", line 82, characters 4-47
 43
diff --git a/testsuite/tests/effects/backtrace.byte.reference b/testsuite/tests/effects/backtrace.byte.reference
@@ -2,5 +2,5 @@ Raised at Stdlib.failwith in file "stdlib.ml", line 39, characters 17-33
 Called from Backtrace.foo in file "backtrace.ml", line 14, characters 11-27
 Called from Backtrace.bar in file "backtrace.ml", line 22, characters 4-9
 Called from Backtrace.task1 in file "backtrace.ml", line 31, characters 4-10
-Re-raised at Stdlib__Effect.Deep.discontinue_with_backtrace.(fun) in file "stdlib/effect.ml", line 104, characters 44-78
+Re-raised at Stdlib__Effect.Deep.discontinue_with_backtrace.(fun) in file "stdlib/effect.ml", line 106, characters 44-78
 Called from Backtrace.task2 in file "backtrace.ml", line 38, characters 4-16
diff --git a/testsuite/tests/effects/backtrace.reference b/testsuite/tests/effects/backtrace.reference
@@ -2,5 +2,5 @@ Raised at Stdlib.failwith in file "stdlib.ml" (inlined), line 39, characters 17-
 Called from Backtrace.foo in file "backtrace.ml", line 14, characters 11-27
 Called from Backtrace.bar in file "backtrace.ml", line 22, characters 4-9
 Called from Backtrace.task1 in file "backtrace.ml", line 31, characters 4-10
-Re-raised at Stdlib__Effect.Deep.discontinue_with_backtrace.(fun) in file "stdlib/effect.ml", line 104, characters 44-78
+Re-raised at Stdlib__Effect.Deep.discontinue_with_backtrace.(fun) in file "stdlib/effect.ml", line 106, characters 44-78
 Called from Backtrace.task2 in file "backtrace.ml", line 38, characters 4-16
diff --git a/testsuite/tests/typing-modes/exn.ml b/testsuite/tests/typing-modes/exn.ml
@@ -0,0 +1,295 @@
+(* TEST
+   expect;
+*)
+
+(* [exn] currently crosses portability. To make it safe, exception constructors
+are portable iff all its arguments are portable. *)
+
+exception Nonportable of (unit -> unit)
+exception Portable of unit
+exception Portable' of (unit -> unit) @@ portable
+
+[%%expect{|
+exception Nonportable of (unit -> unit)
+exception Portable of unit
+exception Portable' of (unit -> unit) @@ portable
+|}]
+
+let x : exn = Nonportable (fun x -> x)
+[%%expect{|
+val x : exn = Nonportable <fun>
+|}]
+
+let (foo @ portable) () =
+    match x with
+    | Nonportable g -> ()
+    | _ -> ()
+[%%expect{|
+Line 3, characters 6-17:
+3 |     | Nonportable g -> ()
+          ^^^^^^^^^^^
+Error: The constructor "Nonportable" is nonportable, so cannot be used inside a function that is portable.
+|}]
+
+let (foo @ portable) () =
+    try () with
+    | Nonportable g -> ()
+    | _ -> ()
+[%%expect{|
+Line 3, characters 6-17:
+3 |     | Nonportable g -> ()
+          ^^^^^^^^^^^
+Error: The constructor "Nonportable" is nonportable, so cannot be used inside a function that is portable.
+|}]
+
+let (foo @ portable) () =
+    match () with
+    | exception Nonportable g -> ()
+    | _ -> ()
+[%%expect{|
+Line 3, characters 16-27:
+3 |     | exception Nonportable g -> ()
+                    ^^^^^^^^^^^
+Error: The constructor "Nonportable" is nonportable, so cannot be used inside a function that is portable.
+|}]
+
+(* below we will only use [match] to test *)
+
+let (foo @ portable) () =
+    match x with
+    | Portable g -> ()
+    | _ -> ()
+[%%expect{|
+val foo : unit -> unit = <fun>
+|}]
+
+let (foo @ portable) () =
+    match x with
+    | Portable' g -> ()
+    | _ -> ()
+[%%expect{|
+val foo : unit -> unit = <fun>
+|}]
+
+let (foo @ portable) () =
+    raise (Nonportable (fun () -> ()))
+[%%expect{|
+Line 2, characters 11-22:
+2 |     raise (Nonportable (fun () -> ()))
+               ^^^^^^^^^^^
+Error: The constructor "Nonportable" is nonportable, so cannot be used inside a function that is portable.
+|}]
+
+let (foo @ portable) () =
+    raise (Portable ())
+[%%expect{|
+val foo : unit -> 'a = <fun>
+|}]
+
+let (foo @ portable) () =
+    raise (Portable' (fun () -> ()))
+[%%expect{|
+val foo : unit -> 'a = <fun>
+|}]
+
+(* rebinding counts as usage *)
+let (foo @ portable) () =
+    let module M = struct
+        exception Nonportable' = Nonportable
+    end in
+    ()
+[%%expect{|
+Line 3, characters 33-44:
+3 |         exception Nonportable' = Nonportable
+                                     ^^^^^^^^^^^
+Error: The constructor "Nonportable" is nonportable, so cannot be used inside a function that is portable.
+|}]
+
+
+(* CR zqian: the following should be allowed, but requires a completely different
+approach (coportable). *)
+exception SemiPortable of string * (unit -> unit)
+
+let (foo @ portable) () =
+    try () with
+    SemiPortable (s, _) -> print_endline s
+[%%expect{|
+exception SemiPortable of string * (unit -> unit)
+Line 5, characters 4-16:
+5 |     SemiPortable (s, _) -> print_endline s
+        ^^^^^^^^^^^^
+Error: The constructor "SemiPortable" is nonportable, so cannot be used inside a function that is portable.
+|}]
+
+(* [exn] also crosses contention. To make it safe, exception constructors
+are uncontended iff all its arguments are uncontended. *)
+exception Uncontended of unit
+exception Uncontended' of int ref @@ contended
+exception Contended of int ref
+[%%expect{|
+exception Uncontended of unit
+exception Uncontended' of int ref @@ contended
+exception Contended of int ref
+|}]
+
+let (foo @ portable) () =
+    match x with
+    | Uncontended () -> ()
+    | _ -> ()
+[%%expect{|
+val foo : unit -> unit = <fun>
+|}]
+
+let (foo @ portable) () =
+    match x with
+    | Uncontended' _ -> ()
+    | _ -> ()
+[%%expect{|
+val foo : unit -> unit = <fun>
+|}]
+
+let (foo @ portable) () =
+    match x with
+    | Contended _ -> ()
+    | _ -> ()
+[%%expect{|
+Line 3, characters 6-15:
+3 |     | Contended _ -> ()
+          ^^^^^^^^^
+Error: The constructor "Contended" is nonportable, so cannot be used inside a function that is portable.
+|}]
+
+let (foo @ portable) () =
+    raise (Uncontended ())
+[%%expect{|
+val foo : unit -> 'a = <fun>
+|}]
+
+let (foo @ portable) () =
+    raise (Uncontended' (ref 42))
+[%%expect{|
+val foo : unit -> 'a = <fun>
+|}]
+
+let (foo @ portable) () =
+    raise (Contended (ref 42))
+[%%expect{|
+Line 2, characters 11-20:
+2 |     raise (Contended (ref 42))
+               ^^^^^^^^^
+Error: The constructor "Contended" is nonportable, so cannot be used inside a function that is portable.
+|}]
+
+(* rebinding counts as usage *)
+let (foo @ portable) () =
+    let module M = struct
+        exception Contended' = Contended
+    end in
+    ()
+[%%expect{|
+Line 3, characters 31-40:
+3 |         exception Contended' = Contended
+                                   ^^^^^^^^^
+Error: The constructor "Contended" is nonportable, so cannot be used inside a function that is portable.
+|}]
+
+(* defining exception inside a portable function is fine *)
+let (foo @ portable) () =
+    let module M = struct
+        exception Bad of int ref * (unit -> unit)
+    end in
+    raise (M.Bad (ref 42, fun () -> ()))
+[%%expect{|
+val foo : unit -> 'a = <fun>
+|}]
+
+let (foo @ portable) () =
+    let exception Bad of int ref * (unit -> unit) in
+    raise (Bad (ref 42, fun () -> ()))
+[%%expect{|
+val foo : unit -> 'a = <fun>
+|}]
+
+
+exception Fields : { x : int } -> exn
+exception MutFields : { mutable x : string } -> exn
+exception MutFields': { mutable z : int ref @@ contended } -> exn
+[%%expect{|
+exception Fields : { x : int; } -> exn
+exception MutFields : { mutable x : string; } -> exn
+exception MutFields' : { mutable z : int ref @@ contended; } -> exn
+|}]
+
+let (foo @ portable) () =
+    match x with
+    | Fields _ -> ()
+    | _ -> ()
+[%%expect{|
+val foo : unit -> unit = <fun>
+|}]
+
+let (foo @ portable) () =
+    match x with
+    | MutFields _ -> ()
+    | _ -> ()
+[%%expect{|
+Line 3, characters 6-15:
+3 |     | MutFields _ -> ()
+          ^^^^^^^^^
+Error: The constructor "MutFields" is nonportable, so cannot be used inside a function that is portable.
+|}]
+
+let (foo @ portable) () =
+    match x with
+    | MutFields' _ -> ()
+    | _ -> ()
+[%%expect{|
+Line 3, characters 6-16:
+3 |     | MutFields' _ -> ()
+          ^^^^^^^^^^
+Error: The constructor "MutFields'" is nonportable, so cannot be used inside a function that is portable.
+|}]
+
+(* built-in exceptions can be raised arbitrarily inside portable functions - we
+show that's safe. *)
+let (foo @ portable) () =
+    match x with
+    | Exit
+    | Match_failure _
+    | Assert_failure _
+    | Invalid_argument _
+    | Failure _
+    | Not_found
+    | Out_of_memory
+    | Stack_overflow
+    | Sys_error _
+    | End_of_file
+    | Division_by_zero
+    | Sys_blocked_io
+    | Undefined_recursive_module _
+    | _ -> ()
+[%%expect{|
+val foo : unit -> unit = <fun>
+|}]
+
+
+(* other extensible types are not affected *)
+(* CR zqian: support other extensible types. *)
+type t = ..
+
+type t += Foo of int
+
+let x : t = Foo 42
+
+let (foo @ portable) () =
+    ignore (x : _ @ portable)
+
+[%%expect{|
+type t = ..
+type t += Foo of int
+val x : t = Foo 42
+Line 8, characters 12-13:
+8 |     ignore (x : _ @ portable)
+                ^
+Error: The value "x" is nonportable, so cannot be used inside a function that is portable.
+|}]