diff options
| -rw-r--r-- | compiler/cmm/CmmParse.y | 6 | ||||
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 10 | ||||
| -rw-r--r-- | compiler/hsSyn/Convert.lhs | 3 | ||||
| -rw-r--r-- | compiler/parser/Lexer.x | 3 | ||||
| -rw-r--r-- | compiler/parser/Parser.y.pp | 8 | ||||
| -rw-r--r-- | compiler/parser/ParserCore.y | 2 | ||||
| -rw-r--r-- | compiler/prelude/ForeignCall.lhs | 17 | ||||
| -rw-r--r-- | compiler/typecheck/TcForeign.lhs | 16 |
8 files changed, 16 insertions, 49 deletions
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 1ee7403b4a..07a8c11df5 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -874,9 +874,8 @@ foreignCall conv_string results_code expr_code args_code vols safety ret code (emitForeignCall' PlayRisky results (CmmCallee expr' convention) args vols NoC_SRT ret) CmmSafe srt -> - code (emitForeignCall' (PlaySafe unused) results + code (emitForeignCall' PlaySafe 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) @@ -911,9 +910,8 @@ primCall results_code name args_code vols safety code (emitForeignCall' PlayRisky results (CmmPrim p) args vols NoC_SRT CmmMayReturn) CmmSafe srt -> - code (emitForeignCall' (PlaySafe unused) results + code (emitForeignCall' PlaySafe 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) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 3988105e90..6c74056aa7 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -351,8 +351,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 [] +repSafety PlaySafe = rep2 safeName [] ds_msg :: SDoc ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") @@ -1797,7 +1796,6 @@ templateHaskellNames = [ -- Safety unsafeName, safeName, - threadsafeName, interruptibleName, -- InlineSpec inlineSpecNoPhaseName, inlineSpecPhaseName, @@ -2046,10 +2044,9 @@ cCallName = libFun (fsLit "cCall") cCallIdKey stdCallName = libFun (fsLit "stdCall") stdCallIdKey -- data Safety = ... -unsafeName, safeName, threadsafeName, interruptibleName :: Name +unsafeName, safeName, interruptibleName :: Name unsafeName = libFun (fsLit "unsafe") unsafeIdKey safeName = libFun (fsLit "safe") safeIdKey -threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey -- data InlineSpec = ... @@ -2328,10 +2325,9 @@ cCallIdKey = mkPreludeMiscIdUnique 394 stdCallIdKey = mkPreludeMiscIdUnique 395 -- data Safety = ... -unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique +unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique unsafeIdKey = mkPreludeMiscIdUnique 400 safeIdKey = mkPreludeMiscIdUnique 401 -threadsafeIdKey = mkPreludeMiscIdUnique 402 interruptibleIdKey = mkPreludeMiscIdUnique 403 -- data InlineSpec = diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 7b0d8c4f0d..cd584e1e2c 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -374,8 +374,7 @@ cvtForD (ImportF callconv safety from nm ty) where safety' = case safety of Unsafe -> PlayRisky - Safe -> PlaySafe False - Threadsafe -> PlaySafe True + Safe -> PlaySafe Interruptible -> PlayInterruptible cvtForD (ExportF callconv as nm ty) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 49eaadf203..a30a7fefbf 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -451,7 +451,6 @@ data Token | ITlabel | ITdynamic | ITsafe - | ITthreadsafe | ITinterruptible | ITunsafe | ITstdcallconv @@ -599,7 +598,6 @@ isSpecial ITexport = True isSpecial ITlabel = True isSpecial ITdynamic = True isSpecial ITsafe = True -isSpecial ITthreadsafe = True isSpecial ITinterruptible = True isSpecial ITunsafe = True isSpecial ITccallconv = True @@ -662,7 +660,6 @@ reservedWordsFM = listToUFM $ ( "label", ITlabel, bit ffiBit), ( "dynamic", ITdynamic, bit ffiBit), ( "safe", ITsafe, bit ffiBit .|. bit safeHaskellBit), - ( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove ( "interruptible", ITinterruptible, bit interruptibleFfiBit), ( "unsafe", ITunsafe, bit ffiBit), ( "stdcall", ITstdcallconv, bit ffiBit), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 2641cc53f2..05e0222182 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -238,7 +238,6 @@ incorrect. 'label' { L _ ITlabel } 'dynamic' { L _ ITdynamic } 'safe' { L _ ITsafe } - 'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias 'interruptible' { L _ ITinterruptible } 'unsafe' { L _ ITunsafe } 'mdo' { L _ ITmdo } @@ -894,7 +893,7 @@ fdecl :: { LHsDecl RdrName } fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (unLoc $4) >>= return.LL } | 'import' callconv fspec - {% do { d <- mkImport $2 (PlaySafe False) (unLoc $3); + {% do { d <- mkImport $2 PlaySafe (unLoc $3); return (LL d) } } | 'export' callconv fspec {% mkExport $2 (unLoc $3) >>= return.LL } @@ -906,9 +905,8 @@ callconv :: { CCallConv } safety :: { Safety } : 'unsafe' { PlayRisky } - | 'safe' { PlaySafe False } + | 'safe' { PlaySafe } | 'interruptible' { PlayInterruptible } - | 'threadsafe' { PlaySafe True } -- deprecated alias fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } : STRING var '::' sigtypedoc { LL (L (getLoc $1) (getSTRING $1), $2, $4) } @@ -1808,7 +1806,6 @@ tyvarid :: { Located RdrName } | '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 } -- Does not include "!", because that is used for strictness marks @@ -1842,7 +1839,6 @@ varid :: { Located RdrName } | '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") } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 3f2b32a8b3..c99fcb6695 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -279,7 +279,7 @@ exp :: { IfaceExpr } -- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall (CCallSpec (StaticTarget (mkFastString $2) Nothing) - CCallConv (PlaySafe False))) + CCallConv PlaySafe)) $3 } alts1 :: { [IfaceAlt] } diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index 87bb94a148..ac19974976 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -62,10 +62,6 @@ data Safety -- by a separate OS thread, i.e., _concurrently_ to the -- execution of other Haskell threads. - Bool -- Indicates the deprecated "threadsafe" annotation - -- 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 @@ -78,15 +74,14 @@ data Safety {-! derive: Binary !-} instance Outputable Safety where - ppr (PlaySafe False) = ptext (sLit "safe") - ppr (PlaySafe True) = ptext (sLit "threadsafe") + ppr PlaySafe = ptext (sLit "safe") ppr PlayInterruptible = ptext (sLit "interruptible") ppr PlayRisky = ptext (sLit "unsafe") playSafe :: Safety -> Bool -playSafe PlaySafe{} = True +playSafe PlaySafe = True playSafe PlayInterruptible = True -playSafe PlayRisky = False +playSafe PlayRisky = False playInterruptible :: Safety -> Bool playInterruptible PlayInterruptible = True @@ -244,9 +239,8 @@ instance Binary ForeignCall where get bh = do aa <- get bh; return (CCall aa) instance Binary Safety where - put_ bh (PlaySafe aa) = do + put_ bh PlaySafe = do putByte bh 0 - put_ bh aa put_ bh PlayInterruptible = do putByte bh 1 put_ bh PlayRisky = do @@ -254,8 +248,7 @@ instance Binary Safety where get bh = do h <- getByte bh case h of - 0 -> do aa <- get bh - return (PlaySafe aa) + 0 -> do return PlaySafe 1 -> do return PlayInterruptible _ -> do return PlayRisky diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index a24eb47b9d..36ab1e2d93 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -88,15 +88,14 @@ tcFImport d = pprPanic "tcFImport" (ppr d) \begin{code} tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _)) = ASSERT( null arg_tys ) do { checkCg checkCOrAsmOrLlvmOrInterp - ; checkSafety safety ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty) ; return idecl } -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do -- Foreign wrapper (former f.e.d.) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well @@ -104,7 +103,6 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do -- is DEPRECATED, though. checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv - checkSafety safety case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok False isFFIExportResultTy res1_ty @@ -118,7 +116,6 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv - checkSafety safety case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> do check False (illegalForeignTyErr empty sig_ty) @@ -149,7 +146,6 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar | otherwise = do -- Normal foreign import checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) checkCConv cconv - checkSafety safety checkCTarget target dflags <- getDOpts checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys @@ -323,14 +319,6 @@ checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} -Deprecated "threadsafe" calls - -\begin{code} -checkSafety :: Safety -> TcM () -checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.") -checkSafety _ = return () -\end{code} - Warnings \begin{code} |