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,70 @@
+#ifdef __linux__
+#define USE_POLL_POLLRDHUP
+#endif
+
+#ifdef USE_POLL_POLLRDHUP
+#define _GNU_SOURCE
+#endif
+
+#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;
+#ifdef USE_POLL_POLLRDHUP
+  fds[0].events = POLLHUP | POLLOUT | POLLIN | POLLRDHUP;
+#else
+  fds[0].events = POLLHUP | POLLOUT | POLLIN;
+#endif
+
+  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;
+
+}
+

hatrace.cabal

@@ -52,6 +52,12 @@ library
                      , unix
                      , unliftio
                      , unliftio-core
+  if os(linux)
+    -- On Linux with glibc, POLLRDHUP support must be enabled
+    -- manually; see `man 2 poll`. We control this with this macro.
+    -- By the way: musl libc supports POLLRDHUP unconditionally,
+    -- see https://git.musl-libc.org/cgit/musl/commit/?id=8442358d9dfc78261a5eab1f2cb13861c6e13207
+    cpp-options:         -DUSE_POLL_POLLRDHUP
   ghc-options:         -Wall
   default-language:    Haskell2010
 
@@ -83,6 +89,9 @@ test-suite hatrace-test
                      , unliftio
                      , unliftio-core
   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N
+  if os(linux)
+    -- See note on `DUSE_POLL_POLLRDHUP` above.
+    cpp-options:         -DUSE_POLL_POLLRDHUP
   default-language:    Haskell2010
 
 source-repository head

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