- hvals <- thing_to_run
-
- -- get the newly bound things, and bind them
- let names = map idName ids
- new_pls <- updateClosureEnv pls (zip names hvals)
-
- return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
- where
- CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
+ either_hvals <- sandboxIO thing_to_run
+ case either_hvals of
+ Left err
+ | err == dEADLOCKED
+ -> return ( cmstate{ pcs=new_pcs, ic=new_ic },
+ CmRunDeadlocked )
+ | otherwise
+ -> do hPutStrLn stderr ("unknown failure, code " ++ show err)
+ return ( cmstate{ pcs=new_pcs, ic=new_ic }, CmRunFailed )
+
+ Right maybe_hvals ->
+ case maybe_hvals of
+ Left e ->
+ return ( cmstate{ pcs=new_pcs, ic=new_ic },
+ CmRunException e )
+ Right hvals -> do
+ -- Get the newly bound things, and bind them.
+ -- Don't forget to delete any shadowed bindings from the
+ -- closure_env, lest we end up with a space leak.
+ pls <- delListFromClosureEnv pls shadowed
+ new_pls <- addListToClosureEnv pls (zip names hvals)
+
+ return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic },
+ CmRunOk names)
+
+-- We run the statement in a "sandbox", which amounts to calling into
+-- the RTS to request a new main thread. The main benefit is that we
+-- get to detect a deadlock this way, but also there's no danger that
+-- exceptions raised by the expression can affect the interpreter.
+
+sandboxIO :: IO a -> IO (Either Int (Either Exception a))
+sandboxIO thing = do
+ st_thing <- newStablePtr (Exception.try thing)
+ alloca $ \ p_st_result -> do
+ stat <- rts_evalStableIO st_thing p_st_result
+ freeStablePtr st_thing
+ if stat == 1
+ then do st_result <- peek p_st_result
+ result <- deRefStablePtr st_result
+ freeStablePtr st_result
+ return (Right result)
+ else do
+ return (Left (fromIntegral stat))
+
+-- ToDo: slurp this in from ghc/includes/RtsAPI.h somehow
+dEADLOCKED = 4 :: Int
+
+foreign import "rts_evalStableIO" {- safe -}
+ rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
+ -- more informative than the C type!