diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index 1e7928f7a7bbde51f5895937bf2114cdcfea171f..c3a63f9934d87fba76cab301f82bcfa740d7bd90 100644
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -401,7 +401,7 @@ flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs)
[]
(StgFCallOp
(CCall (CCallSpec (CasmTarget (_PK_ (mktxt op_str)))
- defaultCCallConv PlaySafe))
+ defaultCCallConv (PlaySafe False)))
uu
)
[CReg VoidReg]
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index ecd5bf803bd748a6b8b0efa36e71b972929c316a..0c8688a9f6b9f895077f05d8b39e1b909cd5cb11 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -26,7 +26,8 @@ import AbsCUtils ( getAmodeRep, nonemptyAbsC,
mixedPtrLocn, mixedTypeLocn
)
-import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute )
+import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
+ playThreadSafe, ccallConvAttribute )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
@@ -937,11 +938,14 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
]
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
+
+ thread_macro_args = ppr_uniq_token <> comma <+>
+ text "rts" <> ppr (playThreadSafe safety)
ppr_uniq_token = text "tok_" <> ppr uniq
(pp_save_context, pp_restore_context)
| playSafe safety = ( text "{ I_" <+> ppr_uniq_token <>
- text "; SUSPEND_THREAD" <> parens ppr_uniq_token <> semi
- , text "RESUME_THREAD" <> parens ppr_uniq_token <> text ";}"
+ text "; SUSPEND_THREAD" <> parens thread_macro_args <> semi
+ , text "RESUME_THREAD" <> parens thread_macro_args <> text ";}"
)
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 5bac1b56693e15532643962dbd46813ebf82d66f..c97080842fc23384c38072e46ad55b6e9bbde04c 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -26,7 +26,7 @@ import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel,
mkForeignLabel )
import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
- CCallConv(..), playSafe )
+ CCallConv(..), playSafe, playThreadSafe )
import Outputable
import FastTypes
@@ -70,18 +70,22 @@ foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
= returnUs (\xs -> ccall : xs)
| otherwise
- = save_thread_state `thenUs` \ save ->
- load_thread_state `thenUs` \ load ->
- getUniqueUs `thenUs` \ uniq ->
+ = save_thread_state `thenUs` \ save ->
+ load_thread_state `thenUs` \ load ->
+ getUniqueUs `thenUs` \ uniq ->
let
id = StixTemp (StixVReg uniq IntRep)
+
+ is_threadSafe
+ | playThreadSafe safety = 1
+ | otherwise = 0
suspend = StAssignReg IntRep id
(StCall (Left SLIT("suspendThread")) {-no:cconv-} CCallConv
- IntRep [StReg stgBaseReg])
+ IntRep [StReg stgBaseReg, StInt is_threadSafe ])
resume = StVoidable
(StCall (Left SLIT("resumeThread")) {-no:cconv-} CCallConv
- VoidRep [StReg id])
+ VoidRep [StReg id, StInt is_threadSafe ])
in
returnUs (\xs -> save (suspend : ccall : resume : load xs))
diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index d4647888dad01aae076a55ce0e4555d0e43d8dde..2eb564a7f51bcd7bbd18990ca0416b9f0e18d93a 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -127,6 +127,7 @@ data Token
| ITlabel
| ITdynamic
| ITsafe
+ | ITthreadsafe
| ITunsafe
| ITwith
| ITstdcallconv
@@ -305,6 +306,7 @@ isSpecial ITexport = True
isSpecial ITlabel = True
isSpecial ITdynamic = True
isSpecial ITsafe = True
+isSpecial ITthreadsafe = True
isSpecial ITunsafe = True
isSpecial ITwith = True
isSpecial ITccallconv = True
@@ -320,15 +322,16 @@ ghcExtensionKeywordsFM = listToUFM $
( "label", ITlabel ),
( "dynamic", ITdynamic ),
( "safe", ITsafe ),
+ ( "threadsafe", ITthreadsafe ),
( "unsafe", ITunsafe ),
( "with", ITwith ),
( "stdcall", ITstdcallconv),
( "ccall", ITccallconv),
( "dotnet", ITdotnet),
("_ccall_", ITccall (False, False, PlayRisky)),
- ("_ccall_GC_", ITccall (False, False, PlaySafe)),
+ ("_ccall_GC_", ITccall (False, False, PlaySafe False)),
("_casm_", ITccall (False, True, PlayRisky)),
- ("_casm_GC_", ITccall (False, True, PlaySafe)),
+ ("_casm_GC_", ITccall (False, True, PlaySafe False)),
-- interface keywords
("__interface", ITinterface),
@@ -363,13 +366,13 @@ ghcExtensionKeywordsFM = listToUFM $
("__U", ITunfold),
("__ccall", ITccall (False, False, PlayRisky)),
- ("__ccall_GC", ITccall (False, False, PlaySafe)),
+ ("__ccall_GC", ITccall (False, False, PlaySafe False)),
("__dyn_ccall", ITccall (True, False, PlayRisky)),
- ("__dyn_ccall_GC", ITccall (True, False, PlaySafe)),
+ ("__dyn_ccall_GC", ITccall (True, False, PlaySafe False)),
("__casm", ITccall (False, True, PlayRisky)),
("__dyn_casm", ITccall (True, True, PlayRisky)),
- ("__casm_GC", ITccall (False, True, PlaySafe)),
- ("__dyn_casm_GC", ITccall (True, True, PlaySafe)),
+ ("__casm_GC", ITccall (False, True, PlaySafe False)),
+ ("__dyn_casm_GC", ITccall (True, True, PlaySafe False)),
("/\\", ITbiglam)
]
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index ca4fbbab322ffc3c92080de52dde7c841572f516..cbc0a5bff62f2a1e058d18b646c9c078fc002514 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.89 2002/02/13 15:19:19 simonpj Exp $
+$Id: Parser.y,v 1.90 2002/02/15 22:13:33 sof Exp $
Haskell grammar.
@@ -111,15 +111,16 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2]
'label' { ITlabel }
'dynamic' { ITdynamic }
'safe' { ITsafe }
+ 'threadsafe' { ITthreadsafe }
'unsafe' { ITunsafe }
'with' { ITwith }
'stdcall' { ITstdcallconv }
'ccall' { ITccallconv }
'dotnet' { ITdotnet }
'_ccall_' { ITccall (False, False, PlayRisky) }
- '_ccall_GC_' { ITccall (False, False, PlaySafe) }
+ '_ccall_GC_' { ITccall (False, False, PlaySafe False) }
'_casm_' { ITccall (False, True, PlayRisky) }
- '_casm_GC_' { ITccall (False, True, PlaySafe) }
+ '_casm_GC_' { ITccall (False, True, PlaySafe False) }
'{-# SPECIALISE' { ITspecialise_prag }
'{-# SOURCE' { ITsource_prag }
@@ -515,7 +516,7 @@ deprecation :: { RdrBinding }
--
fdecl :: { RdrNameHsDecl }
fdecl : srcloc 'import' callconv safety1 fspec {% mkImport $3 $4 $5 $1 }
- | srcloc 'import' callconv fspec {% mkImport $3 PlaySafe $4 $1 }
+ | srcloc 'import' callconv fspec {% mkImport $3 (PlaySafe False) $4 $1 }
| srcloc 'export' callconv fspec {% mkExport $3 $4 $1 }
-- the following syntax is DEPRECATED
| srcloc fdecl1DEPRECATED { ForD ($2 True $1) }
@@ -525,7 +526,7 @@ fdecl1DEPRECATED :: { Bool -> SrcLoc -> ForeignDecl RdrName }
fdecl1DEPRECATED
----------- DEPRECATED label decls ------------
: 'label' ext_name varid '::' sigtype
- { ForeignImport $3 $5 (CImport defaultCCallConv PlaySafe _NIL_ _NIL_
+ { ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) _NIL_ _NIL_
(CLabel ($2 `orElse` mkExtName $3))) }
----------- DEPRECATED ccall/stdcall decls ------------
@@ -595,7 +596,7 @@ fdecl1DEPRECATED
-- DEPRECATED variant #8: use of the special identifier `dynamic' without
-- an explicit calling convention (export)
| 'export' {-no callconv-} 'dynamic' varid '::' sigtype
- { ForeignImport $3 $5 (CImport defaultCCallConv PlaySafe _NIL_ _NIL_
+ { ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) _NIL_ _NIL_
CWrapper) }
-- DEPRECATED variant #9: use of the special identifier `dynamic' (export)
@@ -603,7 +604,7 @@ fdecl1DEPRECATED
{% case $2 of
DNCall -> parseError "Illegal format of .NET foreign import"
CCall cconv -> returnP $
- ForeignImport $4 $6 (CImport cconv PlaySafe _NIL_ _NIL_ CWrapper) }
+ ForeignImport $4 $6 (CImport cconv (PlaySafe False) _NIL_ _NIL_ CWrapper) }
----------- DEPRECATED .NET decls ------------
-- NB: removed the .NET call declaration, as it is entirely subsumed
@@ -624,12 +625,14 @@ callconv :: { CallConv }
safety :: { Safety }
: 'unsafe' { PlayRisky }
- | 'safe' { PlaySafe }
- | {- empty -} { PlaySafe }
+ | 'safe' { PlaySafe False }
+ | 'threadsafe' { PlaySafe True }
+ | {- empty -} { PlaySafe False }
safety1 :: { Safety }
: 'unsafe' { PlayRisky }
- | 'safe' { PlaySafe }
+ | 'safe' { PlaySafe False }
+ | 'threadsafe' { PlaySafe True }
-- only needed to avoid conflicts with the DEPRECATED rules
fspec :: { (FAST_STRING, RdrName, RdrNameHsType) }
@@ -897,9 +900,9 @@ exp10 :: { RdrNameHsExpr }
returnP (HsDo DoExpr stmts $1) }
| '_ccall_' ccallid aexps0 { HsCCall $2 $3 PlayRisky False placeHolderType }
- | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 PlaySafe False placeHolderType }
+ | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 (PlaySafe False) False placeHolderType }
| '_casm_' CLITLIT aexps0 { HsCCall $2 $3 PlayRisky True placeHolderType }
- | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 PlaySafe True placeHolderType }
+ | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 (PlaySafe False) True placeHolderType }
| scc_annot exp { if opt_SccProfilingOn
then HsSCC $1 $2
diff --git a/ghc/compiler/prelude/ForeignCall.lhs b/ghc/compiler/prelude/ForeignCall.lhs
index 9df1c4070c4b6004581d22d9fc5c0027f1fe2297..6be1b5e3b6a52001997c57c8195284562e7ddb0d 100644
--- a/ghc/compiler/prelude/ForeignCall.lhs
+++ b/ghc/compiler/prelude/ForeignCall.lhs
@@ -6,7 +6,7 @@
\begin{code}
module ForeignCall (
ForeignCall(..),
- Safety(..), playSafe,
+ Safety(..), playSafe, playThreadSafe,
CExportSpec(..),
CCallSpec(..),
@@ -52,6 +52,10 @@ data Safety
= PlaySafe -- Might invoke Haskell GC, or do a call back, or
-- switch threads, etc. So make sure things are
-- tidy before the call
+ Bool -- => True, external function is also re-entrant.
+ -- [if supported, RTS arranges for the external call
+ -- to be executed by a separate OS thread, i.e.,
+ -- _concurrently_ to the execution of other Haskell threads.]
| PlayRisky -- None of the above can happen; the call will return
-- without interacting with the runtime system at all
@@ -59,11 +63,17 @@ data Safety
-- Show used just for Show Lex.Token, I think
instance Outputable Safety where
- ppr PlaySafe = ptext SLIT("safe")
+ ppr (PlaySafe False) = ptext SLIT("safe")
+ ppr (PlaySafe True) = ptext SLIT("threadsafe")
ppr PlayRisky = ptext SLIT("unsafe")
-playSafe PlaySafe = True
-playSafe PlayRisky = False
+playSafe :: Safety -> Bool
+playSafe PlaySafe{} = True
+playSafe PlayRisky = False
+
+playThreadSafe :: Safety -> Bool
+playThreadSafe (PlaySafe x) = x
+playThreadSafe _ = False
\end{code}