Make an extension for interruptible FFI calls

4 files changed, 40 insertions, 27 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 16e7a3e048..e0a8c8b6cb 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -357,6 +357,7 @@ data ExtensionFlag
    | Opt_ExtendedDefaultRules           -- Use GHC's extended rules for defaulting
    | Opt_ForeignFunctionInterface
    | Opt_UnliftedFFITypes
+   | Opt_InterruptibleFFI
    | Opt_GHCForeignImportPrim
    | Opt_ParallelArrays                 -- Syntactic support for parallel arrays
    | Opt_Arrows                         -- Arrow-notation syntax
@@ -1823,6 +1824,7 @@ xFlags = [
   ( "MonadComprehensions",              AlwaysAllowed, Opt_MonadComprehensions, nop),
   ( "ForeignFunctionInterface",   RestrictedFunction, Opt_ForeignFunctionInterface, nop ),
   ( "UnliftedFFITypes",                 AlwaysAllowed, Opt_UnliftedFFITypes, nop ),
+  ( "InterruptibleFFI",                 AlwaysAllowed, Opt_InterruptibleFFI, nop ),
   ( "GHCForeignImportPrim",             AlwaysAllowed, Opt_GHCForeignImportPrim, nop ),
   ( "LiberalTypeSynonyms",              AlwaysAllowed, Opt_LiberalTypeSynonyms, nop ),
   ( "Rank2Types",                       AlwaysAllowed, Opt_Rank2Types, nop ),
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 736ab0967b..49eaadf203 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -663,7 +663,7 @@ reservedWordsFM = listToUFM $
 	( "dynamic",	ITdynamic,	 bit ffiBit),
 	( "safe",	ITsafe,		 bit ffiBit .|. bit safeHaskellBit),
 	( "threadsafe",	ITthreadsafe,	 bit ffiBit),  -- ToDo: remove
-	( "interruptible", ITinterruptible, bit ffiBit),
+	( "interruptible", ITinterruptible, bit interruptibleFfiBit),
 	( "unsafe",	ITunsafe,	 bit ffiBit),
 	( "stdcall",    ITstdcallconv,	 bit ffiBit),
 	( "ccall",      ITccallconv,	 bit ffiBit),
@@ -1762,8 +1762,10 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
 
 ffiBit :: Int
 ffiBit	   = 1
+interruptibleFfiBit :: Int
+interruptibleFfiBit = 2
 parrBit :: Int
-parrBit	   = 2
+parrBit	   = 3
 arrowsBit :: Int
 arrowsBit  = 4
 thBit :: Int
@@ -1880,31 +1882,32 @@ mkPState flags buf loc =
       alr_justClosedExplicitLetBlock = False
     }
     where
