Pass relocation base table

TODO

@@ -8,11 +8,3 @@
 
 - Don't ignore relocations where the symbol is not defined in the symbol table.
   Report an error about an undefined symbol.
-- elfObject always uses LSB. It should decide the byte order based on the ELF
-  header.
-- Relocation section header relates to another section (e.g. .rel.text). The
-  index of that section should be passed together with collected relocations.
-- symstrtab creates 3 section headers and does some math to calculate the
-  offsets and names. Introducing the state monad can help to get rid of magic
-  numbers.
-- The final reutrn value of the state monad should be the Elf header.

lib/Language/Elna/Object/Elf.hs

@@ -412,7 +412,7 @@ elfIdentification (ElfIdentification elfClass elfData)
     <> ByteString.Builder.byteString (ByteString.replicate 9 0)
 
 elf32Ehdr :: Elf32_Ehdr -> Either ElfEncodingError ByteString.Builder.Builder
-elf32Ehdr Elf32_Ehdr{..} = encode <$> byteOrder
+elf32Ehdr Elf32_Ehdr{..} = encode <$> byteOrder e_ident
   where
     encode byteOrder'
         = elfIdentification e_ident
@@ -429,45 +429,46 @@ elf32Ehdr Elf32_Ehdr{..} = encode <$> byteOrder
         <> elf32Half byteOrder' e_shentsize
         <> elf32Half byteOrder' e_shnum
         <> elf32Half byteOrder' e_shstrndx
-    byteOrder
-        | ElfIdentification class' _ <- e_ident
-        , class' /= ELFCLASS32 = Left $ ElfUnsupportedClassError class'
-        | ElfIdentification _ ELFDATA2MSB <- e_ident = Right MSB
-        | ElfIdentification _ ELFDATA2LSB <- e_ident = Right LSB
-        | ElfIdentification _ ELFDATANONE <- e_ident = Left ElfInvalidByteOrderError
+
+byteOrder :: ElfIdentification -> Either ElfEncodingError ByteOrder
+byteOrder (ElfIdentification class' _)
+    | class' /= ELFCLASS32 = Left $ ElfUnsupportedClassError class'
+byteOrder (ElfIdentification _ ELFDATA2MSB) = Right MSB
+byteOrder (ElfIdentification _ ELFDATA2LSB) = Right LSB
+byteOrder (ElfIdentification _ ELFDATANONE) = Left ElfInvalidByteOrderError
 
 elf32Shdr :: ByteOrder -> Elf32_Shdr -> ByteString.Builder.Builder
-elf32Shdr byteOrder Elf32_Shdr{..}
-    = elf32Word byteOrder sh_name
-    <> elf32Word byteOrder (fromIntegralEnum sh_type)
-    <> elf32Word byteOrder sh_flags
-    <> elf32Addr byteOrder sh_addr
-    <> elf32Off byteOrder sh_offset
-    <> elf32Word byteOrder sh_size
-    <> elf32Word byteOrder sh_link
-    <> elf32Word byteOrder sh_info
-    <> elf32Word byteOrder sh_addralign
-    <> elf32Word byteOrder sh_entsize
+elf32Shdr byteOrder' Elf32_Shdr{..}
+    = elf32Word byteOrder' sh_name
+    <> elf32Word byteOrder' (fromIntegralEnum sh_type)
+    <> elf32Word byteOrder' sh_flags
+    <> elf32Addr byteOrder' sh_addr
+    <> elf32Off byteOrder' sh_offset
+    <> elf32Word byteOrder' sh_size
+    <> elf32Word byteOrder' sh_link
+    <> elf32Word byteOrder' sh_info
+    <> elf32Word byteOrder' sh_addralign
+    <> elf32Word byteOrder' sh_entsize
 
 elf32Sym :: ByteOrder -> Elf32_Sym -> ByteString.Builder.Builder
-elf32Sym byteOrder Elf32_Sym{..}
-    = elf32Word byteOrder st_name
-    <> elf32Addr byteOrder st_value
-    <> elf32Word byteOrder st_size
+elf32Sym byteOrder' Elf32_Sym{..}
+    = elf32Word byteOrder' st_name
+    <> elf32Addr byteOrder' st_value
+    <> elf32Word byteOrder' st_size
     <> ByteString.Builder.word8 st_info
     <> ByteString.Builder.word8 st_other
-    <> elf32Half byteOrder st_shndx
+    <> elf32Half byteOrder' st_shndx
 
 elf32Rel :: ByteOrder -> Elf32_Rel -> ByteString.Builder.Builder
-elf32Rel byteOrder Elf32_Rel{..}
-    = elf32Addr byteOrder r_offset 
-    <> elf32Word byteOrder r_info
+elf32Rel byteOrder' Elf32_Rel{..}
+    = elf32Addr byteOrder' r_offset
+    <> elf32Word byteOrder' r_info
 
 elf32Rela :: ByteOrder -> Elf32_Rela -> ByteString.Builder.Builder
-elf32Rela byteOrder Elf32_Rela{..}
-    = elf32Addr byteOrder r_offset 
-    <> elf32Word byteOrder r_info
-    <> elf32Sword byteOrder r_addend
+elf32Rela byteOrder' Elf32_Rela{..}
+    = elf32Addr byteOrder' r_offset
+    <> elf32Word byteOrder' r_info
+    <> elf32Sword byteOrder' r_addend
 
 stInfo :: ElfSymbolBinding -> ElfSymbolType -> Word8
 stInfo binding type' = fromIntegralEnum binding `shiftL` 4
@@ -545,21 +546,17 @@ addSectionHeader name newHeader = ElfWriter $ modify' modifier
             , sectionNames = sectionNames <> name <> "\0"
             }
 
