belka/elna
1
0
Fork 0
Code Issues Pull Requests Releases Activity

Add a state monad transformer to the Elf generator

Browse Source
This commit is contained in:
Eugen Wissner 2024-09-10 02:03:20 +02:00
parent bb33423c31
commit 8a0751dfb0
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
4 changed files with 114 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
TODO
View File

@ -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

37
lib/Language/Elna/Intermediate.hs
View File

@ -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

87
lib/Language/Elna/Object/Elf.hs
View File

@ -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

87
lib/Language/Elna/PrinterWriter.hs
View File

@ -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)