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

diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index 1e7928f..c3a63f9 100644 (file)
--- 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 ecd5bf8..0c8688a 100644 (file)
--- 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 5bac1b5..c970808 100644 (file)
--- 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 d464788..2eb564a 100644 (file)
--- 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 ca4fbba..cbc0a5b 100644 (file)
--- 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 9df1c40..6be1b5e 100644 (file)
--- 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}