CPS/Nested IR: Make 'Raise' a constructor of CExp/Stat

src/codegen-js.sml

@@ -1308,19 +1308,6 @@ struct
          in
            case dec of
              N.ValDec
-               { exp =
-                   N.PrimOp
-                     { primOp =
-                         F.RaiseOp
-                           (_ (* span as { start as { file, line, column }, ... } *))
-                     , tyargs = _
-                     , args = [exp]
-                     }
-               , results = _
-               } =>
-               List.rev
-                 (J.ThrowStat (doExp (ctx, env, exp)) :: revStats) (* TODO: location information *)
-           | N.ValDec
                { exp = N.PrimOp {primOp as F.PrimCall prim, tyargs, args}
                , results
                } =>
@@ -2112,6 +2099,9 @@ struct
                      )
                  end
              end)
+    | doCExp ctx env
+        (N.Raise (_ (* span as {start as {file, line, column}} *), exp)) =
+        [J.ThrowStat (doExp (ctx, env, exp))] (* TODO: location information *)
     | doCExp _ _ N.Unreachable = []
 
   fun doProgramDirect ctx cont cexp =

src/codegen-lua.sml

@@ -1737,31 +1737,6 @@ struct
          in
            case dec of
              N.ValDec
-               { exp =
-                   N.PrimOp
-                     { primOp = F.RaiseOp {start as {file, line, column}, ...}
-                     , tyargs = _
-                     , args = [exp]
-                     }
-               , results = _
-               } =>
-               let
-                 val exp = doExp (ctx, env, exp)
-                 val locationInfo =
-                   if start = SourcePos.nullPos then
-                     L.ConstExp L.Nil
-                   else
-                     L.ConstExp (L.LiteralString
-                       (OS.Path.file file ^ ":" ^ Int.toString line ^ ":"
-                        ^ Int.toString column))
-               in
-                 List.rev
-                   (L.CallStat
-                      ( L.VarExp (L.PredefinedId "_raise")
-                      , vector [exp, locationInfo]
-                      ) :: revStats) (* discard continuation *)
-               end
-           | N.ValDec
                { exp = N.PrimOp {primOp as F.PrimCall prim, tyargs, args}
                , results
                } =>
@@ -2707,6 +2682,7 @@ struct
             | containsNestedBlock (N.AppCont _) = false
             | containsNestedBlock (N.If _) = true
             | containsNestedBlock (N.Handle _) = true
+            | containsNestedBlock (N.Raise _) = false
             | containsNestedBlock N.Unreachable = false
           and containsNestedBlockDec (N.ValDec _) = false
             | containsNestedBlockDec (N.RecDec _) = true
@@ -2796,6 +2772,20 @@ struct
               )
           ]
         end
+    | doCExp (ctx, env, _, N.Raise ({start as {file, line, column}, ...}, exp)) =
+        let
+          val exp = doExp (ctx, env, exp)
+          val locationInfo =
+            if start = SourcePos.nullPos then
+              L.ConstExp L.Nil
+            else
+              L.ConstExp (L.LiteralString
+                (OS.Path.file file ^ ":" ^ Int.toString line ^ ":"
+                 ^ Int.toString column))
+        in
+          [L.CallStat
+             (L.VarExp (L.PredefinedId "_raise"), vector [exp, locationInfo])]
+        end
     | doCExp (_, _, _, N.Unreachable) = []
 
   fun doProgram ctx cont cexp =

src/cps.sml

@@ -74,6 +74,7 @@ sig
       , successfulExitIn: CVar
       , successfulExitOut: CVar
       }
+  | Raise of SourcePos.span * Value
   | Unreachable
   val isDiscardable: SimpleExp -> bool
   val containsApp: CExp -> bool
@@ -170,6 +171,7 @@ struct
       , successfulExitIn: CVar
       , successfulExitOut: CVar
       }
+  | Raise of SourcePos.span * Value
   | Unreachable
   local structure F = FSyntax
   in
@@ -258,6 +260,7 @@ struct
           containsApp thenCont orelse containsApp elseCont
       | containsApp (Handle {body, handler = (_, h), ...}) =
           containsApp body orelse containsApp h
+      | containsApp (Raise _) = false
       | containsApp Unreachable = false
 
     fun freeVarsInValue bound (v, acc) =
@@ -361,6 +364,8 @@ struct
           ) =
           freeVarsInExp (bound, body, freeVarsInExp
             (TypedSyntax.VIdSet.add (bound, e), h, acc))
+      | freeVarsInExp (bound, Raise (_, x), acc) =
+          freeVarsInValue bound (x, acc)
       | freeVarsInExp (_, Unreachable, acc) = acc
 
     fun recurseCExp f =
@@ -416,6 +421,7 @@ struct
                    , successfulExitIn = successfulExitIn
                    , successfulExitOut = successfulExitOut
                    }
+             | Raise _ => e
              | Unreachable => e)
       in
         goExp
