Add exnDecElab {gen|app} expert MLB annotation

Allow the elaboration/implementation of exception declarations to be
either generative (default) or applicative.

The default generative behavior is according to the Definition of
Standard ML, where each dynamic evaluation of an `exception C of ty`
introduces a fresh exception variant with name `C` but distinct from
any previous evaluations of this `exception` declaration.  The
implementation of a generative exception declaration is:

 * introduce a `C of unit ref * ty` variant for the `exn` datatype
 * replace the `exception C of ty` declaration with
   `val nonce : unit ref = ref ()`
 * replace any `C arg` constructor applications with
   `C (nonce, arg)` constructor applications
 * replace any `case e of C x => exp | _ => next ()` pattern matches
   with
   `case e of C (n, x) => if nonce = n then exp else next () | _ => next ()`

Note that the freshness of the `ref () : unit ref` allocation is what
ensures that each dynamic evaluation of `exception C of ty` is
distinct from any previous evaluations of this `exception`
declaration.

The (new) applicative behavior simply changes the implementation to
use a `unit` nonce rather than a `unit ref` nonce.  This avoids the
allocation of a fresh `unit ref` at the `exception C of ty`
declaration.  Because MLton implements exceptions after
monomorphisation, this means that an applicative exception declaration
essentially introduces a distinct variant for each monomorphic type at
which the `exception` declaration is evaluated, allowing distinct
evaluations to share the same variant when they share the same
monomorphic type.  Because MLton implements monomorphisation after SML
type checking and elaboration, the sharing of variants is with respect
to the *elaborated* types (and ignores any type distinctions that may
have been present in the source code due to opaque signature
constraints).

The utility of applicative exception declarations is to slightly
optimize the implementation of a universal type using exceptions (see
http://mlton.org/UniversalType).  In the special case that one can be
sure that the use of the universal type will never `inject` at one
type and then try to `project` at another type that would be
considered distinct in the source code (due to opaque signature
constraints) but has the same *elaborated* type, then implementing the
universal type with an applicative exception declaration can remove
the overhead of allocating the `unit ref`.

Normally, universal types are used sparingly in idiomatic Standard ML
code and rarely occur on a hot/fast/critical path.  An exception to
this is in the implementation of parallelism, such as MaPLe's `pcall`.

Consider `pcallFork : (unit -> 'a) * (unit -> 'b) -> 'a * 'b`.
Simplifying somewhat, if the second thunk is stolen, then a
`'b option ref` must be allocated to communicate the result
of the stolen work to the main computation.  A simple implementation
would be:

    fun pcallFork (f, g) =
      let
         val gres = ref NONE
         fun seq fres = (fres, g ())
         fun par fres = (fres, get gres)
         fun spwn () = (put (gres, g ()) ; exit ())
      in
         pcall (f, seq, par, spwn)
      end

where `put` and `get` treat an `'a option ref` as an Id-style
I-structure.  The disadvantage of this implementation is that it
incurs a `ref NONE : 'b option ref` allocation for *every*
`pcallFork`, although most evaluations of `pcallFork` will not have
the second thunk stolen.  To avoid this overhead, we'd like to move
the `ref NONE` allocation to the slow path, occurring only when the
second thunk is stolen.  It is for this reason that the lower-level
`pcall` operation allows the slow-path stealing code to pass (a
pointer to) some data back to the `par` and `spwn` continuations; in
particular, we can have the stealing code allocate the `ref NONE`:

    fun pcallFork (f, g) =
      let
         fun seq fres = (fres, g ())
         fun par (fres, gres) = (fres, get gres)
         fun spwn gres = (put (gres, g ()) ; exit ())
      in
         pcall (f, seq, par, spwn)
      end

However, the stealing code is *generic* and partially implemented in
SML (and, therefore, must integrate with the SML type system).  In
particular, it only has access to an opaque `Thread.t` representing
the interrupted thread that has a `pcall` to steal and has no obvious
means of obtaining the type that the to-be-stolen thunk will return in
order to properly allocate a `ref NONE : 'b option ref`.

One expedient approach is to use a universal type.  Now, the stealing
code can allocate a `ref NONE : Universal.t option ref` and the
`pcallFork` can `inject` to / `project` from the universal type:

    fun pcallFork (f, g) =
      let
         val (inject, project) = Universal.embed ()
         fun seq fres = (fres, g ())
         fun par (fres, gres) = (fres, valOf (project (get gres)))
         fun spwn gres = (put (gres, inject (g ())) ; exit ())
      in
         pcall (f, seq, par, spwn)
      end

Unfortunately, when `structure Universal` is implemented with
generative exceptions, this reintroduces a
`val nonce : unit ref = ref ()` allocation for *every* `pcallFork`.
(Arguably, a `unit ref` is "cheaper" than a `'b ref`, since it is
expected that a meaningful `pcallFork` will have a second thunk that
returns a non-`unit` result.  A `unit ref` can be allocated with only
a header (and no object data), while a `'b ref` (with `'b` not `unit`)
will be allocated with a header and at least 8-bytes of object
data (typically, an object pointer).)

However, when `structure Universal` is implemented with applicative
exceptions, then there is only a `val nonce : unit = ()`
(which will be optimized away).  Note that a distinct `gres` is
created for each stolen `pcall` and is properly passed exactly to the
`par` and `spwn` continuations of the stolen `pcall`, so there is no
possibility of conflating the `Universal.t` values from one `pcall`
with another and the monomorphic behavior of applicative exceptions is
acceptable.

Author: MatthewFluet

mlton/atoms/atoms.fun

@@ -80,6 +80,8 @@ structure Atoms =
                              structure RealSize = RealSize
                              structure WordSize = WordSize)
 
