add poll syscall

Makefile

@@ -6,6 +6,7 @@ EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/hello-linux-i386
 EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/hello-linux-i386-elf64
 EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/hello-linux-x86_64
 EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/symlinkat
+EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/poll
 EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/segfault
 EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/execve
 EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/execve-linux-null-envp

example-programs/poll.c

@@ -0,0 +1,58 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <fcntl.h>
+#include <sys/poll.h>
+
+#define TIMEOUT 5
+
+void die_usage(void) {
+  fprintf(stderr, "Usage: poll file\n");
+  exit(1);
+}
+
+int main (int argc, char const *argv[]) {
+  if (argc < 1) {
+    die_usage();
+  }
+
+  struct pollfd fds[3];
+  int ret;
+  int fd = open(argv[1], O_RDWR);
+
+  if (fd < 0) {
+    perror("could not open provided file");
+    return 1;
+  }
+
+  /* watch stdout for ability to write */
+  fds[0].fd = STDOUT_FILENO;
+  fds[0].events = POLLHUP | POLLOUT | POLLIN;
+
+  fds[1].fd = STDIN_FILENO;
+  fds[1].events = POLLIN;
+
+  fds[2].fd = fd;
+  fds[2].events = POLLIN | POLLOUT;
+
+  ret = poll(fds, 3, TIMEOUT * 1000);
+
+  if (ret == -1) {
+    perror("poll returned error");
+    return 1;
+  }
+
+  if (!ret) {
+    perror("poll timed out before stdout was available for write");
+    return 1;
+  }
+
+  if (fds[0].revents & POLLOUT) {
+    return 0;
+  }
+
+  perror("poll returned success response, but stdout is not available for write");
+  return 1;
+
+}
+

src/System/Hatrace.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
@@ -75,6 +76,8 @@ module System.Hatrace
   , SyscallExitDetails_set_tid_address(..)
   , SyscallEnterDetails_sysinfo(..)
   , SyscallExitDetails_sysinfo(..)
+  , SyscallEnterDetails_poll(..)
+  , SyscallExitDetails_poll(..)
   , DetailedSyscallEnter(..)
   , DetailedSyscallExit(..)
   , ERRNO(..)
