Fix Ar crashing on odd-sized object files (Trac #15396)

Summary: All the work was done by Moritz Angermann.

Test Plan: validate

Reviewers: angerman, RyanGlScott, bgamari

Reviewed By: angerman

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #15396

Differential Revision: https://phabricator.haskell.org/D5013

4 files changed, 22 insertions, 2 deletions

diff --git a/compiler/main/Ar.hs b/compiler/main/Ar.hs
index 51655c023c..9ead0535ad 100644
--- a/compiler/main/Ar.hs
+++ b/compiler/main/Ar.hs
@@ -95,7 +95,8 @@ getBSDArchEntries = do
         st_size <- getPaddedInt <$> getByteString 10
         end     <- getByteString 2
         when (end /= "\x60\x0a") $
-          fail "Invalid archive header end marker"
+          fail ("[BSD Archive] Invalid archive header end marker for name: " ++
+                C.unpack name)
         off1    <- liftM fromIntegral bytesRead :: Get Int
         -- BSD stores extended filenames, by writing #1/<length> into the
         -- name field, the first @length@ bytes then represent the file name
@@ -106,6 +107,10 @@ getBSDArchEntries = do
                         return $ C.unpack $ C.takeWhile (/= ' ') name
         off2    <- liftM fromIntegral bytesRead :: Get Int
         file    <- getByteString (st_size - (off2 - off1))
+        -- data sections are two byte aligned (see Trac #15396)
+        when (odd st_size) $
+          void (getByteString 1)
+
         rest    <- getBSDArchEntries
         return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest
 
@@ -128,8 +133,12 @@ getGNUArchEntries extInfo = do
       st_size <- getPaddedInt <$> getByteString 10
       end     <- getByteString 2
       when (end /= "\x60\x0a") $
-        fail "Invalid archive header end marker"
+        fail ("[BSD Archive] Invalid archive header end marker for name: " ++
+              C.unpack name)
       file <- getByteString st_size
+      -- data sections are two byte aligned (see Trac #15396)
+      when (odd st_size) $
+        void (getByteString 1)
       name <- return . C.unpack $
         if C.unpack (C.take 1 name) == "/"
         then case C.takeWhile (/= ' ') name of
diff --git a/testsuite/tests/driver/T15396.hs b/testsuite/tests/driver/T15396.hs
new file mode 100644
index 0000000000..9ab9f6e6e6
--- /dev/null
+++ b/testsuite/tests/driver/T15396.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Ar
+
+-- obtained from echo -n \0 > x.o && ar -q b.a x.o && cat b.a
+archive = "!<arch>\nx.o/            0           0     0     644     1         \
+\`\n0\nx.o/            0           0     0     644     1         `\n0\n"
+
+main = print (parseAr archive)
diff --git a/testsuite/tests/driver/T15396.stdout b/testsuite/tests/driver/T15396.stdout
new file mode 100644
index 0000000000..65edafad23
--- /dev/null
+++ b/testsuite/tests/driver/T15396.stdout
@@ -0,0 +1 @@
+Archive [ArchiveEntry {filename = "x.o", filetime = 0, fileown = 0, filegrp = 0, filemode = 644, filesize = 1, filedata = "0"},ArchiveEntry {filename = "x.o", filetime = 0, fileown = 0, filegrp = 0, filemode = 644, filesize = 1, filedata = "0"}]
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index 714b6c4a1a..63975981c6 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -278,3 +278,5 @@ test('T13604a', [], run_command, ['$MAKE -s --no-print-directory T13604a'])
 test('inline-check', omit_ways(['hpc', 'profasm'])
                    , compile
 		   , ['-dinline-check foo -O -ddebug-output'])
+
+test('T15396', normal, compile_and_run, ['-package ghc'])