diff options
32 files changed, 177 insertions, 49 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 9c9f41051e..4ea7f00b6a 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -254,7 +254,7 @@ type HintedCmmFormals = [HintedCmmFormal] 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 diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 0e87c6cd84..0778e7c2d4 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -459,7 +459,7 @@ extendEnvWithSafeForeignCalls transfers env g = fold_blocks block env g 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 @@ -478,7 +478,7 @@ extendEnvsForSafeForeignCalls cafEnv slotEnv g = 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 @@ -542,7 +542,7 @@ lowerSafeForeignCalls rst (CmmProc info l args (off, g@(LGraph entry _))) = do -- 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 @@ -554,7 +554,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last)) 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 : @@ -568,7 +568,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last)) -- 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 @@ -582,8 +582,9 @@ lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do 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)] <*> diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs index a0baa51fa1..924ce9d4ab 100644 --- a/compiler/cmm/CmmCPSGen.hs +++ b/compiler/cmm/CmmCPSGen.hs @@ -232,7 +232,9 @@ foreignCall uniques call results arguments = 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, diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index ad388e582a..33a4b809d8 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -8,6 +8,8 @@ -- ----------------------------------------------------------------------------- +-- TODO: Add support for interruptible/uninterruptible foreign call specification + { {-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} -- The NoMonomorphismRestriction deals with a Happy infelicity @@ -734,6 +736,7 @@ callishMachOps = listToUFM $ 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 @@ -864,6 +867,9 @@ foreignCall conv_string results_code expr_code args_code vols safety ret 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 @@ -898,6 +904,9 @@ primCall results_code name args_code vols safety 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 diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs index 06204ef9c3..847019c07c 100644 --- a/compiler/cmm/CmmStackLayout.hs +++ b/compiler/cmm/CmmStackLayout.hs @@ -358,7 +358,7 @@ layout procPoints env entry_off g = 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 @@ -422,7 +422,7 @@ manifestSP areaMap entry_off g@(LGraph entry _blocks) = 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 diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 06830581ad..46f0659e1a 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -64,7 +64,7 @@ mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals 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() @@ -131,9 +131,9 @@ mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r 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: diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index a9df2b9303..f5c5a49b92 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -143,6 +143,7 @@ pprTop (CmmData section ds) = 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 diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index b2328be890..aa16f0b198 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -165,6 +165,7 @@ data ForeignSafety = 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 @@ -484,7 +485,9 @@ ppr_fc (ForeignConvention c args res) = 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 diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index ce689c42f7..8e8e34d77b 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -144,7 +144,8 @@ emitForeignCall' safety results target args vols _srt ret -- 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) diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index b98da50f25..83c430143e 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -127,7 +127,7 @@ emitForeignCall safety results target args _srt _ret | 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) {- diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index b24daea781..b809795252 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -349,6 +349,7 @@ repCCallConv callConv = notHandled "repCCallConv" (ppr callConv) repSafety :: Safety -> DsM (Core TH.Safety) repSafety PlayRisky = rep2 unsafeName [] +repSafety PlayInterruptible = rep2 interruptibleName [] repSafety (PlaySafe False) = rep2 safeName [] repSafety (PlaySafe True) = rep2 threadsafeName [] @@ -1716,6 +1717,7 @@ templateHaskellNames = [ unsafeName, safeName, threadsafeName, + interruptibleName, -- InlineSpec inlineSpecNoPhaseName, inlineSpecPhaseName, -- FunDep @@ -1959,10 +1961,11 @@ cCallName = libFun (fsLit "cCall") cCallIdKey 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 @@ -2235,10 +2238,11 @@ cCallIdKey = mkPreludeMiscIdUnique 300 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 diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 0fa7c62ff3..6f6e51d0f5 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -309,8 +309,8 @@ mkBits findLabel st proto_insns 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) @@ -478,7 +478,7 @@ instrSize16s instr ENTER{} -> 1 RETURN{} -> 1 RETURN_UBX{} -> 1 - CCALL{} -> 3 + CCALL{} -> 4 SWIZZLE{} -> 3 BRK_FUN{} -> 4 diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 7d6bc234f7..d6545868fb 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -923,7 +923,7 @@ generateCCall :: Word16 -> Sequel -- stack and sequel depths -> [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 @@ -1092,7 +1092,8 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l 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) diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index b83006bd45..d44a00bc14 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -127,6 +127,9 @@ data BCInstr -- 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, @@ -217,9 +220,12 @@ instance Outputable BCInstr where 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" diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index cc54b843ce..fc5f897afb 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -375,6 +375,7 @@ cvtForD (ImportF callconv safety from nm ty) Unsafe -> PlayRisky Safe -> PlaySafe False Threadsafe -> PlaySafe True + Interruptible -> PlayInterruptible cvtForD (ExportF callconv as nm ty) = do { nm' <- vNameL nm diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index d49afec3e6..fd6d3bbf45 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -897,7 +897,7 @@ data ForeignImport = -- import of a C entity -- * `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) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index f31e6231ef..eab9419369 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -452,6 +452,7 @@ data Token | ITdynamic | ITsafe | ITthreadsafe + | ITinterruptible | ITunsafe | ITstdcallconv | ITccallconv @@ -596,6 +597,7 @@ isSpecial ITlabel = True isSpecial ITdynamic = True isSpecial ITsafe = True isSpecial ITthreadsafe = True +isSpecial ITinterruptible = True isSpecial ITunsafe = True isSpecial ITccallconv = True isSpecial ITstdcallconv = True @@ -658,6 +660,7 @@ reservedWordsFM = listToUFM $ ( "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), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 7ab7c447b2..a45ad87f0f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -248,6 +248,7 @@ incorrect. '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 } @@ -896,6 +897,7 @@ callconv :: { CCallConv } safety :: { Safety } : 'unsafe' { PlayRisky } | 'safe' { PlaySafe False } + | 'interruptible' { PlayInterruptible } | 'threadsafe' { PlaySafe True } -- deprecated alias fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } @@ -1791,6 +1793,7 @@ tyvarid :: { Located 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 } @@ -1824,6 +1827,7 @@ varid :: { 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") } @@ -1850,7 +1854,7 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-' -- 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 diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index 63c902963b..a92cabdec0 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -14,7 +14,7 @@ module ForeignCall ( ForeignCall(..), - Safety(..), playSafe, + Safety(..), playSafe, playInterruptible, CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, CCallSpec(..), @@ -63,6 +63,11 @@ data Safety -- 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 ) @@ -72,11 +77,17 @@ data Safety 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} @@ -233,13 +244,16 @@ instance Binary Safety where 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 diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml index 5ef50a65ae..b33e95abb6 100644 --- a/docs/users_guide/ffi-chap.xml +++ b/docs/users_guide/ffi-chap.xml @@ -476,6 +476,15 @@ int main(int argc, char *argv[]) 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"> diff --git a/includes/rts/Constants.h b/includes/rts/Constants.h index 354abbbdd9..140aaa4210 100644 --- a/includes/rts/Constants.h +++ b/includes/rts/Constants.h @@ -223,8 +223,8 @@ #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 diff --git a/includes/rts/OSThreads.h b/includes/rts/OSThreads.h index 106e1e7e9f..5d3e6ba140 100644 --- a/includes/rts/OSThreads.h +++ b/includes/rts/OSThreads.h @@ -165,6 +165,7 @@ typedef void OSThreadProcAttr OSThreadProc(void *); extern int createOSThread ( OSThreadId* tid, OSThreadProc *startProc, void *param); extern rtsBool osThreadIsAlive ( OSThreadId id ); +extern void interruptOSThread (OSThreadId id); // // Condition Variables diff --git a/includes/rts/Threads.h b/includes/rts/Threads.h index ca3e8b2da0..c974142ce3 100644 --- a/includes/rts/Threads.h +++ b/includes/rts/Threads.h @@ -31,7 +31,7 @@ StgTSO *createStrictIOThread (Capability *cap, nat stack_size, StgClosure *closure); // Suspending/resuming threads around foreign calls -void * suspendThread (StgRegTable *); +void * suspendThread (StgRegTable *, rtsBool interruptible); StgRegTable * resumeThread (void *); // diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 9a38a7ed18..da7ee2196a 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -1356,6 +1356,7 @@ run_BCO: 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 @@ -1444,7 +1445,7 @@ run_BCO: ((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); diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c index ad830cf322..b94ccea283 100644 --- a/rts/RaiseAsync.c +++ b/rts/RaiseAsync.c @@ -127,7 +127,7 @@ suspendComputation(Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here) Capability, and it is - NotBlocked, BlockedOnMsgThrowTo, - BlockedOnCCall + BlockedOnCCall_Interruptible - or it is masking exceptions (TSO_BLOCKEX) @@ -392,8 +392,29 @@ check_target: 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; diff --git a/rts/Schedule.c b/rts/Schedule.c index 8db125da74..0850749b36 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -1716,13 +1716,17 @@ recoverSuspendedTask (Capability *cap, Task *task) * 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; @@ -1751,12 +1755,10 @@ suspendThread (StgRegTable *reg) 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 @@ -1815,12 +1817,11 @@ resumeThread (void *task_) 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 */ @@ -2331,7 +2332,7 @@ deleteThread (Capability *cap STG_UNUSED, StgTSO *tso) // 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); } } @@ -2343,7 +2344,7 @@ deleteThread_(Capability *cap, StgTSO *tso) // 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 { diff --git a/rts/Task.c b/rts/Task.c index e93d60d86f..f26785a1be 100644 --- a/rts/Task.c +++ b/rts/Task.c @@ -409,6 +409,15 @@ startWorkerTask (Capability *cap) 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 diff --git a/rts/Task.h b/rts/Task.h index 566c0425cd..38e4763b5a 100644 --- a/rts/Task.h +++ b/rts/Task.h @@ -225,6 +225,11 @@ INLINE_HEADER Task *myTask (void); // 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 */ // ----------------------------------------------------------------------------- diff --git a/rts/Threads.c b/rts/Threads.c index 6635ed51e5..7344134a7d 100644 --- a/rts/Threads.c +++ b/rts/Threads.c @@ -492,8 +492,8 @@ printThreadBlockage(StgTSO *tso) 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"); diff --git a/rts/posix/OSThreads.c b/rts/posix/OSThreads.c index 343536e063..283155345c 100644 --- a/rts/posix/OSThreads.c +++ b/rts/posix/OSThreads.c @@ -57,6 +57,10 @@ #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 @@ -290,6 +294,12 @@ setThreadAffinity (nat n GNUC3_ATTRIBUTE(__unused__), } #endif +void +interruptOSThread (OSThreadId id) +{ + pthread_kill(id, SIGPIPE); +} + #else /* !defined(THREADED_RTS) */ int diff --git a/rts/sm/MarkWeak.c b/rts/sm/MarkWeak.c index e65c176c0a..d4d708e72c 100644 --- a/rts/sm/MarkWeak.c +++ b/rts/sm/MarkWeak.c @@ -270,8 +270,10 @@ static rtsBool tidyThreadList (generation *gen) // 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) { diff --git a/rts/win32/OSThreads.c b/rts/win32/OSThreads.c index cb00bd602d..44db42fef4 100644 --- a/rts/win32/OSThreads.c +++ b/rts/win32/OSThreads.c @@ -269,6 +269,25 @@ setThreadAffinity (nat n, nat m) // cap N of M } } +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 |