@@ -125,9 +128,10 @@ import           Foreign.C.Types (CInt(..), CLong(..), CULong(..), CChar(..), CS
 import           Foreign.ForeignPtr (withForeignPtr)
 import           Foreign.Marshal.Alloc (alloca)
 import           Foreign.Marshal.Array (withArray)
+import qualified Foreign.Marshal.Array (peekArray)
 import           Foreign.Marshal.Utils (withMany)
-import           Foreign.Ptr (Ptr, nullPtr, wordPtrToPtr)
-import           Foreign.Storable (peekByteOff, sizeOf)
+import           Foreign.Ptr (castPtr, Ptr, nullPtr, wordPtrToPtr)
+import           Foreign.Storable (Storable, peekByteOff, sizeOf)
 import           GHC.Stack (HasCallStack, callStack, getCallStack, prettySrcLoc)
 import           System.Directory (canonicalizePath, doesFileExist, findExecutable)
 import           System.Exit (ExitCode(..), die)
@@ -949,6 +953,24 @@ instance SyscallExitFormatting SyscallExitDetails_brk where
   syscallExitToFormatted SyscallExitDetails_brk{ enterDetail, brkResult } =
     (syscallEnterToFormatted enterDetail, formatReturn brkResult)
 
+data SyscallEnterDetails_poll = SyscallEnterDetails_poll
+  { fds :: Ptr PollFdStruct
+  , nfds :: CULong
+  , timeout :: CInt
+  } deriving (Eq, Ord, Show)
+
+instance SyscallEnterFormatting SyscallEnterDetails_poll where
+  syscallEnterToFormatted SyscallEnterDetails_poll{ fds, nfds, timeout} =
+    FormattedSyscall "poll" [formatPtrArg "pollfd" fds, formatArg nfds, formatArg timeout]
+
+data SyscallExitDetails_poll = SyscallExitDetails_poll
+  { enterDetail :: SyscallEnterDetails_poll
+  , pollfds :: [PollFdStruct]
+  } deriving (Eq, Ord, Show)
+
+instance SyscallExitFormatting SyscallExitDetails_poll where
+  syscallExitToFormatted SyscallExitDetails_poll{ enterDetail, pollfds } =
+    (syscallEnterToFormatted enterDetail, formatReturn pollfds)
 
 data ArchPrctlAddrArg
   = ArchPrctlAddrArgVal CULong
@@ -1053,6 +1075,7 @@ data DetailedSyscallEnter
   | DetailedSyscallEnter_arch_prctl SyscallEnterDetails_arch_prctl
   | DetailedSyscallEnter_set_tid_address SyscallEnterDetails_set_tid_address
   | DetailedSyscallEnter_sysinfo SyscallEnterDetails_sysinfo
+  | DetailedSyscallEnter_poll SyscallEnterDetails_poll
   | DetailedSyscallEnter_unimplemented Syscall SyscallArgs
   deriving (Eq, Ord, Show)
 
@@ -1085,6 +1108,7 @@ data DetailedSyscallExit
   | DetailedSyscallExit_arch_prctl SyscallExitDetails_arch_prctl
   | DetailedSyscallExit_set_tid_address SyscallExitDetails_set_tid_address
   | DetailedSyscallExit_sysinfo SyscallExitDetails_sysinfo
+  | DetailedSyscallExit_poll SyscallExitDetails_poll
   | DetailedSyscallExit_unimplemented Syscall SyscallArgs Word64
   deriving (Eq, Ord, Show)
 
@@ -1364,6 +1388,14 @@ getSyscallEnterDetails syscall syscallArgs pid = let proc = TracedProcess pid in
     pure $ DetailedSyscallEnter_set_tid_address $ SyscallEnterDetails_set_tid_address
       { tidptr
       } 
+  Syscall_poll -> do
+    let SyscallArgs{ arg0 = pollfdAddr, arg1 = nfds, arg2 = timeout } = syscallArgs
+    let pollfdPtr = word64ToPtr pollfdAddr
+    pure $ DetailedSyscallEnter_poll $ SyscallEnterDetails_poll
+      { fds = pollfdPtr
+      , nfds = fromIntegral nfds
+      , timeout = fromIntegral timeout
+      }
   _ -> pure $ DetailedSyscallEnter_unimplemented (KnownSyscall syscall) syscallArgs
 
 
@@ -1550,9 +1582,29 @@ getSyscallExitDetails' knownSyscall syscallArgs result pid =
                 pure $ DetailedSyscallExit_sysinfo $
                   SyscallExitDetails_sysinfo{ enterDetail, sysinfo }
 
+            DetailedSyscallEnter_poll
+              enterDetail@SyscallEnterDetails_poll{ fds, nfds } -> do
+                -- This capping to max int below is a consequence of nfds var being a long,
+                -- while peekArray taking as an argument just an int. The assumption made
+                -- in here is that the number of checked fds will be less than max int.
+                let n = fromIntegral $ min nfds $ fromIntegral (maxBound :: Int)
+                pollfds <- peekArray (TracedProcess pid) n fds
+                pure $ DetailedSyscallExit_poll $
+                  SyscallExitDetails_poll{ enterDetail, pollfds }
+
             DetailedSyscallEnter_unimplemented syscall _syscallArgs ->
               pure $ DetailedSyscallExit_unimplemented syscall syscallArgs result
 
+peekArray :: Storable a => TracedProcess -> Int -> Ptr a -> IO [a]
+peekArray pid size ptr
+  | size <= 0 = return []
+  | otherwise = do
+      arrayBytes <- Ptrace.peekBytes pid ptr (size * elemSize)
+      let (tmpPtr, _, _) = BSI.toForeignPtr arrayBytes
+      withForeignPtr tmpPtr (\p -> Foreign.Marshal.Array.peekArray size (castPtr p))
+      where
+        elemSize = sizeOf ptr
+
 readPipeFds :: CPid -> Ptr CInt -> IO (CInt, CInt)
 readPipeFds pid pipefd = do
   let fdSize = sizeOf (undefined :: CInt)
@@ -1940,6 +1992,8 @@ formatSyscallEnter syscall syscallArgs pid =
 
         DetailedSyscallEnter_exit_group details -> syscallEnterToFormatted details
 
+        DetailedSyscallEnter_poll details -> syscallEnterToFormatted details
+
         DetailedSyscallEnter_unimplemented unimplementedSyscall unimplementedSyscallArgs ->
           FormattedSyscall ("unimplemented_syscall_details(" ++ show unimplementedSyscall ++ ")")
                            (unimplementedArgs unimplementedSyscallArgs)
@@ -2035,6 +2089,8 @@ formatDetailedSyscallExit detailedExit handleUnimplemented =
 
     DetailedSyscallExit_exit_group details -> formatDetails details
 
+    DetailedSyscallExit_poll details -> formatDetails details
+
     DetailedSyscallExit_unimplemented syscall syscallArgs result ->
       handleUnimplemented syscall syscallArgs result
 

src/System/Hatrace/Format.hs

@@ -25,7 +25,7 @@ import qualified Data.Text.Encoding.Error as TE
 import           Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import           Data.Void (Void)
 import           Data.Word (Word64)
-import           Foreign.C.Types (CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..), CSize(..), CTime(..))
+import           Foreign.C.Types (CShort(..), CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..), CSize(..), CTime(..))
 import           Foreign.Ptr (Ptr, nullPtr, ptrToIntPtr)
 import           System.Posix.Types (CMode(..))
 
