diff options
Diffstat (limited to 'lib/Language/Elna/PrinterWriter.hs')
| -rw-r--r-- | lib/Language/Elna/PrinterWriter.hs | 158 |
1 files changed, 109 insertions, 49 deletions
diff --git a/lib/Language/Elna/PrinterWriter.hs b/lib/Language/Elna/PrinterWriter.hs index 38c3549..95923cf 100644 --- a/lib/Language/Elna/PrinterWriter.hs +++ b/lib/Language/Elna/PrinterWriter.hs @@ -4,6 +4,7 @@ module Language.Elna.PrinterWriter , riscv32Header ) where +import Data.Word (Word8) import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Builder as ByteString.Builder @@ -12,6 +13,7 @@ import Data.Vector (Vector) import qualified Data.Vector as Vector import Language.Elna.Object.Elf ( ByteOrder(..) + , Elf32_Addr , Elf32_Ehdr(..) , Elf32_Half , Elf32_Sym(..) @@ -25,15 +27,21 @@ import Language.Elna.Object.Elf , ElfSectionType(..) , ElfSymbolBinding(..) , ElfSymbolType(..) + , Elf32_Rel (..) , elf32Sym , elfHeaderSize , elfSectionsSize , stInfo + , rInfo + , elf32Rel + , shfInfoLink ) import System.IO (Handle) import qualified Language.Elna.Architecture.RiscV as RiscV +import qualified Data.Text.Encoding as Text.Encoding 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 = @@ -50,6 +58,7 @@ riscv32Elf code objectHandle = , sh_addr = 0 } in text (ElfHeaderResult "\0" $ Vector.singleton zeroHeader) + >>= symstrtab >>= shstrtab >>= finalize where @@ -71,58 +80,86 @@ riscv32Elf code objectHandle = ByteString.hPut objectHandle stringTable pure $ ElfHeaderResult stringTable $ Vector.snoc headers nextHeader - strtab stringTable (ElfHeaderResult names headers) = do - let newHeader = 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 + takeStringZ stringTable Elf32_Sym{ st_name } + = ByteString.takeWhile (/= 0) + $ ByteString.drop (fromIntegral st_name) stringTable + resolveRelocation (ElfHeaderResult stringTable entries) unresolvedRelocation + | UnresolvedRelocation symbolName offset type' <- unresolvedRelocation + , Just entry <- Vector.findIndex ((== symbolName) . takeStringZ stringTable) entries = + Right $ Elf32_Rel + { r_offset = offset + , r_info = rInfo (fromIntegral entry) type' } - ByteString.hPut objectHandle stringTable - pure $ ElfHeaderResult (names <> ".strtab\0") - $ Vector.snoc headers newHeader - symtab strtabIndex entries (ElfHeaderResult names headers) = do - let encoded = LazyByteString.toStrict + | otherwise = Left unresolvedRelocation + symstrtab (symbols@(ElfHeaderResult stringTable entries), ElfHeaderResult names headers, relocations) = do + let encodedSymbols = LazyByteString.toStrict $ ByteString.Builder.toLazyByteString $ foldMap (elf32Sym LSB) entries - newHeader = Elf32_Shdr + namesLength = fromIntegral $ ByteString.length names + symHeader = Elf32_Shdr { sh_type = SHT_SYMTAB - , sh_size = fromIntegral $ ByteString.length encoded + , sh_size = fromIntegral $ ByteString.length encodedSymbols , sh_offset = elfSectionsSize headers - , sh_name = fromIntegral $ ByteString.length names - , sh_link = strtabIndex + , sh_name = namesLength + , sh_link = fromIntegral $ Vector.length headers + 2 , sh_info = 1 , sh_flags = 0 , sh_entsize = 16 , sh_addralign = 0 , sh_addr = 0 } - ByteString.hPut objectHandle encoded - pure $ ElfHeaderResult (names <> ".symtab\0") - $ Vector.snoc headers newHeader + ByteString.hPut objectHandle encodedSymbols + let headers1 = Vector.snoc headers symHeader + let y = resolveRelocation symbols <$> relocations + encodedRelocations = LazyByteString.toStrict + $ ByteString.Builder.toLazyByteString + $ Vector.foldMap (either (const mempty) (elf32Rel LSB)) y + 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 headers + , sh_info = 1 + , sh_flags = shfInfoLink + , sh_entsize = 8 + , sh_addralign = 0 + , sh_addr = 0 + } + ByteString.hPut objectHandle encodedRelocations + let headers2 = Vector.snoc headers1 relHeader + let strHeader = Elf32_Shdr + { sh_type = SHT_STRTAB + , sh_size = fromIntegral $ ByteString.length stringTable + , sh_offset = elfSectionsSize headers2 + , sh_name = namesLength + 18 + , sh_link = 0 + , sh_info = 0 + , sh_flags = 0 + , sh_entsize = 0 + , 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 - strtabIndex = fromIntegral $ textTabIndex + 2 - ElfHeaderResult stringTable entries <- symbolEntry textTabIndex code - $ ElfHeaderResult "\0" - $ Vector.singleton - $ Elf32_Sym - { st_value = 0 - , st_size = 0 - , st_shndx = 0 - , st_other = 0 - , st_name = 0 - , st_info = 0 - } + initialHeaders = ElfHeaderResult "\0" + $ Vector.singleton + $ Elf32_Sym + { st_value = 0 + , st_size = 0 + , st_shndx = 0 + , st_other = 0 + , st_name = 0 + , st_info = 0 + } + (symbolResult, size, relocations) <- symbolEntry textTabIndex code + (initialHeaders, 0, mempty) let newHeader = Elf32_Shdr { sh_type = SHT_PROGBITS - , sh_size = fromIntegral $ foldr ((+) . st_size) 0 entries + , sh_size = size , sh_offset = elfSectionsSize headers , sh_name = fromIntegral $ ByteString.length names , sh_link = 0 @@ -134,24 +171,47 @@ riscv32Elf code objectHandle = } newResult = ElfHeaderResult (names <> ".text\0") $ Vector.snoc headers newHeader - symtab strtabIndex entries newResult - >>= strtab stringTable - symbolEntry :: Elf32_Half -> Vector RiscV.Instruction -> ElfHeaderResult Elf32_Sym -> IO (ElfHeaderResult Elf32_Sym) - symbolEntry shndx instructions (ElfHeaderResult names entries) = do - let encoded = LazyByteString.toStrict - $ ByteString.Builder.toLazyByteString - $ foldMap RiscV.instruction instructions + 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) + symbolEntry shndx instructions (ElfHeaderResult names entries, offset, relocations) = do + let (encoded, size, updatedRelocations) = + Vector.foldl' encodeInstruction (mempty, offset, relocations) instructions newEntry = Elf32_Sym - { st_value = 0 - , st_size = fromIntegral $ ByteString.length encoded + { st_value = offset + , st_size = fromIntegral size , st_shndx = shndx , st_other = 0 , st_name = fromIntegral $ ByteString.length names , st_info = stInfo STB_GLOBAL STT_FUNC } - ByteString.hPut objectHandle encoded - pure $ ElfHeaderResult (names <> "_start\0") - $ Vector.snoc entries newEntry + ByteString.hPut objectHandle $ LazyByteString.toStrict encoded + let newResult = ElfHeaderResult (names <> "_start\0") + $ Vector.snoc entries newEntry + pure (newResult, size, updatedRelocations) + encodeInstruction (instructions, offset, relocations) instruction = + let unresolvedRelocation = case instruction of + RiscV.RelocatableInstruction _ instructionType + | RiscV.Higher20 _ symbolName <- instructionType + -> Just + $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 26 + | RiscV.Lower12I _ _ _ symbolName <- instructionType + -> Just + $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 27 + | RiscV.Lower12S symbolName _ _ _ <- instructionType + -> Just + $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 28 + RiscV.Instruction _ _ -> Nothing + encoded = ByteString.Builder.toLazyByteString + $ RiscV.instruction instruction + in + ( instructions <> encoded + , offset + fromIntegral (LazyByteString.length encoded) + , maybe relocations (Vector.snoc relocations) unresolvedRelocation + ) riscv32Header :: Elf32_Ehdr riscv32Header = Elf32_Ehdr |