type HintedCmmFormal = CmmHinted CmmFormal
type HintedCmmActual = CmmHinted CmmActual
-data CmmSafety = CmmUnsafe | CmmSafe C_SRT
+data CmmSafety = CmmUnsafe | CmmSafe C_SRT | CmmInterruptible
-- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals'
instance UserOfLocalRegs CmmStmt where
l = case last of LastOther l -> l
LastExit -> panic "extendEnvs lastExit"
tail _ z (ZFirst _) = z
- tail fact env (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) =
+ tail fact env (ZHead h m@(MidForeignCall (Safe bid _ _) _ _ _)) =
tail (mid m fact) (extendBlockEnv env bid fact) h
tail fact env (ZHead h m) = tail (mid m fact) env h
lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k
LastExit -> panic "extendEnvs lastExit"
tail _ z (ZFirst _) = z
tail lives@(cafs, slots) (cafEnv, slotEnv)
- (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) =
+ (ZHead h m@(MidForeignCall (Safe bid _ _) _ _ _)) =
let slots' = removeLiveSlotDefs slots m
slotEnv' = extendBlockEnv slotEnv bid slots'
cafEnv' = extendBlockEnv cafEnv bid cafs
-- Check for foreign calls -- if none, then we can avoid copying the block.
hasSafeForeignCall :: CmmBlock -> Bool
hasSafeForeignCall (Block _ t) = tail t
- where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True
+ where tail (ZTail (MidForeignCall (Safe _ _ _) _ _ _) _) = True
tail (ZTail _ t) = tail t
tail (ZLast _) = False
tail s b@(ZBlock (ZFirst _) _) =
do state <- s
return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
- tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) =
+ tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off _) _ _ _)) t) =
do state <- s
let state' = state
{ s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :
-- to lower a safe foreign call to a sequence of unsafe calls.
lowerSafeForeignCall ::
SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last)
-lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do
+lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _ interruptible) _ _ _) tail = do
let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
saveThreadState <*>
caller_save <*>
mkUnsafeCall (ForeignTarget suspendThread
- (ForeignConvention CCallConv [AddrHint] [AddrHint]))
- [id] [CmmReg (CmmGlobal BaseReg)]
+ (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
+ -- XXX Not sure if the size of the CmmInt is correct
+ [id] [CmmReg (CmmGlobal BaseReg), CmmLit (CmmInt (fromIntegral (fromEnum interruptible)) wordWidth)]
resume = mkUnsafeCall (ForeignTarget resumeThread
(ForeignConvention CCallConv [AddrHint] [AddrHint]))
[new_base] [CmmReg (CmmLocal id)] <*>
caller_save ++
[CmmCall (CmmCallee suspendThread CCallConv)
[ CmmHinted id AddrHint ]
- [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ]
+ [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
+ -- XXX: allow for interruptible suspension
+ , CmmHinted (CmmLit (CmmInt 0 wordWidth)) NoHint ]
CmmUnsafe
CmmMayReturn,
CmmCall call results new_args CmmUnsafe CmmMayReturn,
--
-----------------------------------------------------------------------------
+-- TODO: Add support for interruptible/uninterruptible foreign call specification
+
{
{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-}
-- The NoMonomorphismRestriction deals with a Happy infelicity
parseSafety :: String -> P CmmSafety
parseSafety "safe" = return (CmmSafe NoC_SRT)
parseSafety "unsafe" = return CmmUnsafe
+parseSafety "interruptible" = return CmmInterruptible
parseSafety str = fail ("unrecognised safety: " ++ str)
parseCmmHint :: String -> P ForeignHint
code (emitForeignCall' (PlaySafe unused) results
(CmmCallee expr' convention) args vols NoC_SRT ret) where
unused = panic "not used by emitForeignCall'"
+ CmmInterruptible ->
+ code (emitForeignCall' PlayInterruptible results
+ (CmmCallee expr' convention) args vols NoC_SRT ret)
adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
#ifdef mingw32_TARGET_OS
code (emitForeignCall' (PlaySafe unused) results
(CmmPrim p) args vols NoC_SRT CmmMayReturn) where
unused = panic "not used by emitForeignCall'"
+ CmmInterruptible ->
+ code (emitForeignCall' PlayInterruptible results
+ (CmmPrim p) args vols NoC_SRT CmmMayReturn)
doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode
doStore rep addr_code val_code
fold_succs (setSuccSPs inSp) l areaMap
where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young id)) areaMap
- allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap =
+ allocMidCall m@(MidForeignCall (Safe bid _ _) _ _ _) t areaMap =
let young = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
area = CallArea (Young bid)
areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize
where spIn = sp_on_entry id
replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) ->
FuelMonad ([CmmBlock])
- replTail h spOff (ZTail m@(MidForeignCall (Safe bid _) _ _ _) t) =
+ replTail h spOff (ZTail m@(MidForeignCall (Safe bid _ _) _ _ _) t) =
replTail (\t' -> h (setSp spOff spOff' (ZTail (middle spOff m) t'))) spOff' t
where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord)
replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t
mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals ->
UpdFrameOffset -> CmmAGraph
-- Native C-- calling convention
-mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph
mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
-- Never returns; like exit() or barf()
mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
mkSwitch e tbl = mkLast $ LastSwitch e tbl
-mkSafeCall t fs as upd =
+mkSafeCall t fs as upd interruptible =
withFreshLabel "safe call" $ \k ->
- mkMiddle $ MidForeignCall (Safe k upd) t fs as
+ mkMiddle $ MidForeignCall (Safe k upd interruptible) t fs as
mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
-- For debugging purposes, we can stub out dead stack slots:
instance Outputable CmmSafety where
ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
ppr (CmmSafe srt) = ppr srt
+ ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
-- --------------------------------------------------------------------------
-- Info tables. The current pretty printer needs refinement
= Unsafe -- unsafe call
| Safe BlockId -- making infotable requires: 1. label
UpdFrameOffset -- 2. where the upd frame is
+ Bool -- is the call interruptible?
deriving Eq
data ValueDirection = Arguments | Results
doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
ppr_safety :: ForeignSafety -> SDoc
-ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
+ppr_safety (Safe bid upd interruptible) =
+ text (if interruptible then "interruptible" else "safe") <>
+ text "<" <> ppr bid <> text ", " <> ppr upd <> text ">"
ppr_safety Unsafe = text "unsafe"
ppr_call_target :: MidCallTarget -> SDoc
-- to this sequence of three CmmUnsafe calls.
stmtC (CmmCall (CmmCallee suspendThread CCallConv)
[ CmmHinted id AddrHint ]
- [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ]
+ [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
+ , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint]
CmmUnsafe ret)
stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
stmtC (CmmCall (CmmCallee resumeThread CCallConv)
| otherwise = do
updfr_off <- getUpdFrameOff
temp_target <- load_target_into_temp target
- emit $ mkSafeCall temp_target results args updfr_off
+ emit $ mkSafeCall temp_target results args updfr_off (playInterruptible safety)
{-
repSafety :: Safety -> DsM (Core TH.Safety)
repSafety PlayRisky = rep2 unsafeName []
+repSafety PlayInterruptible = rep2 interruptibleName []
repSafety (PlaySafe False) = rep2 safeName []
repSafety (PlaySafe True) = rep2 threadsafeName []
unsafeName,
safeName,
threadsafeName,
+ interruptibleName,
-- InlineSpec
inlineSpecNoPhaseName, inlineSpecPhaseName,
-- FunDep
stdCallName = libFun (fsLit "stdCall") stdCallIdKey
-- data Safety = ...
-unsafeName, safeName, threadsafeName :: Name
+unsafeName, safeName, threadsafeName, interruptibleName :: Name
unsafeName = libFun (fsLit "unsafe") unsafeIdKey
safeName = libFun (fsLit "safe") safeIdKey
threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
+interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
-- data InlineSpec = ...
inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
stdCallIdKey = mkPreludeMiscIdUnique 301
-- data Safety = ...
-unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
+unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique
unsafeIdKey = mkPreludeMiscIdUnique 305
safeIdKey = mkPreludeMiscIdUnique 306
threadsafeIdKey = mkPreludeMiscIdUnique 307
+interruptibleIdKey = mkPreludeMiscIdUnique 308
-- data InlineSpec =
inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
ENTER -> instr1 st bci_ENTER
RETURN -> instr1 st bci_RETURN
RETURN_UBX rep -> instr1 st (return_ubx rep)
- CCALL off m_addr -> do (np, st2) <- addr st m_addr
- instr3 st2 bci_CCALL off np
+ CCALL off m_addr int -> do (np, st2) <- addr st m_addr
+ instr4 st2 bci_CCALL off np int
BRK_FUN array index info -> do
(p1, st2) <- ptr st (BCOPtrArray array)
(p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
ENTER{} -> 1
RETURN{} -> 1
RETURN_UBX{} -> 1
- CCALL{} -> 3
+ CCALL{} -> 4
SWIZZLE{} -> 3
BRK_FUN{} -> 4
-> [AnnExpr' Id VarSet] -- args (atoms)
-> BcM BCInstrList
-generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
+generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
= let
-- useful constants
addr_sizeW :: Word16
recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
let
-- do the call
- do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller))
+ do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)
+ (fromIntegral (fromEnum (playInterruptible safety))))
-- slide and return
wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
`snocOL` RETURN_UBX (primRepToCgRep r_rep)
-- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi)
| CCALL Word16 -- stack frame size
(Ptr ()) -- addr of the glue code
+ Word16 -- whether or not the call is interruptible
+ -- (XXX: inefficient, but I don't know
+ -- what the alignment constraints are.)
-- For doing magic ByteArray passing to foreign calls
| SWIZZLE Word16 -- to the ptr N words down the stack,
ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
ppr CASEFAIL = text "CASEFAIL"
ppr (JMP lab) = text "JMP" <+> ppr lab
- ppr (CCALL off marshall_addr) = text "CCALL " <+> ppr off
+ ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off
<+> text "marshall code at"
<+> text (show marshall_addr)
+ <+> (if int == 1
+ then text "(interruptible)"
+ else empty)
ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
<+> text "by" <+> ppr n
ppr ENTER = text "ENTER"
Unsafe -> PlayRisky
Safe -> PlaySafe False
Threadsafe -> PlaySafe True
+ Interruptible -> PlayInterruptible
cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameL nm
-- * `Safety' is irrelevant for `CLabel' and `CWrapper'
--
CImport CCallConv -- ccall or stdcall
- Safety -- safe or unsafe
+ Safety -- interruptible, safe or unsafe
FastString -- name of C header
CImportSpec -- details of the C entity
deriving (Data, Typeable)
| ITdynamic
| ITsafe
| ITthreadsafe
+ | ITinterruptible
| ITunsafe
| ITstdcallconv
| ITccallconv
isSpecial ITdynamic = True
isSpecial ITsafe = True
isSpecial ITthreadsafe = True
+isSpecial ITinterruptible = True
isSpecial ITunsafe = True
isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
( "dynamic", ITdynamic, bit ffiBit),
( "safe", ITsafe, bit ffiBit),
( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove
+ ( "interruptible", ITinterruptible, bit ffiBit),
( "unsafe", ITunsafe, bit ffiBit),
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
'dynamic' { L _ ITdynamic }
'safe' { L _ ITsafe }
'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias
+ 'interruptible' { L _ ITinterruptible }
'unsafe' { L _ ITunsafe }
'mdo' { L _ ITmdo }
'family' { L _ ITfamily }
safety :: { Safety }
: 'unsafe' { PlayRisky }
| 'safe' { PlaySafe False }
+ | 'interruptible' { PlayInterruptible }
| 'threadsafe' { PlaySafe True } -- deprecated alias
fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
| special_id { L1 $! mkUnqual tvName (unLoc $1) }
| 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") }
| 'safe' { L1 $! mkUnqual tvName (fsLit "safe") }
+ | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") }
| 'threadsafe' { L1 $! mkUnqual tvName (fsLit "threadsafe") }
tyvarsym :: { Located RdrName }
| special_id { L1 $! mkUnqual varName (unLoc $1) }
| 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") }
| 'safe' { L1 $! mkUnqual varName (fsLit "safe") }
+ | 'interruptible' { L1 $! mkUnqual varName (fsLit "interruptible") }
| 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") }
| 'forall' { L1 $! mkUnqual varName (fsLit "forall") }
| 'family' { L1 $! mkUnqual varName (fsLit "family") }
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
--- except 'unsafe', 'forall', and 'family' whose treatment differs
+-- except 'unsafe', 'interruptible', 'forall', and 'family' whose treatment differs
-- depending on context
special_id :: { Located FastString }
special_id
module ForeignCall (
ForeignCall(..),
- Safety(..), playSafe,
+ Safety(..), playSafe, playInterruptible,
CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
CCallSpec(..),
-- which is now an alias for "safe". This information
-- is never used except to emit a deprecation warning.
+ | PlayInterruptible -- Like PlaySafe, but additionally
+ -- the worker thread running this foreign call may
+ -- be unceremoniously killed, so it must be scheduled
+ -- on an unbound thread.
+
| PlayRisky -- None of the above can happen; the call will return
-- without interacting with the runtime system at all
deriving ( Eq, Show, Data, Typeable )
instance Outputable Safety where
ppr (PlaySafe False) = ptext (sLit "safe")
ppr (PlaySafe True) = ptext (sLit "threadsafe")
+ ppr PlayInterruptible = ptext (sLit "interruptible")
ppr PlayRisky = ptext (sLit "unsafe")
playSafe :: Safety -> Bool
playSafe PlaySafe{} = True
+playSafe PlayInterruptible = True
playSafe PlayRisky = False
+
+playInterruptible :: Safety -> Bool
+playInterruptible PlayInterruptible = True
+playInterruptible _ = False
\end{code}
put_ bh (PlaySafe aa) = do
putByte bh 0
put_ bh aa
- put_ bh PlayRisky = do
+ put_ bh PlayInterruptible = do
putByte bh 1
+ put_ bh PlayRisky = do
+ putByte bh 2
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
return (PlaySafe aa)
+ 1 -> do return PlayInterruptible
_ -> do return PlayRisky
instance Binary CExportSpec where
threads, but there may be an arbitrary number of foreign
calls in progress at any one time, regardless of
the <literal>+RTS -N</literal> value.</para>
+
+ <para>If a call is annotated as <literal>interruptible</literal>
+ and the program was multithreaded, the call may be
+ interrupted in the event that the Haskell thread receives an
+ exception. The mechanism by which the interrupt occurs
+ is platform dependent, but is intended to cause blocking
+ system calls to return immediately with an interrupted error
+ code. The underlying operating system thread is not to be
+ destroyed.</para>
</sect3>
<sect3 id="haskell-threads-and-os-threads">
#define BlockedOnGA_NoSend 9
/* Only relevant for THREADED_RTS: */
#define BlockedOnCCall 10
-#define BlockedOnCCall_NoUnblockExc 11
- /* same as above but don't unblock async exceptions in resumeThread() */
+#define BlockedOnCCall_Interruptible 11
+ /* same as above but permit killing the worker thread */
/* Involved in a message sent to tso->msg_cap */
#define BlockedOnMsgThrowTo 12
extern int createOSThread ( OSThreadId* tid,
OSThreadProc *startProc, void *param);
extern rtsBool osThreadIsAlive ( OSThreadId id );
+extern void interruptOSThread (OSThreadId id);
//
// Condition Variables
StgClosure *closure);
// Suspending/resuming threads around foreign calls
-void * suspendThread (StgRegTable *);
+void * suspendThread (StgRegTable *, rtsBool interruptible);
StgRegTable * resumeThread (void *);
//
void *tok;
int stk_offset = BCO_NEXT;
int o_itbl = BCO_NEXT;
+ int interruptible = BCO_NEXT;
void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
int ret_dyn_size =
RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
SAVE_STACK_POINTERS;
- tok = suspendThread(&cap->r);
+ tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse);
// We already made a copy of the arguments above.
ffi_call(cif, fn, ret, argptrs);
Capability, and it is
- NotBlocked, BlockedOnMsgThrowTo,
- BlockedOnCCall
+ BlockedOnCCall_Interruptible
- or it is masking exceptions (TSO_BLOCKEX)
return THROWTO_SUCCESS;
}
+ case BlockedOnCCall_Interruptible:
+#ifdef THREADED_RTS
+ {
+ Task *task = NULL;
+ // walk suspended_ccalls to find the correct worker thread
+ InCall *incall;
+ for (incall = cap->suspended_ccalls; incall != NULL; incall = incall->next) {
+ if (incall->suspended_tso == target) {
+ task = incall->task;
+ break;
+ }
+ }
+ if (task != NULL) {
+ raiseAsync(cap, target, msg->exception, rtsFalse, NULL);
+ interruptWorkerTask(task);
+ return THROWTO_SUCCESS;
+ } else {
+ debugTraceCap(DEBUG_sched, cap, "throwTo: could not find worker thread to kill");
+ }
+ // fall to next
+ }
+#endif
case BlockedOnCCall:
- case BlockedOnCCall_NoUnblockExc:
blockedThrowTo(cap,target,msg);
return THROWTO_BLOCKED;
* the whole system.
*
* The Haskell thread making the C call is put to sleep for the
- * duration of the call, on the susepended_ccalling_threads queue. We
+ * duration of the call, on the suspended_ccalling_threads queue. We
* give out a token to the task, which it can use to resume the thread
* on return from the C function.
+ *
+ * If this is an interruptible C call, this means that the FFI call may be
+ * unceremoniously terminated and should be scheduled on an
+ * unbound worker thread.
* ------------------------------------------------------------------------- */
void *
-suspendThread (StgRegTable *reg)
+suspendThread (StgRegTable *reg, rtsBool interruptible)
{
Capability *cap;
int saved_errno;
threadPaused(cap,tso);
- if ((tso->flags & TSO_BLOCKEX) == 0) {
- tso->why_blocked = BlockedOnCCall;
- tso->flags |= TSO_BLOCKEX;
- tso->flags &= ~TSO_INTERRUPTIBLE;
+ if (interruptible) {
+ tso->why_blocked = BlockedOnCCall_Interruptible;
} else {
- tso->why_blocked = BlockedOnCCall_NoUnblockExc;
+ tso->why_blocked = BlockedOnCCall;
}
// Hand back capability
traceEventRunThread(cap, tso);
- if (tso->why_blocked == BlockedOnCCall) {
+ if ((tso->flags & TSO_BLOCKEX) == 0) {
// avoid locking the TSO if we don't have to
if (tso->blocked_exceptions != END_BLOCKED_EXCEPTIONS_QUEUE) {
awakenBlockedExceptionQueue(cap,tso);
}
- tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE);
}
/* Reset blocking status */
// we must own all Capabilities.
if (tso->why_blocked != BlockedOnCCall &&
- tso->why_blocked != BlockedOnCCall_NoUnblockExc) {
+ tso->why_blocked != BlockedOnCCall_Interruptible) {
throwToSingleThreaded(tso->cap,tso,NULL);
}
}
// like deleteThread(), but we delete threads in foreign calls, too.
if (tso->why_blocked == BlockedOnCCall ||
- tso->why_blocked == BlockedOnCCall_NoUnblockExc) {
+ tso->why_blocked == BlockedOnCCall_Interruptible) {
tso->what_next = ThreadKilled;
appendToRunQueue(tso->cap, tso);
} else {
RELEASE_LOCK(&task->lock);
}
+void
+interruptWorkerTask (Task *task)
+{
+ ASSERT(osThreadId() != task->id); // seppuku not allowed
+ ASSERT(task->incall->suspended_tso); // use this only for FFI calls
+ interruptOSThread(task->id);
+ debugTrace(DEBUG_sched, "interrupted worker task %lu", task->id);
+}
+
#endif /* THREADED_RTS */
#ifdef DEBUG
//
void startWorkerTask (Capability *cap);
+// Interrupts a worker task that is performing an FFI call. The thread
+// should not be destroyed.
+//
+void interruptWorkerTask (Task *task);
+
#endif /* THREADED_RTS */
// -----------------------------------------------------------------------------
case BlockedOnCCall:
debugBelch("is blocked on an external call");
break;
- case BlockedOnCCall_NoUnblockExc:
- debugBelch("is blocked on an external call (exceptions were already blocked)");
+ case BlockedOnCCall_Interruptible:
+ debugBelch("is blocked on an external call (but may be interrupted)");
break;
case BlockedOnSTM:
debugBelch("is blocked on an STM operation");
#include <mach/mach.h>
#endif
+#ifdef HAVE_SIGNAL_H
+# include <signal.h>
+#endif
+
/*
* This (allegedly) OS threads independent layer was initially
* abstracted away from code that used Pthreads, so the functions
}
#endif
+void
+interruptOSThread (OSThreadId id)
+{
+ pthread_kill(id, SIGPIPE);
+}
+
#else /* !defined(THREADED_RTS) */
int
// if the thread is not masking exceptions but there are
// pending exceptions on its queue, then something has gone
- // wrong:
+ // wrong. However, pending exceptions are OK if there is an
+ // uninterruptible FFI call.
ASSERT(t->blocked_exceptions == END_BLOCKED_EXCEPTIONS_QUEUE
+ || t->why_blocked == BlockedOnCCall
|| (t->flags & TSO_BLOCKEX));
if (tmp == NULL) {
}
}
+typedef BOOL (WINAPI *PCSIO)(HANDLE);
+
+void
+interruptOSThread (OSThreadId id)
+{
+ HANDLE hdl;
+ PCSIO pCSIO;
+ if (!(hdl = OpenThread(THREAD_TERMINATE,FALSE,id))) {
+ sysErrorBelch("interruptOSThread: OpenThread");
+ stg_exit(EXIT_FAILURE);
+ }
+ pCSIO = (PCSIO) GetProcAddress(GetModuleHandle(TEXT("Kernel32.dll")), "CancelSynchronousIo");
+ if ( NULL != pCSIO ) {
+ pCSIO(hdl);
+ } else {
+ // Nothing to do, unfortunately
+ }
+}
+
#else /* !defined(THREADED_RTS) */
int