Permalink
Browse files

js backend now properly deals with exceptions

  • Loading branch information...
1 parent 6a6fa8e commit cd6113ba53cc130f048b67ba39ff7e49f10093fd @atzedijkstra atzedijkstra committed Nov 27, 2012
Showing with 41 additions and 7 deletions.
  1. +1 −1 EHC/configure
  2. +10 −1 EHC/ehclib/uhcbase/UHC/IOBase.chs
  3. +19 −5 EHC/ehclib/uhcbase/UHC/Run.chs
  4. +11 −0 EHC/src/javascript/rts/prim.cjs
View
@@ -3691,7 +3691,7 @@ HSC2HS_CMD=$hsc2hsCmd
### now we know we have ghc, check for some libraries using ghc-pkg
-ghcLibsRequired="fgl syb uulib network binary hashable"
+ghcLibsRequired="fgl syb uulib network binary hashable uuagc-cabal"
if test x$ghcExists = xyes
then
if test -x "$ghcCmd" -a -x "$ghcPkgCmd"
@@ -49,7 +49,7 @@ module UHC.IOBase
try,
-- Exception related: catch, throw
-#if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__)
+#if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) || defined (__UHC_TARGET_JS__)
#else
catchTracedException,
#endif
@@ -656,6 +656,14 @@ catchException m k = m
#else
+#if defined (__UHC_TARGET_JS__)
+foreign import prim primCatchException :: forall a . a -> (SomeException -> a) -> a
+
+catchException :: IO a -> (SomeException -> IO a) -> IO a
+catchException (IO m) k = IO $ \s ->
+ primCatchException (m s)
+ (\te -> case (k te) of {IO k' -> k' s })
+#else
foreign import prim primCatchException :: forall a . a -> ((SomeException,ImplicitStackTrace,ExplicitStackTrace) -> a) -> a
catchTracedException :: IO a -> ((SomeException,ImplicitStackTrace,ExplicitStackTrace) -> IO a) -> IO a
@@ -666,6 +674,7 @@ catchTracedException (IO m) k = IO $ \s ->
catchException :: IO a -> (SomeException -> IO a) -> IO a
catchException m k =
catchTracedException m (\(e,_,_) -> k e)
+#endif
catch :: IO a -> (IOError -> IO a) -> IO a
catch m h = catchException m $ \e -> case e of
@@ -18,13 +18,15 @@ import UHC.Handle
#endif
import UHC.StackTrace
-#if !( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JS__) )
+#if ( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JS__) || defined (__UHC_TARGET_LLVM__) )
+import UHC.OldIO (putStrLn)
+#else
import System.IO (hPutStrLn)
#endif
%%]
%%[99
-#if defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JS__) || defined (__UHC_TARGET_LLVM__)
+#if defined(__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__)
-- Wrapper around 'main', invoked as 'ehcRunMain main'
ehcRunMain :: IO a -> IO a
@@ -37,15 +39,24 @@ foreign import prim primCallInfoKindIsVisible :: Int -> Bool
-- Wrapper around 'main', invoked as 'ehcRunMain main'
ehcRunMain :: IO a -> IO a
ehcRunMain m =
- catchTracedException (wrapCleanUp m)
- (\(exc,implTrace,explTrace) -> cleanUp >>
+# if defined(__UHC_TARGET_JS__)
+ catchException m
+ (\exc ->
+# else
+ catchTracedException (wrapCleanUp m)
+ (\(exc,implTrace,explTrace) -> cleanUp >>
+# endif
case exc of
ExitException ExitSuccess
-> exitWithIntCode 0
ExitException (ExitFailure code)
| code == 0 -> exitWithIntCode 1
| otherwise -> exitWithIntCode code
- _ -> do { hPutStrLn stderr ("Error: " ++ show exc)
+ _ -> do {
+# if defined(__UHC_TARGET_JS__)
+ putStrLn ("Error: " ++ show exc)
+# else
+ hPutStrLn stderr ("Error: " ++ show exc)
; if null explTrace
then if null implTrace
then return ()
@@ -55,11 +66,13 @@ ehcRunMain m =
else do { hPutStrLn stderr "Explicit stack trace:"
; mapM_ (\s -> hPutStrLn stderr s) explTrace
}
+# endif
; exitWithIntCode 1
}
)
+#if ! defined(__UHC_TARGET_JS__)
-- try to flush stdout/stderr, but don't worry if we fail
-- (these handles might have errors, and we don't want to go into
-- an infinite loop).
@@ -72,6 +85,7 @@ wrapCleanUp :: IO a -> IO a
wrapCleanUp m = do x <- m
cleanUp
return x
+#endif
#endif
%%]
@@ -342,8 +342,19 @@ primByteArrayToPackedString = primUnsafeId ;
%%]
%%[8
+// primThrowException :: forall a x . SomeException' x -> a
primThrowException = function(x) { throw x ; }
+
primExitWith = function(x) { throw "EXIT:" + x ; }
+
+// primCatchException :: forall a . a -> (SomeException -> a) -> a
+primCatchException = function(x,hdlr) {
+ try {
+ return _e_(x);
+ } catch (err) {
+ return _e_(new _A_(hdlr,[err]));
+ }
+}
%%]
%%[8

0 comments on commit cd6113b

Please sign in to comment.