@@ -60,6 +60,9 @@ instance ArgFormatting Word64 where
 instance ArgFormatting CUShort where
   formatArg = IntegerArg . fromIntegral
 
+instance ArgFormatting CShort where
+  formatArg = IntegerArg . fromIntegral
+
 instance ArgFormatting CInt where
   formatArg = IntegerArg . fromIntegral
 

src/System/Hatrace/Types.hsc

@@ -1,8 +1,10 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 #include <unistd.h>
 #include <sys/stat.h>
 #include <sys/sysinfo.h>
 #include <asm/prctl.h>
+#include <poll.h>
 
 module System.Hatrace.Types
   ( FileAccessMode(..)
@@ -11,13 +13,14 @@ module System.Hatrace.Types
   , StatStruct(..)
   , TimespecStruct(..)
   , ArchPrctlSubfunction(..)
+  , PollFdStruct(..)
   , CIntRepresentable(..)
   , SysinfoStruct(..)
   ) where
 
 import           Data.Bits
 import           Data.List (intercalate)
-import           Foreign.C.Types (CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..))
+import           Foreign.C.Types (CShort(..), CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..))
 import           Foreign.Marshal.Array (peekArray, pokeArray)
 import           Foreign.Ptr (plusPtr)
 import           Foreign.Storable (Storable(..))
@@ -28,6 +31,10 @@ class CIntRepresentable a where
   toCInt :: a -> CInt
   fromCInt :: CInt -> a
 
+class CShortRepresentable a where
+  toCShort :: a -> CShort
+  fromCShort :: CShort -> a
+
 data FileAccessMode
   = FileAccessKnown GranularAccessMode
   | FileAccessUnknown CInt
@@ -259,3 +266,136 @@ instance Storable SysinfoStruct where
     #{poke struct sysinfo, totalhigh} p totalhigh
     #{poke struct sysinfo, freehigh} p freehigh
     #{poke struct sysinfo, mem_unit} p mem_unit