--- Writes an ELF object with the given header to the provided file path.
--- The callback writes the sections and returns headers for those sections.
---
--- It updates some of the header header according to the given headers and
--- expects .shstrtab be the last header in the list.
-elfObject :: FilePath -> Elf32_Ehdr -> (Handle -> ElfWriter ()) -> IO ()
-elfObject outFile header putContents = withFile outFile WriteMode withObjectFile
+-- Writes an ELF object to the provided file path. The callback writes the
+-- sections, collects headers for those sections and returns the ELF header.
+elfObject :: FilePath -> (Handle -> ElfWriter Elf32_Ehdr) -> IO ()
+elfObject outFile putContents = withFile outFile WriteMode withObjectFile
   where
     withObjectFile objectHandle
         = hSeek objectHandle AbsoluteSeek (fromIntegral elfHeaderSize)
         >> putContents' objectHandle
-        >>= afterContents objectHandle
+        >>= uncurry (afterContents objectHandle)
     putContents' objectHandle
-        = fmap snd
-        $ flip runStateT initialState
+        = flip runStateT initialState
         $ runElfWriter
         $ putContents objectHandle
     zeroHeader = Elf32_Shdr
@@ -578,30 +575,13 @@ elfObject outFile header putContents = withFile outFile WriteMode withObjectFile
         { sectionHeaders = Vector.singleton zeroHeader
         , sectionNames = "\0"
         }
