Interruptible FFI calls with pthread_kill and CancelSynchronousIO. v4

[ghc-hetmet.git] / compiler / cmm / CmmParse.y

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index ff6358d..33a4b80 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -8,8 +8,18 @@
 --
 -----------------------------------------------------------------------------
 
+-- TODO: Add support for interruptible/uninterruptible foreign call specification
+
 {
-{-# OPTIONS -Wwarn -w #-}
+{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-}
+-- The NoMonomorphismRestriction deals with a Happy infelicity
+--    With OutsideIn's more conservativ monomorphism restriction
+--    we aren't generalising
+--        notHappyAtAll = error "urk"
+--    which is terrible.  Switching off the restriction allows
+--    the generalisation.  Better would be to make Happy generate
+--    an appropriate signature.
+--
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
@@ -214,7 +224,7 @@ static      :: { ExtFCode [CmmStatic] }
        | 'CLOSURE' '(' NAME lits ')'
                { do lits <- sequence $4;
                     return $ map CmmStaticLit $
-                       mkStaticClosure (mkForeignLabel $3 Nothing True IsData)
+                       mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
                          -- mkForeignLabel because these are only used
                          -- for CHARLIKE and INTLIKE closures in the RTS.
                         dontCareCCS (map getLit lits) [] [] [] }
@@ -346,14 +356,21 @@ decl      :: { ExtCode }
 
 -- an imported function name, with optional packageId
 importNames  
-       :: { [(Maybe PackageId, FastString)] }
+       :: { [(FastString, CLabel)] }
        : importName                    { [$1] }
        | importName ',' importNames    { $1 : $3 }             
        
 importName
-       :: { (Maybe PackageId, FastString) }
-       : NAME                          { (Nothing, $1) }
-       | STRING NAME                   { (Just (fsToPackageId (mkFastString $1)), $2) }
+       :: { (FastString,  CLabel) }
+
+       -- A label imported without an explicit packageId.
+       --      These are taken to come frome some foreign, unnamed package.
+       : NAME  
+       { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
+
+       -- A label imported with an explicit packageId.
+       | STRING NAME
+       { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
        
        
 names  :: { [FastString] }
@@ -719,6 +736,7 @@ callishMachOps = listToUFM $
 parseSafety :: String -> P CmmSafety
 parseSafety "safe"   = return (CmmSafe NoC_SRT)
 parseSafety "unsafe" = return CmmUnsafe
+parseSafety "interruptible" = return CmmInterruptible
 parseSafety str      = fail ("unrecognised safety: " ++ str)
 
 parseCmmHint :: String -> P ForeignHint
@@ -849,6 +867,9 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
                 code (emitForeignCall' (PlaySafe unused) results 
                    (CmmCallee expr' convention) args vols NoC_SRT ret) where
                unused = panic "not used by emitForeignCall'"
+              CmmInterruptible ->
+                code (emitForeignCall' PlayInterruptible results 
+                   (CmmCallee expr' convention) args vols NoC_SRT ret)
 
 adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
 #ifdef mingw32_TARGET_OS
@@ -883,6 +904,9 @@ primCall results_code name args_code vols safety
                    code (emitForeignCall' (PlaySafe unused) results 
                      (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
                    unused = panic "not used by emitForeignCall'"
+                 CmmInterruptible ->
+                   code (emitForeignCall' PlayInterruptible results 
+                     (CmmPrim p) args vols NoC_SRT CmmMayReturn)
 
 doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 doStore rep addr_code val_code
@@ -1026,7 +1050,7 @@ parseCmmFile dflags filename = do
   buf <- hGetStringBuffer filename
   let
        init_loc = mkSrcLoc (mkFastString filename) 1 1
-       init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
+       init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
                -- reset the lex_state: the Lexer monad leaves some stuff
                -- in there we don't want.
   case unP cmmParse init_state of