From: sof Date: Fri, 15 Feb 2002 22:13:33 +0000 (+0000) Subject: [project @ 2002-02-15 22:13:32 by sof] X-Git-Tag: Approximately_9120_patches~23 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d95869c5824ef634654be93dd9f964c24bb5185e;p=ghc-hetmet.git [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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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}