diff --git a/TODO b/TODO index b358871..d790c8b 100644 --- a/TODO +++ b/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 - in the generator and put the headers into the state to reduce the number of - returned values in the tuples. +- 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 diff --git a/lib/Language/Elna/Intermediate.hs b/lib/Language/Elna/Intermediate.hs index d334661..ff2b115 100644 --- a/lib/Language/Elna/Intermediate.hs +++ b/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 diff --git a/lib/Language/Elna/Object/Elf.hs b/lib/Language/Elna/Object/Elf.hs index 7bbdccf..4e08abb 100644 --- a/lib/Language/Elna/Object/Elf.hs +++ b/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 = - let headerEncodingResult = elf32Ehdr + putContents' objectHandle + = 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 diff --git a/lib/Language/Elna/PrinterWriter.hs b/lib/Language/Elna/PrinterWriter.hs index 95923cf..5575e16 100644 --- a/lib/Language/Elna/PrinterWriter.hs +++ b/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 code objectHandle = - 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 +riscv32Elf :: Vector RiscV.Instruction -> Handle -> ElfWriter () +riscv32Elf code objectHandle = text + >>= symstrtab 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 - let headers1 = Vector.snoc headers symHeader + liftIO $ ByteString.hPut objectHandle encodedSymbols + 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 - pure $ ElfHeaderResult (names <> ".symtab\0.rel.text\0.strtab\0") - $ Vector.snoc headers2 strHeader - text (ElfHeaderResult names headers) = do - let textTabIndex = fromIntegral $ Vector.length headers + liftIO $ ByteString.hPut objectHandle stringTable + addSectionHeader ".symtab" symHeader + addSectionHeader ".rel.text" relHeader + addSectionHeader ".strtab" strHeader + 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_name = fromIntegral $ ByteString.length names + , sh_offset = elfSectionsSize sectionHeaders + , 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") - $ Vector.snoc headers newHeader - pure (symbolResult, newResult, relocations) + addSectionHeader ".text" newHeader + pure (symbolResult, 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)