-    afterContents objectHandle ElfHeaderResult{..} =
-        let stringTable = sectionNames <> ".shstrtab\0"
-            nextHeader = Elf32_Shdr
-                { sh_type = SHT_STRTAB
-                , sh_size = fromIntegral $ ByteString.length stringTable
-                , sh_offset = elfSectionsSize sectionHeaders
-                , sh_name = fromIntegral $ ByteString.length sectionNames
-                , sh_link = 0
-                , sh_info = 0
-                , sh_flags = 0
-                , sh_entsize = 0
-                , sh_addralign = 0
-                , sh_addr = 0
-                }
-            headers = Vector.snoc sectionHeaders nextHeader
-            headerEncodingResult = elf32Ehdr
-                $ header
-                    { e_shoff = elfSectionsSize headers
-                    , e_shnum = fromIntegral $ Vector.length headers
-                    , e_shstrndx = fromIntegral (Vector.length headers) - 1
-                    }
-         in ByteString.hPut objectHandle stringTable
-            >> traverse_ (ByteString.Builder.hPutBuilder objectHandle . elf32Shdr LSB) headers
-            >> either throwIO (putHeaders objectHandle) headerEncodingResult
+    afterContents objectHandle header ElfHeaderResult{..} =
+        let hPutBuilder = ByteString.Builder.hPutBuilder objectHandle
+            writeSectionHeaders byteOrder' =
+                traverse_ (hPutBuilder . elf32Shdr byteOrder') sectionHeaders
+         in either throwIO pure (byteOrder (e_ident header))
+            >>= writeSectionHeaders
+            >> either throwIO (putHeaders objectHandle) (elf32Ehdr header)
     putHeaders objectHandle encodedHeader
         = hSeek objectHandle AbsoluteSeek 0
         >> ByteString.Builder.hPutBuilder objectHandle encodedHeader

lib/Language/Elna/PrinterWriter.hs

@@ -1,7 +1,6 @@
 -- | Writer assembler to an object file.
 module Language.Elna.PrinterWriter
     ( riscv32Elf
-    , riscv32Header
     ) where
 
 import Data.Word (Word8)
@@ -16,6 +15,7 @@ import Language.Elna.Object.Elf
     , Elf32_Addr
     , Elf32_Ehdr(..)
     , Elf32_Half
+    , Elf32_Word
     , Elf32_Sym(..)
     , ElfMachine(..)
     , ElfType(..)
@@ -28,6 +28,8 @@ import Language.Elna.Object.Elf
     , ElfSymbolBinding(..)
     , ElfSymbolType(..)
     , Elf32_Rel(..)
+    , ElfWriter(..)
+    , ElfHeaderResult(..)
     , elf32Sym
     , elfHeaderSize
     , elfSectionsSize
@@ -35,8 +37,6 @@ import Language.Elna.Object.Elf
     , rInfo
     , elf32Rel
     , shfInfoLink
-    , ElfWriter(..)
-    , ElfHeaderResult(..)
     , addSectionHeader
     )
 import System.IO (Handle)
@@ -46,11 +46,53 @@ import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.State (get)
 
 data UnresolvedRelocation = UnresolvedRelocation ByteString Elf32_Addr Word8
+data UnresolvedRelocations = UnresolvedRelocations (Vector UnresolvedRelocation) Elf32_Word
 
-riscv32Elf :: Vector RiscV.Instruction -> Handle -> ElfWriter ()
+riscv32Elf :: Vector RiscV.Instruction -> Handle -> ElfWriter Elf32_Ehdr
 riscv32Elf code objectHandle = text
-    >>= symstrtab
+    >>= uncurry symrel
+    >>= strtab
+    >> shstrtab
+    >>= riscv32Header
   where
+    shstrtab :: ElfWriter Elf32_Half
+    shstrtab = do
+        ElfHeaderResult{..} <- ElfWriter get
+        let stringTable = sectionNames <> ".shstrtab\0"
+            nextHeader = Elf32_Shdr
+                { sh_type = SHT_STRTAB
+                , sh_size = fromIntegral $ ByteString.length stringTable
+                , sh_offset = elfSectionsSize sectionHeaders
+                , sh_name = fromIntegral $ ByteString.length sectionNames
+                , sh_link = 0
+                , sh_info = 0
+                , sh_flags = 0
+                , sh_entsize = 0
+                , sh_addralign = 1
+                , sh_addr = 0
+                }
+        liftIO $ ByteString.hPut objectHandle stringTable
+        addSectionHeader ".shstrtab" nextHeader
+        pure $ fromIntegral $ Vector.length sectionHeaders
+    riscv32Header :: Elf32_Half -> ElfWriter Elf32_Ehdr
+    riscv32Header shstrndx = do
+        ElfHeaderResult{..} <- ElfWriter get
+        pure $ Elf32_Ehdr
+            { e_version = EV_CURRENT
+            , e_type = ET_REL
+            , e_shstrndx = shstrndx
+            , e_shoff = elfSectionsSize sectionHeaders
+            , e_shnum = fromIntegral (Vector.length sectionHeaders)
+            , e_shentsize = 40
+            , e_phoff = 0
+            , e_phnum = 0
+            , e_phentsize = 32
+            , e_machine = EM_RISCV
+            , e_ident = ElfIdentification ELFCLASS32 ELFDATA2LSB
+            , e_flags = 0x4 -- EF_RISCV_FLOAT_ABI_DOUBLE
+            , e_entry = 0
+            , e_ehsize = fromIntegral elfHeaderSize
+            }
     takeStringZ stringTable Elf32_Sym{ st_name }
         = ByteString.takeWhile (/= 0)
         $ ByteString.drop (fromIntegral st_name) stringTable
