Interruptible FFI calls with pthread_kill and CancelSynchronousIO. v4

[ghc-hetmet.git] / compiler / deSugar / DsMeta.hs

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7718e4f..b809795 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -106,7 +106,7 @@ repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
 
 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 repTopDs group
- = do { let { bndrs = map unLoc (groupBinders group) } ;
+ = do { let { bndrs = hsGroupBinders group } ;
        ss <- mkGenSyms bndrs ;
 
        -- Bind all the names mainly to avoid repeated use of explicit strings.
@@ -135,16 +135,6 @@ repTopDs group
        -- Do *not* gensym top-level binders
       }
 
-groupBinders :: HsGroup Name -> [Located Name]
-groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
-                        hs_instds = inst_decls, hs_fords = foreign_decls })
--- Collect the binders of a Group
-  = collectHsValBinders val_decls ++
-    [n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++
-    [n | L _ (ForeignImport n _ _) <- foreign_decls]
-  where
-    assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
-
 
 {-     Note [Binders and occurrences]
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -317,7 +307,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
                 -- appear in the resulting data structure
                do { cxt1 <- repContext cxt
                   ; inst_ty1 <- repPredTy (HsClassP cls tys)
-                  ; ss <- mkGenSyms (collectHsBindBinders binds)
+                  ; ss <- mkGenSyms (collectHsBindsBinders binds)
                   ; binds1 <- addBinds ss (rep_binds binds)
                    ; ats1   <- repLAssocFamInst ats
                   ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
@@ -359,6 +349,7 @@ repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
 
 repSafety :: Safety -> DsM (Core TH.Safety)
 repSafety PlayRisky = rep2 unsafeName []
+repSafety PlayInterruptible = rep2 interruptibleName []
 repSafety (PlaySafe False) = rep2 safeName []
 repSafety (PlaySafe True) = rep2 threadsafeName []
 
@@ -470,15 +461,17 @@ rep_specialise nm ty ispec loc
 rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
                -> DsM (Core TH.InlineSpecQ)
 rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
-  | Nothing            <- activation1 
-    = repInlineSpecNoPhase inline1 match1
   | Just (flag, phase) <- activation1 
-    = repInlineSpecPhase inline1 match1 flag phase
-  | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
-    where
+  = repInlineSpecPhase inline1 match1 flag phase
+  | otherwise
+  = repInlineSpecNoPhase inline1 match1
+  where
       match1      = coreBool (rep_RuleMatchInfo match)
       activation1 = rep_Activation activation
-      inline1     = coreBool inline
+      inline1     = case inline of 
+                       Inline -> coreBool True
+                      _other -> coreBool False
+                      -- We have no representation for Inlinable
 
       rep_RuleMatchInfo FunLike = False
       rep_RuleMatchInfo ConLike = True
@@ -536,9 +529,10 @@ lookupTyVarBinds tvs m =
 --
 repTyVarBndrWithKind :: LHsTyVarBndr Name 
                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)
-repTyVarBndrWithKind (L _ (UserTyVar _))      = repPlainTV
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) = 
-  \nm -> repKind ki >>= repKindedTV nm
+repTyVarBndrWithKind (L _ (UserTyVar {})) nm
+  = repPlainTV nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
+  = repKind ki >>= repKindedTV nm
 
 -- represent a type context
 --
@@ -632,9 +626,9 @@ repTy (HsKindSig t k)       = do
                                 t1 <- repLTy t
                                 k1 <- repKind k
                                 repTSig t1 k1
-repTy (HsSpliceTy splice)   = repSplice splice
-repTy ty@(HsNumTy _)        = notHandled "Number types (for generics)" (ppr ty)
-repTy ty                   = notHandled "Exotic form of type" (ppr ty)
+repTy (HsSpliceTy splice _ _) = repSplice splice
+repTy ty@(HsNumTy _)          = notHandled "Number types (for generics)" (ppr ty)
+repTy ty                     = notHandled "Exotic form of type" (ppr ty)
 
 -- represent a kind
 --
@@ -643,7 +637,7 @@ repKind ki
   = do { let (kis, ki') = splitKindFunTys ki
        ; kis_rep <- mapM repKind kis
        ; ki'_rep <- repNonArrowKind ki'
-       ; foldlM repArrowK ki'_rep kis_rep
+       ; foldrM repArrowK ki'_rep kis_rep
        }
   where
     repNonArrowKind k | isLiftedTypeKind k = repStarK
@@ -899,7 +893,7 @@ repBinds EmptyLocalBinds
 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
 
 repBinds (HsValBinds decs)
- = do  { let { bndrs = map unLoc (collectHsValBinders decs) }
+ = do  { let { bndrs = collectHsValBinders decs }
                -- No need to worrry about detailed scopes within
                -- the binding group, because we are talking Names
                -- here, so we can safely treat it as a mutually 
@@ -1664,10 +1658,11 @@ templateHaskellNames :: [Name]
 templateHaskellNames = [
     returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, 
-
+    liftStringName,
+ 
     -- Lit
     charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
-    floatPrimLName, doublePrimLName, rationalLName,
+    floatPrimLName, doublePrimLName, rationalLName, 
     -- Pat
     litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName,
     asPName, wildPName, recPName, listPName, sigPName,
@@ -1722,6 +1717,7 @@ templateHaskellNames = [
     unsafeName,
     safeName,
     threadsafeName,
+    interruptibleName,
     -- InlineSpec
     inlineSpecNoPhaseName, inlineSpecPhaseName,
     -- FunDep
@@ -1965,10 +1961,11 @@ cCallName = libFun (fsLit "cCall") cCallIdKey
 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
 
 -- data Safety = ...
-unsafeName, safeName, threadsafeName :: Name
+unsafeName, safeName, threadsafeName, interruptibleName :: Name
 unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
 safeName       = libFun (fsLit "safe") safeIdKey
 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
+interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
 
 -- data InlineSpec = ...
 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
@@ -2241,10 +2238,11 @@ cCallIdKey      = mkPreludeMiscIdUnique 300
 stdCallIdKey    = mkPreludeMiscIdUnique 301
 
 -- data Safety = ...
-unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
+unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique
 unsafeIdKey     = mkPreludeMiscIdUnique 305
 safeIdKey       = mkPreludeMiscIdUnique 306
 threadsafeIdKey = mkPreludeMiscIdUnique 307
+interruptibleIdKey = mkPreludeMiscIdUnique 308
 
 -- data InlineSpec =
 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique