Interruptible FFI calls with pthread_kill and CancelSynchronousIO. v4

[ghc-hetmet.git] / compiler / cmm / ZipCfgCmmRep.hs

diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index 451450e..aa16f0b 100644 (file)
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -1,3 +1,8 @@
+#if __GLASGOW_HASKELL__ >= 611
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+#endif
+-- Norman likes local bindings
+
 -- This module is pure representation and should be imported only by
 -- clients that need to manipulate representation and know what
 -- they're doing.  Clients that need to create flow graphs should
@@ -114,13 +119,13 @@ data Last
          -- the call goes into a loop.
        }
 
-data MidCallTarget     -- The target of a MidUnsafeCall
-  = ForeignTarget      -- A foreign procedure
-       CmmExpr                 -- Its address
-       ForeignConvention       -- Its calling convention
+data MidCallTarget        -- The target of a MidUnsafeCall
+  = ForeignTarget         -- A foreign procedure
+        CmmExpr                  -- Its address
+        ForeignConvention        -- Its calling convention
 
-  | PrimTarget         -- A possibly-side-effecting machine operation
-       CallishMachOp           -- Which one
+  | PrimTarget            -- A possibly-side-effecting machine operation
+        CallishMachOp            -- Which one
   deriving Eq
 
 data Convention
@@ -160,6 +165,7 @@ data ForeignSafety
   = Unsafe              -- unsafe call
   | Safe BlockId        -- making infotable requires: 1. label 
          UpdFrameOffset --                            2. where the upd frame is
+         Bool           -- is the call interruptible?
   deriving Eq
 
 data ValueDirection = Arguments | Results
@@ -277,8 +283,8 @@ instance UserOfLocalRegs MidCallTarget where
   foldRegsUsed f  z (ForeignTarget e _) = foldRegsUsed f z e
 
 instance UserOfSlots MidCallTarget where
+  foldSlotsUsed  f z (ForeignTarget e _) = foldSlotsUsed f z e
   foldSlotsUsed _f z (PrimTarget _)      = z
-  foldSlotsUsed f  z (ForeignTarget e _) = foldSlotsUsed f z e
 
 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
   foldRegsUsed f z (Just x) = foldRegsUsed f z x
@@ -479,12 +485,19 @@ ppr_fc (ForeignConvention c args res) =
   doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
 
 ppr_safety :: ForeignSafety -> SDoc
-ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
+ppr_safety (Safe bid upd interruptible) =
+    text (if interruptible then "interruptible" else "safe") <>
+    text "<" <> ppr bid <> text ", " <> ppr upd <> text ">"
 ppr_safety Unsafe         = text "unsafe"
 
 ppr_call_target :: MidCallTarget -> SDoc
 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
-ppr_call_target (PrimTarget op)      = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction))
+ppr_call_target (PrimTarget op) 
+ -- HACK: We're just using a ForeignLabel to get this printed, the label
+ --      might not really be foreign.
+ = ppr (CmmLabel (mkForeignLabel
+                       (mkFastString (show op)) 
+                       Nothing ForeignLabelInThisPackage IsFunction))
 
 ppr_target :: CmmExpr -> SDoc
 ppr_target t@(CmmLit _) = ppr t