-      bitmap =     ffiBit            `setBitIf` xopt Opt_ForeignFunctionInterface flags
-               .|. parrBit           `setBitIf` xopt Opt_ParallelArrays  flags
-               .|. arrowsBit         `setBitIf` xopt Opt_Arrows          flags
-               .|. thBit             `setBitIf` xopt Opt_TemplateHaskell flags
-               .|. qqBit             `setBitIf` xopt Opt_QuasiQuotes     flags
-               .|. ipBit             `setBitIf` xopt Opt_ImplicitParams  flags
-               .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll  flags
-               .|. bangPatBit        `setBitIf` xopt Opt_BangPatterns    flags
-               .|. tyFamBit          `setBitIf` xopt Opt_TypeFamilies    flags
-               .|. haddockBit        `setBitIf` dopt Opt_Haddock         flags
-               .|. magicHashBit      `setBitIf` xopt Opt_MagicHash       flags
-               .|. kindSigsBit       `setBitIf` xopt Opt_KindSignatures  flags
-               .|. recursiveDoBit    `setBitIf` xopt Opt_RecursiveDo     flags
-               .|. recBit            `setBitIf` xopt Opt_DoRec           flags
-               .|. recBit            `setBitIf` xopt Opt_Arrows          flags
-               .|. unicodeSyntaxBit  `setBitIf` xopt Opt_UnicodeSyntax   flags
-               .|. unboxedTuplesBit  `setBitIf` xopt Opt_UnboxedTuples   flags
-               .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
-               .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
-               .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags
-               .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
-               .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
-               .|. relaxedLayoutBit  `setBitIf` xopt Opt_RelaxedLayout flags
+      bitmap =     ffiBit                      `setBitIf` xopt Opt_ForeignFunctionInterface flags
+               .|. interruptibleFfiBit         `setBitIf` xopt Opt_InterruptibleFFI         flags
+               .|. parrBit                     `setBitIf` xopt Opt_ParallelArrays           flags
+               .|. arrowsBit                   `setBitIf` xopt Opt_Arrows                   flags
+               .|. thBit                       `setBitIf` xopt Opt_TemplateHaskell          flags
+               .|. qqBit                       `setBitIf` xopt Opt_QuasiQuotes              flags
+               .|. ipBit                       `setBitIf` xopt Opt_ImplicitParams           flags
+               .|. explicitForallBit           `setBitIf` xopt Opt_ExplicitForAll           flags
+               .|. bangPatBit                  `setBitIf` xopt Opt_BangPatterns             flags
+               .|. tyFamBit                    `setBitIf` xopt Opt_TypeFamilies             flags
+               .|. haddockBit                  `setBitIf` dopt Opt_Haddock                  flags
+               .|. magicHashBit                `setBitIf` xopt Opt_MagicHash                flags
+               .|. kindSigsBit                 `setBitIf` xopt Opt_KindSignatures           flags
+               .|. recursiveDoBit              `setBitIf` xopt Opt_RecursiveDo              flags
+               .|. recBit                      `setBitIf` xopt Opt_DoRec                    flags
+               .|. recBit                      `setBitIf` xopt Opt_Arrows                   flags
+               .|. unicodeSyntaxBit            `setBitIf` xopt Opt_UnicodeSyntax            flags
+               .|. unboxedTuplesBit            `setBitIf` xopt Opt_UnboxedTuples            flags
+               .|. datatypeContextsBit         `setBitIf` xopt Opt_DatatypeContexts         flags
+               .|. transformComprehensionsBit  `setBitIf` xopt Opt_TransformListComp        flags
+               .|. transformComprehensionsBit  `setBitIf` xopt Opt_MonadComprehensions      flags
+               .|. rawTokenStreamBit           `setBitIf` dopt Opt_KeepRawTokenStream       flags
+               .|. alternativeLayoutRuleBit    `setBitIf` xopt Opt_AlternativeLayoutRule    flags
+               .|. relaxedLayoutBit            `setBitIf` xopt Opt_RelaxedLayout            flags
                .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
-               .|. safeHaskellBit    `setBitIf` safeHaskellOn flags
+               .|. safeHaskellBit              `setBitIf` safeHaskellOn                     flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml
index 2fef13515d..c037623a49 100644
--- a/docs/users_guide/ffi-chap.xml
+++ b/docs/users_guide/ffi-chap.xml
@@ -101,7 +101,9 @@ OK:
           The problem is that it is not possible in general to
           interrupt a foreign call safely.  However, GHC does provide
           a way to interrupt blocking system calls which works for
-          most system calls on both Unix and Windows.  A foreign call
+          most system calls on both Unix and Windows.  When the
+          <literal>InterruptibleFFI</literal> extension is enabled,
+          a foreign call
           can be annotated with <literal>interruptible</literal> instead
           of <literal>safe</literal> or <literal>unsafe</literal>:
 
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index e8e262de67..ddec7d79d9 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -933,6 +933,12 @@
 	      <entry><option>-XNoUnliftedFFITypes</option></entry>
 	    </row>
 	    <row>
+	      <entry><option>-XInterruptibleFFI</option></entry>
+	      <entry>Enable interruptible FFI.</entry>
+	      <entry>dynamic</entry>
+	      <entry><option>-XNoInterruptibleFFI</option></entry>
+	    </row>
+	    <row>
 	      <entry><option>-XLiberalTypeSynonyms</option></entry>
 	      <entry>Enable <link linkend="type-synonyms">liberalised type synonyms</link>.</entry>
 	      <entry>dynamic</entry>