+      structure ExnDecElab = ExnDecElab ()
+
       structure Prod = Prod ()
       structure Handler = Handler (structure Label = Label)
       structure Return = Return (structure Label = Label

mlton/atoms/atoms.sig

@@ -24,6 +24,7 @@ signature ATOMS' =
       structure CharSize: CHAR_SIZE
       structure Con: CON
       structure Const: CONST
+      structure ExnDecElab: EXN_DEC_ELAB
       structure Ffi: FFI
       structure Field: FIELD
       structure Func: FUNC
@@ -95,6 +96,7 @@ signature ATOMS =
       sharing Cases = Atoms.Cases
       sharing Con = Atoms.Con
       sharing Const = Atoms.Const
+      sharing ExnDecElab = Atoms.ExnDecElab
       sharing Ffi = Atoms.Ffi
       sharing Field = Atoms.Field
       sharing Func = Atoms.Func

mlton/atoms/exn-dec-elab.fun

@@ -0,0 +1,26 @@
+(* Copyright (C) 2024 Matthew Fluet.
+ *
+ * MLton is released under a HPND-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+functor ExnDecElab (S: EXN_DEC_ELAB_STRUCTS): EXN_DEC_ELAB =
+struct
+
+open S
+
+open Control.Elaborate.ExnDecElab
+
+val all = [App, Gen]
+
+val layout = Layout.str o toString
+
+val parse =
+   let
+      open Parse
+      infix 3 *>
+   in
+      any (List.map (all, fn ede => kw (toString ede) *> pure ede))
+   end
+
+end

mlton/atoms/exn-dec-elab.sig

@@ -0,0 +1,19 @@
+(* Copyright (C) 2024 Matthew Fluet.
+ *
+ * MLton is released under a HPND-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+signature EXN_DEC_ELAB_STRUCTS =
+   sig
+   end
+
+signature EXN_DEC_ELAB =
+   sig
+      include EXN_DEC_ELAB_STRUCTS
+
+      datatype t = App | Gen
+
+      val layout: t -> Layout.t
+      val parse: t Parse.t
+   end

mlton/atoms/sources.cm

@@ -15,6 +15,7 @@ signature CHAR_SIZE
 signature CONST
 signature C_FUNCTION
 signature C_TYPE
+signature EXN_DEC_ELAB
 signature HASH_TYPE
 signature ID
 signature INT_SIZE
@@ -108,6 +109,8 @@ cases.sig
 cases.fun
 prim.sig
 prim.fun
+exn-dec-elab.sig
+exn-dec-elab.fun
 prod.sig
 prod.fun
 handler.sig

mlton/atoms/sources.mlb

@@ -70,6 +70,8 @@ local
    cases.fun
    prim.sig
    prim.fun
+   exn-dec-elab.sig
+   exn-dec-elab.fun
    prod.sig
    prod.fun
    handler.sig
@@ -97,6 +99,7 @@ in
    signature CONST
    signature C_FUNCTION
    signature C_TYPE
+   signature EXN_DEC_ELAB
    signature HASH_TYPE
    signature ID
    signature INT_SIZE

mlton/control/control-flags.sig

@@ -134,6 +134,12 @@ signature CONTROL_FLAGS =
                      Default
                    | Ignore
                end
+            structure ExnDecElab :
+               sig
+                  datatype t = App | Gen
+                  val toString: t -> string
+               end
+
             structure ResolveScope :
                sig
                   datatype t =
@@ -154,6 +160,7 @@ signature CONTROL_FLAGS =
             val allowRedefineSpecialIds: (bool,bool) t
             val allowSpecifySpecialIds: (bool,bool) t
             val deadCode: (bool,bool) t
+            val exnDecElab: (ExnDecElab.t,ExnDecElab.t) t
             val forceUsed: (unit,bool) t
             val ffiStr: (string,string option) t
             val nonexhaustiveBind: (DiagEIW.t,DiagEIW.t) t

mlton/control/control-flags.sml

@@ -356,6 +356,20 @@ structure Elaborate =
                 | Ignore => "ignore"
          end
 
+      structure ExnDecElab =
+         struct
+            datatype t = App | Gen
+
+            val fromString: string -> t option =
+               fn "app" => SOME App
+                | "gen" => SOME Gen
+                | _ => NONE
+
+            val toString: t -> string =
+               fn App => "app"
+                | Gen => "gen"
+         end
+
       structure ResolveScope =
          struct
             datatype t =
@@ -658,6 +672,19 @@ structure Elaborate =
          val (deadCode, ac) =
             makeBool ({name = "deadCode",
                        default = false, expert = true}, ac)
+         val (exnDecElab, ac) =
+            make ({choices = SOME [ExnDecElab.App, ExnDecElab.Gen],
+                   default = ExnDecElab.Gen,
+                   expert = true,
+                   toString = ExnDecElab.toString,
+                   name = "exnDecElab",
+                   newCur = fn (_,ede) => ede,
+                   newDef = fn (_,ede) => ede,
+                   parseArgs = fn args' =>
+                               case args' of
+                                  [arg'] => ExnDecElab.fromString arg'
+                                | _ => NONE},
+                  ac)
          val (forceUsed, ac) =
             make ({choices = NONE,
                    default = false,

mlton/core-ml/core-ml.fun

@@ -166,7 +166,8 @@ datatype dec =
                 tycon: Tycon.t,
                 tyvars: Tyvar.t vector} vector
  | Exception of {arg: Type.t option,
-                 con: Con.t}
+                 con: Con.t,
+                 elab: ExnDecElab.t}
  | Fun of {decs: {lambda: lambda,
                   var: Var.t} vector,
            tyvars: unit -> Tyvar.t vector}
@@ -248,8 +249,11 @@ in
                         align
                         (separateLeft (Vector.toListMap (cons, layoutConArg),
                                        "| "))]))]