@@ -62,59 +104,67 @@ riscv32Elf code objectHandle = text
                 , r_info = rInfo (fromIntegral entry) type'
                 }
         | otherwise = Left unresolvedRelocation
-    symstrtab (symbols@(ElfHeaderResult stringTable entries), relocations) = do
+    symtab entries = do 
         ElfHeaderResult{..} <- ElfWriter get
         let encodedSymbols = LazyByteString.toStrict
                 $ ByteString.Builder.toLazyByteString
                 $ foldMap (elf32Sym LSB) entries 
-            namesLength = fromIntegral $ ByteString.length sectionNames
             symHeader = Elf32_Shdr
                 { sh_type = SHT_SYMTAB
                 , sh_size = fromIntegral $ ByteString.length encodedSymbols
                 , sh_offset = elfSectionsSize sectionHeaders
-                , sh_name = namesLength
+                , sh_name = fromIntegral $ ByteString.length sectionNames
                 , sh_link = fromIntegral $ Vector.length sectionHeaders + 2
                 , sh_info = 1
                 , sh_flags = 0
                 , sh_entsize = 16
-                , sh_addralign = 0
+                , sh_addralign = 4
                 , sh_addr = 0
                 }
         liftIO $ ByteString.hPut objectHandle encodedSymbols
-        let headers1 = Vector.snoc sectionHeaders symHeader
-        let y = resolveRelocation symbols <$> relocations
-            encodedRelocations = LazyByteString.toStrict
+        addSectionHeader ".symtab" symHeader
+        pure $ fromIntegral $ Vector.length sectionHeaders
+    symrel symbols relocations = do
+        let UnresolvedRelocations relocationList index = relocations
+            ElfHeaderResult stringTable entries = symbols
+
+        sectionHeadersLength <- symtab entries
+        ElfHeaderResult{..} <- ElfWriter get
+
+        let encodedRelocations = LazyByteString.toStrict
                 $ ByteString.Builder.toLazyByteString
-                $ Vector.foldMap (either (const mempty) (elf32Rel LSB)) y
+                $ Vector.foldMap (either (const mempty) (elf32Rel LSB))
+                $ resolveRelocation symbols <$> relocationList
             relHeader = Elf32_Shdr
                 { sh_type = SHT_REL
                 , sh_size = fromIntegral $ ByteString.length encodedRelocations
-                , sh_offset = elfSectionsSize headers1
-                , sh_name = namesLength + 8
-                , sh_link = fromIntegral $ Vector.length sectionHeaders
-                , sh_info = 1
+                , sh_offset = elfSectionsSize sectionHeaders
+                , sh_name = fromIntegral $ ByteString.length sectionNames
+                , sh_link = sectionHeadersLength
+                , sh_info = index
                 , sh_flags = shfInfoLink
                 , sh_entsize = 8
-                , sh_addralign = 0
+                , sh_addralign = 4
                 , sh_addr = 0
                 }
         liftIO $ ByteString.hPut objectHandle encodedRelocations
