diff options
Diffstat (limited to 'lib/Language/Elna/RiscV/ElfWriter.hs')
| -rw-r--r-- | lib/Language/Elna/RiscV/ElfWriter.hs | 276 |
1 files changed, 276 insertions, 0 deletions
diff --git a/lib/Language/Elna/RiscV/ElfWriter.hs b/lib/Language/Elna/RiscV/ElfWriter.hs new file mode 100644 index 0000000..a83aca3 --- /dev/null +++ b/lib/Language/Elna/RiscV/ElfWriter.hs @@ -0,0 +1,276 @@ +-- | Writer assembler to an object file. +module Language.Elna.RiscV.ElfWriter + ( riscv32Elf + ) where + +import Data.Word (Word8) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Builder as ByteString.Builder +import qualified Data.ByteString.Lazy as LazyByteString +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Language.Elna.Object.Elf + ( ByteOrder(..) + , Elf32_Addr + , Elf32_Ehdr(..) + , Elf32_Half + , Elf32_Word + , Elf32_Sym(..) + , ElfMachine(..) + , ElfType(..) + , ElfVersion(..) + , ElfIdentification(..) + , ElfClass(..) + , ElfData(..) + , Elf32_Shdr(..) + , ElfSectionType(..) + , ElfSymbolBinding(..) + , ElfSymbolType(..) + , Elf32_Rel(..) + , ElfWriter(..) + , ElfHeaderResult(..) + , elf32Sym + , elfHeaderSize + , elfSectionsSize + , stInfo + , rInfo + , elf32Rel + , shfInfoLink + , 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) +import Language.Elna.RiscV.CodeGenerator (Statement(..)) +import qualified Data.HashSet as HashSet +import GHC.Records (HasField(..)) + +data UnresolvedRelocation = UnresolvedRelocation ByteString Elf32_Addr Word8 +data UnresolvedRelocations = UnresolvedRelocations (Vector UnresolvedRelocation) Elf32_Word + +riscv32Elf :: Vector Statement -> Handle -> ElfWriter Elf32_Ehdr +riscv32Elf code objectHandle = text + >>= 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 + 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' + } + | otherwise = Left unresolvedRelocation + symtab entries = do + ElfHeaderResult{..} <- ElfWriter get + let encodedSymbols = LazyByteString.toStrict + $ ByteString.Builder.toLazyByteString + $ foldMap (elf32Sym LSB) entries + symHeader = Elf32_Shdr + { sh_type = SHT_SYMTAB + , sh_size = fromIntegral $ ByteString.length encodedSymbols + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = fromIntegral $ ByteString.length sectionNames + , sh_link = fromIntegral $ Vector.length sectionHeaders + 2 + , sh_info = 1 + , sh_flags = 0 + , sh_entsize = 16 + , sh_addralign = 4 + , sh_addr = 0 + } + liftIO $ ByteString.hPut objectHandle encodedSymbols + 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)) + $ resolveRelocation symbols <$> relocationList + relHeader = Elf32_Shdr + { sh_type = SHT_REL + , sh_size = fromIntegral $ ByteString.length encodedRelocations + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = fromIntegral $ ByteString.length sectionNames + , sh_link = sectionHeadersLength + , sh_info = index + , sh_flags = shfInfoLink + , sh_entsize = 8 + , sh_addralign = 4 + , sh_addr = 0 + } + liftIO $ ByteString.hPut objectHandle encodedRelocations + 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 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 ".strtab" strHeader + text = do + ElfHeaderResult{..} <- ElfWriter get + let textTabIndex = fromIntegral $ Vector.length sectionHeaders + 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 + } + (encoded, updatedRelocations, symbols, definitions) = + encodeAsm textTabIndex (mempty, Vector.empty, initialHeaders, HashSet.empty) code + + filterPredicate = not + . (`ByteString.isInfixOf` getField @"sectionNames" symbols) + . ("\0" <>) . (<> "\0") + symbolResult = HashSet.foldl' encodeEmptyDefinitions symbols + $ HashSet.filter filterPredicate definitions + size = fromIntegral $ LazyByteString.length encoded + newHeader = Elf32_Shdr + { sh_type = SHT_PROGBITS + , sh_size = size + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = fromIntegral $ ByteString.length sectionNames + , sh_link = 0 + , sh_info = 0 + , sh_flags = 0b110 + , sh_entsize = 0 + , sh_addralign = 4 + , sh_addr = 0 + } + liftIO $ ByteString.hPut objectHandle $ LazyByteString.toStrict encoded + addSectionHeader ".text" newHeader + pure (symbolResult, UnresolvedRelocations updatedRelocations $ fromIntegral $ Vector.length sectionHeaders) + encodeEmptyDefinitions (ElfHeaderResult names entries) definition = + let nextEntry = Elf32_Sym + { st_value = 0 + , st_size = 0 + , st_shndx = 0 + , st_other = 0 + , st_name = fromIntegral (ByteString.length names) + , st_info = stInfo STB_GLOBAL STT_FUNC + } + in ElfHeaderResult (names <> definition <> "\0") + $ Vector.snoc entries nextEntry + encodeAsm shndx (encoded, relocations, ElfHeaderResult names symbols, definitions) instructions + | Just (instruction, rest) <- Vector.uncons instructions = + case instruction of + Instruction _ -> + let (encoded', relocations', rest', definitions') = + encodeInstructions (encoded, relocations, instructions, definitions) + in encodeAsm shndx (encoded', relocations', ElfHeaderResult names symbols, definitions') rest' + JumpLabel labelName _ -> + let (encoded', relocations', rest', definitions') = + encodeInstructions (encoded, relocations, rest, definitions) + newEntry = Elf32_Sym + { st_value = fromIntegral $ LazyByteString.length encoded + , st_size = fromIntegral $ LazyByteString.length encoded' + , st_shndx = shndx + , st_other = 0 + , st_name = fromIntegral $ ByteString.length names + , st_info = stInfo STB_GLOBAL STT_FUNC + } + result = + ( encoded <> encoded' + , relocations <> relocations' + , ElfHeaderResult (names <> labelName <> "\0") (Vector.snoc symbols newEntry) + , definitions' + ) + in encodeAsm shndx result rest' + | otherwise = (encoded, relocations, ElfHeaderResult names symbols, definitions) + encodeInstructions (encoded, relocations, instructions, definitions) + | Just (Instruction instruction, rest) <- Vector.uncons instructions = + let offset = fromIntegral $ LazyByteString.length encoded + unresolvedRelocation = case instruction of + RiscV.RelocatableInstruction _ instructionType + | RiscV.Higher20 _ symbolName <- instructionType + -> Just -- R_RISCV_HI20 + $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 26 + | RiscV.Lower12I _ _ _ symbolName <- instructionType + -> Just -- R_RISCV_LO12_I + $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 27 + | RiscV.Lower12S symbolName _ _ _ <- instructionType + -> Just -- R_RISCV_LO12_S + $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 28 + RiscV.CallInstruction symbolName + -> Just -- R_RISCV_CALL_PLT + $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 19 + RiscV.BaseInstruction _ _ -> Nothing + chunk = ByteString.Builder.toLazyByteString + $ RiscV.instruction instruction + result = + ( encoded <> chunk + , maybe relocations (Vector.snoc relocations) unresolvedRelocation + , rest + , addDefinition unresolvedRelocation definitions + ) + in encodeInstructions result + | otherwise = (encoded, relocations, Vector.drop 1 instructions, definitions) + addDefinition (Just (UnresolvedRelocation symbolName _ _)) = + HashSet.insert symbolName + addDefinition Nothing = id |