Add a state monad transformer to the Elf generator

TODO

@@ -8,9 +8,8 @@
 
 - Don't ignore relocations where the symbol is not defined in the symbol table.
   Report an error about an undefined symbol.
-- Since every function adds a section header use a state monad
+- elfObject always uses LSB. It should decide the byte order based on the ELF
-  in the generator and put the headers into the state to reduce the number of
+  header.
-  returned values in the tuples.
 - 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

lib/Language/Elna/Intermediate.hs

@@ -23,7 +23,6 @@ intermediate _globalTable = const $ Vector.fromList [StartQuadruple, StopQuadrup
     . runIntermediate
     . program globalTable -}
 {-
-import Control.Monad.Trans.State (State, runState, gets, modify')
 import Data.Bifunctor (Bifunctor(..))
 import Data.Int (Int32)
 import Data.HashMap.Strict (HashMap)
@@ -59,42 +58,6 @@ instance Show Variable
     show (Variable variable) = '$' : Text.unpack variable
     show (TempVariable variable) = '$' : show variable
 
-data Generator = Generator
-    { labelCounter :: Int32
-    , temporaryCounter :: Int32
-    } deriving (Eq, Show)
-
-instance Semigroup Generator
-  where
-    lhs <> rhs = Generator
-        { labelCounter = getField @"labelCounter" lhs + getField @"labelCounter" rhs
-        , temporaryCounter = getField @"temporaryCounter" lhs + getField @"temporaryCounter" rhs
-        }
-
-instance Monoid Generator
-  where
-    mempty = Generator
-        { labelCounter = 0
-        , temporaryCounter = 0
-        }
-
-newtype Intermediate a = Intermediate
-    { runIntermediate :: State Generator a
-    }
-
-instance Functor Intermediate
-  where
-    fmap f (Intermediate x) = Intermediate $ f <$> x
-
-instance Applicative Intermediate
-  where
-    pure = Intermediate . pure
-    (Intermediate f) <*> (Intermediate x) = Intermediate $ f <*> x
-
-instance Monad Intermediate
-  where
-    (Intermediate x) >>= f = Intermediate $ x >>= (runIntermediate . f)
-
 data Quadruple
     = StartQuadruple
     | GoToQuadruple Label

lib/Language/Elna/Object/Elf.hs

@@ -20,6 +20,9 @@ module Language.Elna.Object.Elf
     , ElfSectionType(..)
     , ElfSymbolBinding(..)
     , ElfSymbolType(..)
+    , ElfWriter(..)
+    , ElfHeaderResult(..)
+    , addSectionHeader
     , elf32Addr
     , elf32Half
     , elf32Off
@@ -53,6 +56,9 @@ import Data.Vector (Vector)
 import qualified Data.Vector as Vector
 import System.IO (Handle, IOMode(..), SeekMode(..), hSeek, withFile)
 import Data.Foldable (traverse_)
+import Control.Monad.Trans.State (StateT, runStateT, modify')
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.ByteString (ByteString)
 
 -- * Data types.
 
@@ -494,6 +500,32 @@ fromIntegralEnum = fromIntegral . fromEnum
 
 -- * Object file generation.
 
+newtype ElfWriter a = ElfWriter
+    { runElfWriter :: StateT (ElfHeaderResult Elf32_Shdr) IO a
+    }
+
+data ElfHeaderResult a = ElfHeaderResult
+    { sectionNames :: ByteString
+    , sectionHeaders :: Vector a
+    } deriving Eq
+
+instance Functor ElfWriter
+  where
+    fmap f (ElfWriter x) = ElfWriter $ f <$> x
+
+instance Applicative ElfWriter
+  where
+    pure = ElfWriter . pure
+    (ElfWriter f) <*> (ElfWriter x) = ElfWriter $ f <*> x
+
+instance Monad ElfWriter
+  where
+    (ElfWriter x) >>= f = ElfWriter $ x >>= (runElfWriter . f)
+
+instance MonadIO ElfWriter
+  where
+    liftIO = ElfWriter . liftIO
+
 -- | ELF header size.
 elfHeaderSize :: Elf32_Off
 elfHeaderSize = 52
@@ -504,26 +536,71 @@ elfSectionsSize :: Vector Elf32_Shdr -> Elf32_Off
 elfSectionsSize = (elfHeaderSize +)
     . Vector.foldr ((+) . sh_size) 0
 
+addSectionHeader :: ByteString -> Elf32_Shdr -> ElfWriter ()
+addSectionHeader name newHeader = ElfWriter $ modify' modifier
+  where
+    modifier ElfHeaderResult{..} =
+        ElfHeaderResult
+            { sectionHeaders = Vector.snoc sectionHeaders newHeader
+            , 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 -> IO (Vector Elf32_Shdr)) -> IO ()
+elfObject :: FilePath -> Elf32_Ehdr -> (Handle -> ElfWriter ()) -> IO ()
 elfObject outFile header putContents = withFile outFile WriteMode withObjectFile
   where
     withObjectFile objectHandle
         = hSeek objectHandle AbsoluteSeek (fromIntegral elfHeaderSize)
-        >> putContents objectHandle
+        >> putContents' objectHandle
         >>= afterContents objectHandle
-    afterContents objectHandle headers =
+    putContents' objectHandle
-        let headerEncodingResult = elf32Ehdr
+        = fmap snd
+        $ flip runStateT initialState
+        $ runElfWriter
+        $ putContents objectHandle
+    zeroHeader = Elf32_Shdr
+        { sh_type = SHT_NULL
+        , sh_size = 0
+        , sh_offset = 0
+        , sh_name = 0
+        , sh_link = 0
+        , sh_info = 0
+        , sh_flags = 0
+        , sh_entsize = 0
+        , sh_addralign = 0
+        , sh_addr = 0
+        }
+    initialState = ElfHeaderResult
+        { 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 traverse_ (ByteString.Builder.hPutBuilder objectHandle . elf32Shdr LSB) headers
+         in ByteString.hPut objectHandle stringTable
+            >> traverse_ (ByteString.Builder.hPutBuilder objectHandle . elf32Shdr LSB) headers
             >> either throwIO (putHeaders objectHandle) headerEncodingResult
     putHeaders objectHandle encodedHeader
         = hSeek objectHandle AbsoluteSeek 0

lib/Language/Elna/PrinterWriter.hs

@@ -35,51 +35,22 @@ import Language.Elna.Object.Elf
     , rInfo
     , elf32Rel
     , shfInfoLink
+    , ElfWriter(..)
+    , ElfHeaderResult(..)
+    , addSectionHeader
     )
 import System.IO (Handle)
 import qualified Language.Elna.Architecture.RiscV as RiscV
 import qualified Data.Text.Encoding as Text.Encoding
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Trans.State (get)
 
-data ElfHeaderResult a = ElfHeaderResult ByteString (Vector a)
 data UnresolvedRelocation = UnresolvedRelocation ByteString Elf32_Addr Word8
 
-riscv32Elf :: Vector RiscV.Instruction -> Handle -> IO (Vector Elf32_Shdr)
+riscv32Elf :: Vector RiscV.Instruction -> Handle -> ElfWriter ()
-riscv32Elf code objectHandle =
+riscv32Elf code objectHandle = text
-    let zeroHeader = Elf32_Shdr
-            { sh_type = SHT_NULL
-            , sh_size = 0
-            , sh_offset = 0
-            , sh_name = 0
-            , sh_link = 0
-            , sh_info = 0
-            , sh_flags = 0
-            , sh_entsize = 0
-            , sh_addralign = 0
-            , sh_addr = 0
-            }
-     in text (ElfHeaderResult "\0" $ Vector.singleton zeroHeader)
     >>= symstrtab
-        >>= shstrtab
-        >>= finalize
   where
-    finalize (ElfHeaderResult _ headers) = pure headers
-    shstrtab (ElfHeaderResult names headers) = do
-        let stringTable = names <> ".shstrtab\0"
-            nextHeader = Elf32_Shdr
-                { sh_type = SHT_STRTAB
-                , sh_size = fromIntegral $ ByteString.length stringTable
-                , sh_offset = elfSectionsSize headers
-                , sh_name = fromIntegral $ ByteString.length names
-                , sh_link = 0
-                , sh_info = 0
-                , sh_flags = 0
-                , sh_entsize = 0
-                , sh_addralign = 0
-                , sh_addr = 0
-                }
-        ByteString.hPut objectHandle stringTable
-        pure $ ElfHeaderResult stringTable
-            $ Vector.snoc headers nextHeader
     takeStringZ stringTable Elf32_Sym{ st_name }
         = ByteString.takeWhile (/= 0)
         $ ByteString.drop (fromIntegral st_name) stringTable
@@ -91,25 +62,26 @@ riscv32Elf code objectHandle =
                 , r_info = rInfo (fromIntegral entry) type'
                 }
         | otherwise = Left unresolvedRelocation
-    symstrtab (symbols@(ElfHeaderResult stringTable entries), ElfHeaderResult names headers, relocations) = do
+    symstrtab (symbols@(ElfHeaderResult stringTable entries), relocations) = do
+        ElfHeaderResult{..} <- ElfWriter get
         let encodedSymbols = LazyByteString.toStrict
                 $ ByteString.Builder.toLazyByteString
                 $ foldMap (elf32Sym LSB) entries 
-            namesLength = fromIntegral $ ByteString.length names
+            namesLength = fromIntegral $ ByteString.length sectionNames
             symHeader = Elf32_Shdr
                 { sh_type = SHT_SYMTAB
                 , sh_size = fromIntegral $ ByteString.length encodedSymbols
-                , sh_offset = elfSectionsSize headers
+                , sh_offset = elfSectionsSize sectionHeaders
                 , sh_name = namesLength
-                , sh_link = fromIntegral $ Vector.length headers + 2
+                , sh_link = fromIntegral $ Vector.length sectionHeaders + 2
                 , sh_info = 1
                 , sh_flags = 0
                 , sh_entsize = 16
                 , sh_addralign = 0
                 , sh_addr = 0
                 }
-        ByteString.hPut objectHandle encodedSymbols
+        liftIO $ ByteString.hPut objectHandle encodedSymbols
-        let headers1 = Vector.snoc headers symHeader
+        let headers1 = Vector.snoc sectionHeaders symHeader
         let y = resolveRelocation symbols <$> relocations
             encodedRelocations = LazyByteString.toStrict
                 $ ByteString.Builder.toLazyByteString
@@ -119,14 +91,14 @@ riscv32Elf code objectHandle =
                 , sh_size = fromIntegral $ ByteString.length encodedRelocations
                 , sh_offset = elfSectionsSize headers1
                 , sh_name = namesLength + 8
-                , sh_link = fromIntegral $ Vector.length headers
+                , sh_link = fromIntegral $ Vector.length sectionHeaders
                 , sh_info = 1
                 , sh_flags = shfInfoLink
                 , sh_entsize = 8
                 , sh_addralign = 0
                 , sh_addr = 0
                 }
-        ByteString.hPut objectHandle encodedRelocations
+        liftIO $ ByteString.hPut objectHandle encodedRelocations
         let headers2 = Vector.snoc headers1 relHeader
         let strHeader = Elf32_Shdr
                 { sh_type = SHT_STRTAB
@@ -140,11 +112,13 @@ riscv32Elf code objectHandle =
                 , sh_addralign = 0
                 , sh_addr = 0
                 }
-        ByteString.hPut objectHandle stringTable
+        liftIO $ ByteString.hPut objectHandle stringTable
-        pure $ ElfHeaderResult (names <> ".symtab\0.rel.text\0.strtab\0")
+        addSectionHeader ".symtab" symHeader
-            $ Vector.snoc headers2 strHeader
+        addSectionHeader ".rel.text" relHeader
-    text (ElfHeaderResult names headers) = do
+        addSectionHeader ".strtab" strHeader
-        let textTabIndex = fromIntegral $ Vector.length headers
+    text = do
+        ElfHeaderResult{..} <- ElfWriter get
+        let textTabIndex = fromIntegral $ Vector.length sectionHeaders
             initialHeaders = ElfHeaderResult "\0"
                 $ Vector.singleton
                 $ Elf32_Sym
@@ -160,8 +134,8 @@ riscv32Elf code objectHandle =
         let newHeader = Elf32_Shdr
                 { sh_type = SHT_PROGBITS
                 , sh_size = size
-                , sh_offset = elfSectionsSize headers
+                , sh_offset = elfSectionsSize sectionHeaders
-                , sh_name = fromIntegral $ ByteString.length names
+                , sh_name = fromIntegral $ ByteString.length sectionNames
                 , sh_link = 0
                 , sh_info = 0
                 , sh_flags = 0b110
@@ -169,14 +143,13 @@ riscv32Elf code objectHandle =
                 , sh_addralign = 0
                 , sh_addr = 0
                 }
-            newResult = ElfHeaderResult (names <> ".text\0")
+        addSectionHeader ".text" newHeader
-                $ Vector.snoc headers newHeader
+        pure (symbolResult, relocations)
-        pure (symbolResult, newResult, relocations)
     symbolEntry
         :: Elf32_Half
         -> Vector RiscV.Instruction
         -> (ElfHeaderResult Elf32_Sym, Elf32_Addr, Vector UnresolvedRelocation)
-        -> IO (ElfHeaderResult Elf32_Sym, Elf32_Addr, Vector UnresolvedRelocation)
+        -> ElfWriter (ElfHeaderResult Elf32_Sym, Elf32_Addr, Vector UnresolvedRelocation)
     symbolEntry shndx instructions (ElfHeaderResult names entries, offset, relocations) = do
         let (encoded, size, updatedRelocations) = 
                 Vector.foldl' encodeInstruction (mempty, offset, relocations) instructions
@@ -188,7 +161,7 @@ riscv32Elf code objectHandle =
                 , st_name = fromIntegral $ ByteString.length names
                 , st_info = stInfo STB_GLOBAL STT_FUNC
                 }
-        ByteString.hPut objectHandle $ LazyByteString.toStrict encoded
+        liftIO $ ByteString.hPut objectHandle $ LazyByteString.toStrict encoded
         let newResult = ElfHeaderResult (names <> "_start\0")
                 $ Vector.snoc entries newEntry
         pure (newResult, size, updatedRelocations)