+
+data PollFdStruct = PollFdStruct
+  { fd      :: CInt
+  , events  :: PollEvents
+  , revents :: PollEvents
+  } deriving (Eq, Ord, Show)
+
+instance Storable PollFdStruct where
+  sizeOf _ = #{size struct pollfd}
+  alignment _ = #{alignment struct pollfd}
+  peek p = do
+    fd <- #{peek struct pollfd, fd} p
+    events <- fromCShort <$> #{peek struct pollfd, events} p
+    revents <- fromCShort <$> #{peek struct pollfd, revents} p
+    return PollFdStruct{ fd = fd
+                       , events = events
+                       , revents = revents
+                       }
+  poke p PollFdStruct{..} = do
+    #{poke struct pollfd, fd} p fd
+    #{poke struct pollfd, events} p (toCShort events)
+    #{poke struct pollfd, revents} p (toCShort revents)
+
+instance ArgFormatting PollFdStruct where
+  formatArg PollFdStruct {..} =
+    StructArg [ ("fd", formatArg fd)
+              , ("events", formatArg events)
+              , ("revents", formatArg revents)
+              ]
+
+data PollEvents = PollEventsKnown GranularPollEvents
+                | PollEventsUnknown CShort deriving (Eq, Ord, Show)
+
+instance ArgFormatting PollEvents where
+  formatArg = FixedStringArg . formatMode
+    where
+      formatMode (PollEventsKnown gpe) =
+        let granularPollEvents =
+              [ "POLLIN" | pollin gpe ] ++
+              [ "POLLPRI" | pollpri gpe ] ++
+              [ "POLLOUT" | pollout gpe ] ++
+#ifdef _GNU_SOURCE
+              [ "POLLRDHUP" | pollrdhup gpe ] ++
+#endif
+              [ "POLLERR" | pollerr gpe ] ++
+              [ "POLLHUP" | pollhup gpe ] ++
+              [ "POLLNVAL" | pollnval gpe ] ++
+#ifdef _XOPEN_SOURCE
+              [ "POLLRDNORM" | pollrdnorm gpe ] ++
+              [ "POLLRDBAND" | pollrdband gpe ] ++
+              [ "POLLWRNORM" | pollwrnorm gpe ] ++
+              [ "POLLWRBAND" | pollwrband gpe ] ++
+#endif
+              []
+        in if null granularPollEvents then "0" else intercalate "|" granularPollEvents
+      formatMode (PollEventsUnknown x) = show x
+
+-- |Only explicitly defined in man pages poll bits are currently used.
+data GranularPollEvents = GranularPollEvents
+  { pollin :: Bool
+  , pollpri :: Bool
+  , pollout :: Bool
+#ifdef _GNU_SOURCE
+  , pollrdhup :: Bool
+#endif
+  , pollerr :: Bool
+  , pollhup :: Bool
+  , pollnval :: Bool
+#ifdef _XOPEN_SOURCE
+  , pollrdnorm :: Bool
+  , pollrdband :: Bool
+  , pollwrnorm :: Bool
+  , pollwrband :: Bool
+#endif
+  } deriving (Eq, Ord, Show)
+
+instance CShortRepresentable PollEvents where
+  toCShort (PollEventsKnown gpe) = foldr (.|.) (fromIntegral (0 :: Int)) setBits
+    where
+      setBits =
+        [ if pollin gpe then (#const POLLIN) else 0
+        , if pollpri gpe then (#const POLLPRI) else 0
+        , if pollout gpe then (#const POLLOUT) else 0
+#ifdef _GNU_SOURCE
+        , if pollrdhup gpe then (#const POLLRDHUP) else 0
+#endif
+        , if pollerr gpe then (#const POLLERR) else 0
+        , if pollhup gpe then (#const POLLHUP) else 0
+        , if pollnval gpe then (#const POLLNVAL) else 0
+#ifdef _XOPEN_SOURCE
+        , if pollrdnorm gpe then (#const POLLRDNORM) else 0
+        , if pollrdband gpe then (#const POLLRDBAND) else 0
+        , if pollwrnorm gpe then (#const POLLWRNORM) else 0
+        , if pollwrband gpe then (#const POLLWRBAND) else 0
+#endif
+        ]
+  toCShort (PollEventsUnknown x) = x
+  fromCShort m | (m .&. complement pollEventsBits) /= zeroBits = PollEventsUnknown m
+               | otherwise =
+                  let isset f = (m .&. f) /= zeroBits
+                  in PollEventsKnown GranularPollEvents
+                     { pollin = isset (#const POLLIN)
+                     , pollpri = isset (#const POLLPRI)
+                     , pollout = isset (#const POLLOUT)
+#ifdef _GNU_SOURCE
+                     , pollrdhup = isset (#const POLLRDHUP)
+#endif
+                     , pollerr = isset (#const POLLERR)
+                     , pollhup = isset (#const POLLHUP)
+                     , pollnval = isset (#const POLLNVAL)
+#ifdef _XOPEN_SOURCE
+                     , pollrdnorm = isset (#const POLLRDNORM)
+                     , pollrdband = isset (#const POLLRDBAND)
+                     , pollwrnorm = isset (#const POLLWRNORM)
+                     , pollwrband = isset (#const POLLWRBAND)
+#endif
+                     }
+    where
+      pollEventsBits = (#const POLLIN)
+                     .|. (#const POLLPRI)
+                     .|. (#const POLLOUT)
+#ifdef _GNU_SOURCE
+                     .|. (#const POLLRDHUP)
+#endif
+                     .|. (#const POLLERR)
+                     .|. (#const POLLHUP)
+                     .|. (#const POLLNVAL)
+#ifdef _XOPEN_SOURCE
+                     .|. (#const POLLRDNORM)
+                     .|. (#const POLLRDBAND)
+                     .|. (#const POLLWRNORM)
+                     .|. (#const POLLWRBAND)
+#endif