Commit d95869c5 authored by sof's avatar sof
Browse files

[project @ 2002-02-15 22:13:32 by sof]

New call attribute on foreign imports, threadsafe.

It indicates that a foreign import can(*) safely be called
concurrently with the continued evaluation of other Haskell
threads, i.e., when the foreign call is made by a Haskell
thread, it won't hinder the progress of other threads.

(*) - if the platform and RTS supports it, it _will be_
invoked concurrently.
parent d031626e
......@@ -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]
......
......@@ -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)
......
......@@ -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))
......
......@@ -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)
]
......
{- -*-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
......
......@@ -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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment