[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.

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]

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)

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))
 

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)
      ]

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,15 +596,15 @@ 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)
   | 'export' callconv 'dynamic' varid '::' sigtype
     {% 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

ghc/compiler/prelude/ForeignCall.lhs

@@ -6,7 +6,7 @@
 \begin{code}
 module ForeignCall (
 	ForeignCall(..),
-	Safety(..), playSafe,
+	Safety(..), playSafe, playThreadSafe,
 
 	CExportSpec(..),
 	CCallSpec(..), 
@@ -52,18 +52,28 @@ 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
   deriving( Eq, Show )
 	-- 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}