Basic exception handling support (#128)

.circleci/config.yml

@@ -61,6 +61,7 @@ jobs:
             stack --no-terminal test asterius:bigint
             stack --no-terminal test asterius:todomvc
             stack --no-terminal test asterius:cloudflare
+            stack --no-terminal test asterius:exception
             stack --no-terminal test asterius:fib --test-arguments="--no-gc-sections"
             stack --no-terminal test asterius:fib --test-arguments="--binaryen --no-gc-sections"
             stack --no-terminal test asterius:fib --test-arguments="--sync"
@@ -76,6 +77,7 @@ jobs:
             stack --no-terminal test asterius:teletype --test-arguments="--debug" > /dev/null
             # stack --no-terminal test asterius:bytearray --test-arguments="--debug" > /dev/null
             stack --no-terminal test asterius:bigint --test-arguments="--debug" > /dev/null
+            stack --no-terminal test asterius:exception --test-arguments="--debug" > /dev/null
 
             stack --no-terminal test asterius:fib --test-arguments="--tail-calls"
             stack --no-terminal test asterius:fib --test-arguments="--tail-calls --no-gc-sections"

asterius/package.yaml

@@ -27,6 +27,7 @@ extra-source-files:
   - test/cloudflare/**/*.hs
   - test/cloudflare/cloudflare.mjs
   - test/nomain/**/*.hs
+  - test/exception/**/*.hs
 
 data-files:
   - rts/*.mjs
@@ -221,3 +222,10 @@ tests:
     ghc-options: -threaded -rtsopts
     dependencies:
       - asterius
+
+  exception:
+    source-dirs: test
+    main: exception.hs
+    ghc-options: -threaded -rtsopts
+    dependencies:
+      - asterius

asterius/rts/rts.exception.mjs

@@ -0,0 +1,84 @@
+import * as ClosureTypes from "./rts.closuretypes.mjs";
+import * as rtsConstants from "./rts.constants.mjs";
+
+export class RaiseExceptionHelper {
+  constructor(memory, heapalloc, info_tables, symbol_table) {
+    this.memory = memory;
+    this.heapAlloc = heapalloc;
+    this.infoTables = info_tables;
+    this.symbolTable = symbol_table;
+    Object.freeze(this);
+  }
+  raiseExceptionHelper(reg, tso, exception) {
+    const raise_closure = this.heapAlloc.allocate(
+      Math.ceil(rtsConstants.sizeof_StgThunk / 8) + 1
+    );
+    this.memory.i64Store(raise_closure, this.symbolTable.stg_raise_info);
+    this.memory.i64Store(
+      raise_closure + rtsConstants.offset_StgThunk_payload,
+      exception
+    );
+    const stackobj = Number(
+      this.memory.i64Load(tso + rtsConstants.offset_StgTSO_stackobj)
+    );
+    let p = this.memory.i64Load(stackobj + rtsConstants.offset_StgStack_sp);
+    while (true) {
+      const info = Number(this.memory.i64Load(p)),
+        type = this.memory.i32Load(
+          info + rtsConstants.offset_StgInfoTable_type
+        ),
+        raw_layout = this.memory.i64Load(
+          info + rtsConstants.offset_StgInfoTable_layout
+        );
+      if (!this.infoTables.has(info))
+        throw new WebAssembly.RuntimeError(
+          "raiseExceptionHelper: invalid info pointer"
+        );
+      switch (type) {
+        case ClosureTypes.UPDATE_FRAME: {
+          const p1 = this.memory.i64Load(
+            p + rtsConstants.offset_StgUpdateFrame_updatee
+          );
+          this.memory.i64Store(p1, this.symbolTable.stg_BLACKHOLE_info);
+          this.memory.i64Store(
+            p1 + rtsConstants.offset_StgInd_indirectee,
+            raise_closure
+          );
+          const size = Number(raw_layout & BigInt(0x3f));
+          p += (1 + size) << 3;
+          break;
+        }
+        case ClosureTypes.CATCH_FRAME:
+        case ClosureTypes.STOP_FRAME: {
+          this.memory.i64Store(stackobj + rtsConstants.offset_StgStack_sp, p);
+          return type;
+        }
+        case ClosureTypes.RET_SMALL: {
+          const size = Number(raw_layout & BigInt(0x3f));
+          p += (1 + size) << 3;
+          break;
+        }
+        case ClosureTypes.RET_BIG: {
+          const size = Number(
+            this.memory.i64Load(
+              Number(raw_layout) + rtsConstants.offset_StgLargeBitmap_size
+            )
+          );
+          p += (1 + size) << 3;
+          break;
+        }
+        case ClosureTypes.RET_FUN: {
+          const size = Number(
+            this.memory.i64Load(c + rtsConstants.offset_StgRetFun_size)
+          );
+          p += rtsConstants.sizeof_StgRetFun + (size << 3);
+          break;
+        }
+        default:
+          throw new WebAssembly.RuntimeError(
+            "raiseExceptionHelper: unsupported stack frame"
+          );
+      }
+    }
+  }
+}

asterius/rts/rts.mjs

@@ -16,6 +16,7 @@ import { IntegerManager } from "./rts.integer.mjs";
 import { MemoryFileSystem } from "./rts.fs.mjs";
 import { ByteStringCBits } from "./rts.bytestring.mjs";
 import { GC } from "./rts.gc.mjs";
+import { RaiseExceptionHelper } from "./rts.exception.mjs";
 import * as rtsConstants from "./rts.constants.mjs";
 
 export function newAsteriusInstance(req) {
@@ -35,7 +36,8 @@ export function newAsteriusInstance(req) {
     __asterius_fs = new MemoryFileSystem(__asterius_logger),
     __asterius_vault = req.vault ? req.vault : new Map(),
     __asterius_bytestring_cbits = new ByteStringCBits(null),
-    __asterius_gc = new GC(__asterius_memory, __asterius_mblockalloc, __asterius_heapalloc, __asterius_stableptr_manager, __asterius_tso_manager, req.infoTables, req.pinnedStaticClosures, req.symbolTable);
+    __asterius_gc = new GC(__asterius_memory, __asterius_mblockalloc, __asterius_heapalloc, __asterius_stableptr_manager, __asterius_tso_manager, req.infoTables, req.pinnedStaticClosures, req.symbolTable),
+    __asterius_raise_exception_helper = new RaiseExceptionHelper(__asterius_memory, __asterius_heapalloc, req.infoTables, req.symbolTable);
   function __asterius_show_I64(x) {
     return "0x" + x.toString(16).padStart(8, "0");
   }
@@ -124,6 +126,7 @@ export function newAsteriusInstance(req) {
       },
       bytestring: modulify(__asterius_bytestring_cbits),
       GC: modulify(__asterius_gc),
+      RaiseExceptionHelper: modulify(__asterius_raise_exception_helper),
       HeapAlloc: modulify(__asterius_heapalloc),
       HeapBuilder: modulify(__asterius_heap_builder),
       MBlockAlloc: modulify(__asterius_mblockalloc),

asterius/src/Asterius/Builtins.hs

@@ -28,6 +28,7 @@ import Data.Functor
 import Data.List
 import qualified Data.Map.Strict as Map
 import Data.Maybe
+import Data.Word
 import qualified GhcPlugins as GHC
 import Language.Haskell.GHC.Toolkit.Constants
 import Prelude hiding (IO)
@@ -65,6 +66,11 @@ rtsAsteriusModule opts =
                       replicate (8 * roundup_bytes_to_words sizeof_Capability) 0
                     ]
                 })
+          , ( "rts_stop_on_exception"
+            , AsteriusStatics
+                { staticsType = Bytes
+                , asteriusStatics = [Serialized $ encodeStorable (0 :: Word64)]
+                })
           , ( "__asterius_pc"
             , AsteriusStatics
                 { staticsType = Bytes
@@ -106,6 +112,7 @@ rtsAsteriusModule opts =
        <> fromJSArrayFunction opts
        <> threadPausedFunction opts
        <> dirtyMutVarFunction opts
+       <> raiseExceptionHelperFunction opts
        <> (if debug opts then generateRtsAsteriusDebugModule opts else mempty)
        -- | Add in the module that contain functions which need to be
        -- | exposed to the outside world. So add in the module, and
@@ -351,6 +358,13 @@ rtsFunctionImports debug =
       , externalBaseName = "gcRootTSO"
       , functionType = FunctionType {paramTypes = [F64], returnTypes = []}
       }
+  , FunctionImport
+      { internalName = "__asterius_raiseExceptionHelper"
+      , externalModuleName = "RaiseExceptionHelper"
+      , externalBaseName = "raiseExceptionHelper"
+      , functionType =
+          FunctionType {paramTypes = [F64, F64, F64], returnTypes = [F64]}
+      }
   ] <>
   (if debug
      then [ FunctionImport
@@ -588,8 +602,9 @@ generateWrapperModule mod = mod {
 
 
 
-mainFunction, hsInitFunction, rtsApplyFunction, rtsEvalFunction, rtsEvalIOFunction, rtsEvalLazyIOFunction, rtsGetSchedStatusFunction, rtsCheckSchedStatusFunction, scheduleWaitThreadFunction, createThreadFunction, createGenThreadFunction, createIOThreadFunction, createStrictIOThreadFunction, allocatePinnedFunction, newCAFFunction, stgReturnFunction, getStablePtrWrapperFunction, deRefStablePtrWrapperFunction, freeStablePtrWrapperFunction, rtsMkBoolFunction, rtsMkDoubleFunction, rtsMkCharFunction, rtsMkIntFunction, rtsMkWordFunction, rtsMkPtrFunction, rtsMkStablePtrFunction, rtsGetBoolFunction, rtsGetDoubleFunction, loadI64Function, printI64Function, assertEqI64Function, printF32Function, printF64Function, strlenFunction, memchrFunction, memcpyFunction, memsetFunction, memcmpFunction, fromJSArrayBufferFunction, toJSArrayBufferFunction, fromJSStringFunction, fromJSArrayFunction, threadPausedFunction, dirtyMutVarFunction :: BuiltinsOptions -> AsteriusModule
 
+mainFunction, hsInitFunction, rtsApplyFunction, rtsEvalFunction, rtsEvalIOFunction, rtsEvalLazyIOFunction, rtsGetSchedStatusFunction, rtsCheckSchedStatusFunction, scheduleWaitThreadFunction, createThreadFunction, createGenThreadFunction, createIOThreadFunction, createStrictIOThreadFunction, allocatePinnedFunction, newCAFFunction, stgReturnFunction, getStablePtrWrapperFunction, deRefStablePtrWrapperFunction, freeStablePtrWrapperFunction, rtsMkBoolFunction, rtsMkDoubleFunction, rtsMkCharFunction, rtsMkIntFunction, rtsMkWordFunction, rtsMkPtrFunction, rtsMkStablePtrFunction, rtsGetBoolFunction, rtsGetDoubleFunction, loadI64Function, printI64Function, assertEqI64Function, printF32Function, printF64Function, strlenFunction, memchrFunction, memcpyFunction, memsetFunction, memcmpFunction, fromJSArrayBufferFunction, toJSArrayBufferFunction, fromJSStringFunction, fromJSArrayFunction, threadPausedFunction, dirtyMutVarFunction, raiseExceptionHelperFunction ::
+     BuiltinsOptions -> AsteriusModule
 mainFunction BuiltinsOptions {} =
   runEDSL  "main" $ do
     tid <- call' "rts_evalLazyIO" [symbol "Main_main_closure"] I32
@@ -786,6 +801,8 @@ createThreadFunction _ =
     storeI64 tso_p 0 $ symbol "stg_TSO_info"
     storeI16 tso_p offset_StgTSO_what_next $ constI32 next_ThreadRunGHC
     storeI16 tso_p offset_StgTSO_why_blocked $ constI32 blocked_NotBlocked
+    storeI64 tso_p offset_StgTSO_blocked_exceptions $
+      symbol "stg_END_TSO_QUEUE_closure"
     storeI32 tso_p offset_StgTSO_flags $ constI32 0
     storeI32 tso_p offset_StgTSO_dirty $ constI32 1
     storeI32 tso_p offset_StgTSO_saved_errno $ constI32 0
@@ -1135,6 +1152,18 @@ dirtyMutVarFunction _ =
       (storeI64 p 0 $ symbol "stg_MUT_VAR_DIRTY_info")
       mempty
 
+raiseExceptionHelperFunction _ =
+  runEDSL "raiseExceptionHelper" $ do
+    setReturnTypes [I64]
+    args <- params [I64, I64, I64]
+    frame_type <-
+      truncUFloat64ToInt64 <$>
+      callImport'
+        "__asterius_raiseExceptionHelper"
+        (map convertUInt64ToFloat64 args)
+        F64
+    emit frame_type
+
 getF64GlobalRegFunction ::
   BuiltinsOptions
   -> AsteriusEntitySymbol  -- ^ Name of the function to be created

asterius/src/Asterius/JSGen/Constants.hs

@@ -99,6 +99,7 @@ rtsConstants =
       , ("offset_StgStack_stack_size", offset_StgStack_stack_size)
       , ("offset_StgStack_sp", offset_StgStack_sp)
       , ("offset_StgStack_stack", offset_StgStack_stack)
+      , ("offset_StgUpdateFrame_updatee", offset_StgUpdateFrame_updatee)
       , ("offset_StgWeak_cfinalizers", offset_StgWeak_cfinalizers)
       , ("offset_StgWeak_key", offset_StgWeak_key)
       , ("offset_StgWeak_value", offset_StgWeak_value)

asterius/src/Asterius/Ld.hs

@@ -51,8 +51,10 @@ rtsUsedSymbols =
     , "ghczmprim_GHCziTypes_ZMZN_closure"
     , "integerzmwiredzmin_GHCziIntegerziType_Integer_con_info"
     , "stg_ARR_WORDS_info"
+    , "stg_BLACKHOLE_info"
     , "stg_DEAD_WEAK_info"
     , "stg_NO_FINALIZER_closure"
+    , "stg_raise_info"
     , "stg_WEAK_info"
     ]
 

asterius/src/Asterius/Main.hs

@@ -104,7 +104,13 @@ parseTask args =
         , bool_opt "sync" $ \t -> t {sync = True}
         , bool_opt "binaryen" $ \t -> t {binaryen = True}
         , bool_opt "debug" $ \t ->
-            t {debug = True, outputLinkReport = True, outputIR = True}
+            t
+              { fullSymTable = True
+              , binaryen = True
+              , debug = True
+              , outputLinkReport = True
+              , outputIR = True
+              }
         , bool_opt "output-link-report" $ \t -> t {outputLinkReport = True}
         , bool_opt "output-ir" $ \t -> t {outputIR = True}
         , bool_opt "run" $ \t -> t {run = True}
@@ -217,11 +223,11 @@ genLib Task {..} LinkReport {..} err_msgs =
   ]
   where
     raw_symbol_table = staticsSymbolMap <> functionSymbolMap
-    symbol_table =
-      if fullSymTable || debug
-        then raw_symbol_table
-        else M.restrictKeys raw_symbol_table $
-             S.fromList extraRootSymbols <> rtsUsedSymbols
+    symbol_table
+      | fullSymTable = raw_symbol_table
+      | otherwise =
+        M.restrictKeys raw_symbol_table $
+        S.fromList extraRootSymbols <> rtsUsedSymbols
 
 genDefEntry :: Task -> Builder
 genDefEntry Task {..} =

asterius/test/exception.hs

@@ -0,0 +1,8 @@
+import System.Environment
+import System.Process
+
+main :: IO ()
+main = do
+  args <- getArgs
+  callProcess "ahc-link" $
+    ["--input-hs", "test/exception/exception.hs", "--run"] <> args

asterius/test/exception/exception.hs

@@ -0,0 +1,7 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import Control.Exception
+import System.IO.Error
+
+main :: IO ()
+main = catch (throwIO (userError "BOOM")) (\(e :: SomeException) -> print e)

ghc-toolkit/cbits/ghc_constants.c

@@ -387,6 +387,10 @@ HsInt offset_StgTSO_tot_stack_size() {
   return offsetof(StgTSO, tot_stack_size);
 }
 
+HsInt offset_StgUpdateFrame_updatee() {
+  return offsetof(StgUpdateFrame, updatee);
+}
+
 HsInt sizeof_StgWeak() { return sizeof(StgWeak); }
 
 HsInt offset_StgWeak_cfinalizers() { return offsetof(StgWeak, cfinalizers); }

ghc-toolkit/src/Language/Haskell/GHC/Toolkit/Constants.hs

@@ -424,6 +424,9 @@ foreign import ccall unsafe "offset_StgTSO_alloc_limit" offset_StgTSO_alloc_limi
 foreign import ccall unsafe "offset_StgTSO_tot_stack_size" offset_StgTSO_tot_stack_size
   :: Int
 
+foreign import ccall unsafe "offset_StgUpdateFrame_updatee" offset_StgUpdateFrame_updatee
+  :: Int
+
 foreign import ccall unsafe "sizeof_StgWeak" sizeof_StgWeak :: Int
 
 foreign import ccall unsafe "offset_StgWeak_cfinalizers" offset_StgWeak_cfinalizers