-        let headers2 = Vector.snoc headers1 relHeader
+        addSectionHeader ".rel.text" relHeader
+        pure stringTable
+    strtab stringTable = do
+        ElfHeaderResult{..} <- ElfWriter get
         let strHeader = Elf32_Shdr
                 { sh_type = SHT_STRTAB
                 , sh_size = fromIntegral $ ByteString.length stringTable
-                , sh_offset = elfSectionsSize headers2
-                , sh_name = namesLength + 18
+                , sh_offset = elfSectionsSize sectionHeaders
+                , sh_name = fromIntegral $ ByteString.length sectionNames
                 , sh_link = 0
                 , sh_info = 0
                 , sh_flags = 0
                 , sh_entsize = 0
-                , sh_addralign = 0
+                , sh_addralign = 1
                 , sh_addr = 0
                 }
         liftIO $ ByteString.hPut objectHandle stringTable
-        addSectionHeader ".symtab" symHeader
-        addSectionHeader ".rel.text" relHeader
         addSectionHeader ".strtab" strHeader
     text = do
         ElfHeaderResult{..} <- ElfWriter get
@@ -140,11 +190,11 @@ riscv32Elf code objectHandle = text
                 , sh_info = 0
                 , sh_flags = 0b110
                 , sh_entsize = 0
-                , sh_addralign = 0
+                , sh_addralign = 4
                 , sh_addr = 0
                 }
         addSectionHeader ".text" newHeader
-        pure (symbolResult, relocations)
+        pure (symbolResult, UnresolvedRelocations relocations $ fromIntegral $ Vector.length sectionHeaders)
     symbolEntry
         :: Elf32_Half
         -> Vector RiscV.Instruction
@@ -169,13 +219,13 @@ riscv32Elf code objectHandle = text
         let unresolvedRelocation = case instruction of
                 RiscV.RelocatableInstruction _ instructionType
                     | RiscV.Higher20 _ symbolName <- instructionType
-                        -> Just
+                        -> Just -- R_RISCV_HI20
                         $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 26
                     | RiscV.Lower12I _ _ _ symbolName <- instructionType
-                        -> Just
+                        -> Just -- R_RISCV_LO12_I
                         $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 27
                     | RiscV.Lower12S symbolName _ _ _ <- instructionType
-                        -> Just
+                        -> Just -- R_RISCV_LO12_S
                         $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 28
                 RiscV.Instruction _ _ -> Nothing
             encoded = ByteString.Builder.toLazyByteString
@@ -185,21 +235,3 @@ riscv32Elf code objectHandle = text
             , offset + fromIntegral (LazyByteString.length encoded)
             , maybe relocations (Vector.snoc relocations) unresolvedRelocation
             )
-
-riscv32Header :: Elf32_Ehdr
-riscv32Header = Elf32_Ehdr
-    { e_version = EV_CURRENT
-    , e_type = ET_REL
-    , e_shstrndx = 2 -- String table. SHN_UNDEF
-    , e_shoff = 0
-    , e_shnum = 0
-    , e_shentsize = 40
-    , e_phoff = 0
-    , e_phnum = 0
-    , e_phentsize = 32
-    , e_machine = EM_RISCV
-    , e_ident = ElfIdentification ELFCLASS32 ELFDATA2LSB
-    , e_flags = 0x4 -- EF_RISCV_FLOAT_ABI_DOUBLE
-    , e_entry = 0
-    , e_ehsize = fromIntegral elfHeaderSize
-    }

src/Main.hs

@@ -3,7 +3,7 @@ module Main
     ) where
 
 import Language.Elna.CommandLine (CommandLine(..), commandLine, execParser)
-import Language.Elna.PrinterWriter (riscv32Elf, riscv32Header)
+import Language.Elna.PrinterWriter (riscv32Elf)
 import Language.Elna.Object.Elf (elfObject)
 import Language.Elna.Parser (programP)
 import Language.Elna.NameAnalysis (nameAnalysis)
@@ -28,7 +28,7 @@ main  = execParser commandLine >>= withCommandLine
         let symbolTable = nameAnalysis program
             _ = typeAnalysis symbolTable program
             intermediate' = intermediate symbolTable program
-         in elfObject output riscv32Header
+         in elfObject output
             $ riscv32Elf
             $ generateCode symbolTable intermediate'
     withParsedInput _ (Left errorBundle) = putStrLn