@@ -570,6 +576,9 @@ struct
                         })))
       | F.PrimExp (F.PrimCall Primitives.Unsafe_cast, _, [arg]) =>
           transformX (ctx, env) arg (revDecs, k)
+      | F.PrimExp (F.RaiseOp span, _, [arg]) =>
+          transform (ctx, env) arg {revDecs = revDecs, resultHint = NONE}
+            (fn (revDecs, arg) => prependRevDecs (revDecs, C.Raise (span, arg)))
       | F.PrimExp (F.PrimCall Primitives.unreachable, _, _) => C.Unreachable
       | F.PrimExp (primOp, tyargs, args) =>
           foldlCont
@@ -1041,6 +1050,7 @@ struct
             , successfulExitIn = _
             , successfulExitOut = _
             } => sizeOfCExp (body, sizeOfCExp (h, threshold - 1))
+        | C.Raise _ => threshold
         | C.Unreachable => threshold
     fun substValue (subst: C.Value TypedSyntax.VIdMap.map) (x as C.Var v) =
           (case TypedSyntax.VIdMap.find (subst, v) of
@@ -1138,6 +1148,8 @@ struct
             , successfulExitIn = successfulExitIn
             , successfulExitOut = substCVar csubst successfulExitOut
             }
+      | substCExp (subst, _, C.Raise (span, x)) =
+          C.Raise (span, substValue subst x)
       | substCExp (_, _, e as C.Unreachable) = e
     val substCExp = fn (subst, csubst, e) =>
       if TypedSyntax.VIdMap.isEmpty subst andalso C.CVarMap.isEmpty csubst then
@@ -1362,6 +1374,8 @@ struct
               , successfulExitOut = substCVar csubst successfulExitOut
               }
           end
+      | alphaConvert (_, subst, _, C.Raise (span, x)) =
+          C.Raise (span, substValue subst x)
       | alphaConvert (_, _, _, e as C.Unreachable) = e
     type value_info = {exp: C.SimpleExp option, isDiscardableFunction: bool}
     fun isDiscardableDec (dec, env: value_info TypedSyntax.VIdMap.map) =
@@ -1416,6 +1430,7 @@ struct
               }
           ) =
           isDiscardableExp (env, body) andalso isDiscardableExp (env, h)
+      | isDiscardableExp (_, C.Raise _) = false
       | isDiscardableExp (_, C.Unreachable) = false
     fun prependDecs ([], cont) = cont
       | prependDecs (decs, C.Let {decs = decs', cont}) =
@@ -1530,6 +1545,7 @@ struct
             , successfulExitIn = successfulExitIn
             , successfulExitOut = successfulExitOut
             }
+      | finalizeCExp (_, e as C.Raise _) = e
       | finalizeCExp (_, e as C.Unreachable) = e
   end
 end;
@@ -1682,6 +1698,7 @@ struct
               free;
             go (table, level, body, C.CVarSet.union (acc, free))
           end
+      | go (_, _, C.Raise _, acc) = acc
       | go (_, _, C.Unreachable, acc) = acc
     fun contEscape (cont, cexp) =
       let

src/cps/dead-code.sml

@@ -88,6 +88,7 @@ local
             , acc
             ) =
             goExp (g, body, goExp (g, h, acc))
+        | goExp (_, C.Raise (_, x), acc) = addValue (x, acc)
         | goExp (_, C.Unreachable, acc) = acc
       (*: val makeGraph : CSyntax.CExp -> graph * TypedSyntax.VIdSet.set *)
       fun makeGraph program =
@@ -333,6 +334,7 @@ local
               ; add (env, e)
               ; goCExp (env, renv, cenv, crenv, h)
               )
+          | C.Raise (_, x) => useValue env x
           | C.Unreachable => ()
       end (* local *)
       fun analyze exp =
@@ -755,6 +757,7 @@ in
               , successfulExitOut =
                   CpsSimplify.substCVar csubst successfulExitOut
               }
+        | C.Raise (span, x) => C.Raise (span, CpsSimplify.substValue subst x)
         | C.Unreachable => e
       fun goCExp (ctx: CpsSimplify.Context, exp) =
         let

src/cps/decompose-recursive.sml

@@ -137,6 +137,7 @@ struct
             , successfulExitIn = successfulExitIn
             , successfulExitOut = successfulExitOut
             }
+      | C.Raise _ => exp
       | C.Unreachable => exp
   end (* local *)
 end; (* structure CpsDecomposeRecursive *)

src/cps/eta.sml

@@ -108,6 +108,7 @@ struct
           , successfulExitIn = successfulExitIn
           , successfulExitOut = goCont (env, successfulExitOut)
           }
+    | C.Raise _ => exp
     | C.Unreachable => exp
   and goFunction exp = goCExp (C.CVarMap.empty, exp)
   fun go (_: CpsSimplify.Context, exp) = goFunction exp

src/cps/inline.sml

@@ -959,6 +959,7 @@ struct
             , successfulExitIn = successfulExitIn
             , successfulExitOut = CpsSimplify.substCVar csubst successfulExitOut
             }