-       | Exception ca =>
-            seq [str "exception ", layoutConArg ca]
+       | Exception {con, arg, elab} =>
+            seq [str "exception ",
+                 ExnDecElab.layout elab,
+                 str " ",
+                 layoutConArg {con = con, arg = arg}]
        | Fun {decs, tyvars, ...} => layoutFuns (tyvars, decs)
        | Val {rvbs, tyvars, vbs, ...} =>
             align [layoutFuns (tyvars, rvbs),

mlton/core-ml/core-ml.sig

@@ -163,7 +163,8 @@ signature CORE_ML =
                             tycon: Tycon.t,
                             tyvars: Tyvar.t vector} vector
              | Exception of {arg: Type.t option,
-                             con: Con.t}
+                             con: Con.t,
+                             elab: ExnDecElab.t}
              | Fun of {decs: {lambda: Lambda.t,
                               var: Var.t} vector,
                        tyvars: unit -> Tyvar.t vector}

mlton/defunctorize/defunctorize.fun

@@ -744,9 +744,10 @@ fun defunctorize (CoreML.Program.T {decs}) =
          in
             case d of
                Datatype _ => e
-             | Exception {arg, con} =>
+             | Exception {arg, con, elab} =>
                   prefix (Xdec.Exception {arg = Option.map (arg, loopTy),
-                                          con = con})
+                                          con = con,
+                                          elab = elab})
              | Fun {decs, tyvars} =>
                   prefix (Xdec.Fun {decs = processLambdas decs,
                                     tyvars = tyvars ()})

mlton/elaborate/elaborate-core.fun

@@ -15,6 +15,7 @@ open S
 local
    open Control.Elaborate
 in
+   val exnDecElab = fn () => current exnDecElab
    val nonexhaustiveBind = fn () => current nonexhaustiveBind
    val nonexhaustiveExnBind = fn () => current nonexhaustiveExnBind
    val nonexhaustiveExnMatch = fn () => current nonexhaustiveExnMatch
@@ -137,6 +138,7 @@ in
    structure Convention = CFunction.Convention
    structure Cdec = Dec
    structure Cexp = Exp
+   structure ExnDecElab = ExnDecElab
    structure Ffi = Ffi
    structure IntSize = IntSize
    structure Lambda = Lambda
@@ -2336,10 +2338,17 @@ fun elaborateDec (d, {env = E, nest}) =
                                                      end
                                             val scheme = Scheme.fromType ty
                                             val _ = Env.extendExn (E, exn, exn', scheme)
+                                            val elab =
+                                               case exnDecElab () of
+                                                  Control.Elaborate.ExnDecElab.App =>
+                                                     ExnDecElab.App
+                                                | Control.Elaborate.ExnDecElab.Gen =>
+                                                     ExnDecElab.Gen
                                          in
                                             Decs.add (decs,
                                                       Cdec.Exception {arg = arg,
-                                                                      con = exn'})
+                                                                      con = exn',
+                                                                      elab = elab})
                                          end
                              in
                                 decs

mlton/main/compile.fun

@@ -225,7 +225,8 @@ local
          List.concat [[Datatype primitiveDatatypes],
                       List.map
                       (primitiveExcons, fn c =>
-                       Exception {con = c, arg = NONE})]
+                       Exception {con = c, arg = NONE,
+                                  elab = CoreML.ExnDecElab.Gen})]
       end
 
 in