+      | C.Raise (span, x) => C.Raise (span, CpsSimplify.substValue subst x)
       | C.Unreachable => e
     val General_exnName =
       let

src/cps/loop.sml

@@ -113,6 +113,7 @@ local
               , successfulExitOut = _
               } =>
               (goCExp (env, renv, body); add (env, e); goCExp (env, renv, h))
+          | C.Raise _ => ()
           | C.Unreachable => ()
       end (* local *)
       fun analyze exp =
@@ -254,6 +255,7 @@ in
               , successfulExitIn = successfulExitIn
               , successfulExitOut = successfulExitOut
               }
+        | C.Raise _ => e
         | C.Unreachable => e
       fun goCExp (ctx: CpsSimplify.Context, exp) =
         let

src/cps/ref-cell.sml

@@ -199,6 +199,7 @@ local
               , successfulExitOut = _
               } =>
               (goCExp (env, renv, body); add (env, e); goCExp (env, renv, h))
+          | C.Raise (_, x) => useValue env x
           | C.Unreachable => ()
       end (* local *)
       fun analyze exp =
@@ -401,6 +402,7 @@ in
               , successfulExitIn = successfulExitIn
               , successfulExitOut = successfulExitOut
               }
+        | C.Raise _ => e
         | C.Unreachable => e
       fun goCExp (ctx: CpsSimplify.Context, exp) =
         let

src/cps/uncurry.sml

@@ -146,6 +146,7 @@ struct
             , successfulExitIn = successfulExitIn
             , successfulExitOut = successfulExitOut
             }
+      | C.Raise _ => exp
       | C.Unreachable => exp
     val goCExp = simplifyCExp
   end (* local *)

src/cps/unpack-record-parameter.sml

@@ -288,6 +288,7 @@ local
               ; add (env, e)
               ; goCExp (env, renv, cenv, crenv, h)
               )
+          | C.Raise (_, x) => useValue env x
           | C.Unreachable => ()
       end (* local *)
       fun analyze exp =
@@ -991,6 +992,7 @@ in
               , successfulExitIn = successfulExitIn
               , successfulExitOut = successfulExitOut
               }
+        | C.Raise _ => e
         | C.Unreachable => e
       fun goCExp (ctx: CpsSimplify.Context, exp) =
         let

src/nested.sml

@@ -49,6 +49,7 @@ sig
       , successfulExitIn: CVar
       , successfulExitOut: CVar
       }
+  | Raise of SourcePos.span * Exp
   | Unreachable
   val containsApp: Stat -> bool
   val fromCExp: CSyntax.CExp -> Stat
@@ -99,6 +100,7 @@ struct
       , successfulExitIn: CVar
       , successfulExitOut: CVar
       }
+  | Raise of SourcePos.span * Exp
   | Unreachable
 
   fun containsAppDec (ValDec _) = false
@@ -115,6 +117,7 @@ struct
         containsApp thenCont orelse containsApp elseCont
     | containsApp (Handle {body, handler = (_, h), ...}) =
         containsApp body orelse containsApp h
+    | containsApp (Raise _) = false
     | containsApp Unreachable = false
 
   local
@@ -179,6 +182,8 @@ struct
             , successfulExitIn = successfulExitIn
             , successfulExitOut = successfulExitOut
             }
+      | goCExp (C.Raise (span, x)) =
+          Raise (span, Value x)
       | goCExp C.Unreachable = Unreachable
   in val fromCExp = goCExp
   end (* local *)
@@ -230,6 +235,7 @@ struct
               (goExp cond; goStat thenCont; goStat elseCont)
           | goStat (Handle {body, handler = (_, h), ...}) =
               (goStat body; goStat h)
+          | goStat (Raise (_, x)) = goExp x
           | goStat Unreachable = ()
       in
         goStat
@@ -340,14 +346,14 @@ struct
                    If {cond = cond, thenCont = thenCont, elseCont = elseCont})
                 (goExp cond)
           | goStat (Handle _) = NONE
+          | goStat (Raise (span, x)) =
+              Option.map (fn x => Raise (span, x)) (goExp x)
           | goStat Unreachable = NONE
       in
         {goValue = goValue, goExp = goExp, goDecs = goDecs, goStat = goStat}
       end
-    fun canInlineLua (PrimOp {primOp = FSyntax.RaiseOp _, ...}) = false
-      | canInlineLua _ = true
-    fun canInlineJs (PrimOp {primOp = FSyntax.RaiseOp _, ...}) = false
-      | canInlineJs (ExnTag _) = false
+    fun canInlineLua _ = true
+    fun canInlineJs (ExnTag _) = false
       | canInlineJs _ = true
     val DEPTH_LIMIT = 10
     fun toNestedImpl (backend, usage) =
@@ -574,6 +580,8 @@ struct
                 , successfulExitIn = successfulExitIn
                 , successfulExitOut = successfulExitOut
                 }
+          | goStat (Raise (span, x)) =
+              Raise (span, goExp x)
           | goStat Unreachable = Unreachable
       in
         goStat