diff options
Diffstat (limited to 'lib/Language')
| -rw-r--r-- | lib/Language/Elna/Glue.hs | 2 | ||||
| -rw-r--r-- | lib/Language/Elna/Object/ElfCoder.hs | 34 | ||||
| -rw-r--r-- | lib/Language/Elna/RiscV/CodeGenerator.hs | 3 | ||||
| -rw-r--r-- | lib/Language/Elna/RiscV/ElfWriter.hs | 373 |
4 files changed, 239 insertions, 173 deletions
diff --git a/lib/Language/Elna/Glue.hs b/lib/Language/Elna/Glue.hs index 933a2d3..70161a0 100644 --- a/lib/Language/Elna/Glue.hs +++ b/lib/Language/Elna/Glue.hs @@ -140,7 +140,7 @@ createLabel = do pure $ Label $ Text.Lazy.toStrict $ Text.Builder.toLazyText - $ "L" <> Text.Builder.decimal currentCounter + $ ".L" <> Text.Builder.decimal currentCounter where modifier generator = generator { labelCounter = getField @"labelCounter" generator + 1 diff --git a/lib/Language/Elna/Object/ElfCoder.hs b/lib/Language/Elna/Object/ElfCoder.hs index c3d58a1..b01045a 100644 --- a/lib/Language/Elna/Object/ElfCoder.hs +++ b/lib/Language/Elna/Object/ElfCoder.hs @@ -3,20 +3,26 @@ module Language.Elna.Object.ElfCoder ( ElfEnvironment(..) , ElfWriter(..) , ElfHeaderResult(..) - , elfHeaderSize + , UnresolvedRelocation(..) + , UnresolvedRelocations(..) + , addHeaderToResult , addSectionHeader + , elfHeaderSize , elfObject , elfSectionsSize , putSectionHeader + , partitionSymbols , module Language.Elna.Object.Elf ) where import Control.Exception (throwIO) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.State (StateT, runStateT, modify', gets) +import Data.Bits (Bits(..)) import Data.ByteString (StrictByteString) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Builder as ByteString.Builder +import Data.Word (Word8) import Data.Vector (Vector) import qualified Data.Vector as Vector import System.IO (Handle, IOMode(..), SeekMode(..), hSeek, withFile) @@ -26,6 +32,10 @@ import Language.Elna.Object.StringTable (StringTable) import qualified Language.Elna.Object.StringTable as StringTable import GHC.Records (HasField(..)) +data UnresolvedRelocation = UnresolvedRelocation StrictByteString Elf32_Addr Word8 +data UnresolvedRelocations = + UnresolvedRelocations (Vector UnresolvedRelocation) (ElfHeaderResult Elf32_Sym) Elf32_Word + data ElfEnvironment = ElfEnvironment { objectHeaders :: ElfHeaderResult Elf32_Shdr , objectHandle :: Handle @@ -57,6 +67,11 @@ instance MonadIO ElfWriter where liftIO = ElfWriter . liftIO +partitionSymbols :: ElfHeaderResult Elf32_Sym -> (Vector Elf32_Sym, Vector Elf32_Sym) +partitionSymbols = Vector.partition go . getField @"sectionHeaders" + where + go Elf32_Sym{ st_info } = (st_info .&. 0xf0) == 0 + -- | ELF header size. elfHeaderSize :: Elf32_Off elfHeaderSize = 52 @@ -67,17 +82,18 @@ elfSectionsSize :: Vector Elf32_Shdr -> Elf32_Off elfSectionsSize = (elfHeaderSize +) . Vector.foldr ((+) . sh_size) 0 +addHeaderToResult :: StrictByteString -> a -> ElfHeaderResult a -> ElfHeaderResult a +addHeaderToResult name newHeader accumulator@ElfHeaderResult{..} = accumulator + { sectionHeaders = Vector.snoc sectionHeaders newHeader + , sectionNames = StringTable.append name sectionNames + } + addSectionHeader :: StrictByteString -> Elf32_Shdr -> ElfWriter () addSectionHeader name newHeader = ElfWriter $ modify' modifier where - modifier elfEnvironment@ElfEnvironment{ objectHeaders } = - let ElfHeaderResult{..} = objectHeaders - in elfEnvironment - { objectHeaders = ElfHeaderResult - { sectionHeaders = Vector.snoc sectionHeaders newHeader - , sectionNames = StringTable.append name sectionNames - } - } + modifier elfEnvironment@ElfEnvironment{ objectHeaders } = elfEnvironment + { objectHeaders = addHeaderToResult name newHeader objectHeaders + } putSectionHeader :: StrictByteString -> Elf32_Shdr -> StrictByteString -> ElfWriter () putSectionHeader name newHeader encoded = do diff --git a/lib/Language/Elna/RiscV/CodeGenerator.hs b/lib/Language/Elna/RiscV/CodeGenerator.hs index c364ae6..6e5a92f 100644 --- a/lib/Language/Elna/RiscV/CodeGenerator.hs +++ b/lib/Language/Elna/RiscV/CodeGenerator.hs @@ -1,5 +1,6 @@ module Language.Elna.RiscV.CodeGenerator - ( Statement(..) + ( Directive(..) + , Statement(..) , generateRiscV , riscVConfiguration ) where diff --git a/lib/Language/Elna/RiscV/ElfWriter.hs b/lib/Language/Elna/RiscV/ElfWriter.hs index d7723d3..165197d 100644 --- a/lib/Language/Elna/RiscV/ElfWriter.hs +++ b/lib/Language/Elna/RiscV/ElfWriter.hs @@ -3,16 +3,15 @@ module Language.Elna.RiscV.ElfWriter ( riscv32Elf ) where -import Data.Word (Word8) import Data.ByteString (StrictByteString) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Builder as ByteString.Builder +import Data.ByteString.Lazy (LazyByteString) import qualified Data.ByteString.Lazy as LazyByteString import Data.Vector (Vector) import qualified Data.Vector as Vector import Language.Elna.Object.ElfCoder ( ByteOrder(..) - , Elf32_Addr , Elf32_Ehdr(..) , Elf32_Half , Elf32_Word @@ -31,6 +30,10 @@ import Language.Elna.Object.ElfCoder , ElfWriter(..) , ElfHeaderResult(..) , ElfEnvironment(..) + , UnresolvedRelocation(..) + , UnresolvedRelocations(..) + , addHeaderToResult + , addSectionHeader , elf32Sym , elfHeaderSize , elfSectionsSize @@ -38,53 +41,35 @@ import Language.Elna.Object.ElfCoder , rInfo , elf32Rel , shfInfoLink - , addSectionHeader + , partitionSymbols , putSectionHeader ) import qualified Language.Elna.Architecture.RiscV as RiscV import qualified Data.Text.Encoding as Text import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.State (get, gets) -import Language.Elna.RiscV.CodeGenerator (Statement(..)) +import Language.Elna.RiscV.CodeGenerator (Directive(..), Statement(..)) +import Language.Elna.Object.StringTable (StringTable) import qualified Language.Elna.Object.StringTable as StringTable +import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import GHC.Records (HasField(..)) -data UnresolvedRelocation = UnresolvedRelocation StrictByteString Elf32_Addr Word8 -data UnresolvedRelocations = UnresolvedRelocations (Vector UnresolvedRelocation) Elf32_Word +data TextAccumulator = TextAccumulator + { encodedAccumulator :: LazyByteString + , relocationAccumulator :: Vector UnresolvedRelocation + , symbolAccumulator :: ElfHeaderResult Elf32_Sym + , definitionAccumulator :: HashSet StrictByteString + } riscv32Elf :: Vector Statement -> ElfWriter Elf32_Ehdr -riscv32Elf code = text +riscv32Elf code = text code + >>= symtab >>= uncurry symrel >>= strtab >> shstrtab >>= riscv32Header where - shstrtab :: ElfWriter Elf32_Half - shstrtab = do - ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders" - let stringTable = ".shstrtab" - currentNamesSize = StringTable.size sectionNames - nextHeader = Elf32_Shdr - { sh_type = SHT_STRTAB - , sh_size = currentNamesSize -- Adding trailing null character. - + fromIntegral (succ $ ByteString.length stringTable) - , sh_offset = elfSectionsSize sectionHeaders - , sh_name = currentNamesSize - , sh_link = 0 - , sh_info = 0 - , sh_flags = 0 - , sh_entsize = 0 - , sh_addralign = 1 - , sh_addr = 0 - } - addSectionHeader stringTable nextHeader - - ElfEnvironment{..} <- ElfWriter get - liftIO $ ByteString.hPut objectHandle - $ StringTable.encode - $ getField @"sectionNames" objectHeaders - pure $ fromIntegral $ Vector.length sectionHeaders riscv32Header :: Elf32_Half -> ElfWriter Elf32_Ehdr riscv32Header shstrndx = do ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders" @@ -104,110 +89,50 @@ riscv32Elf code = text , e_entry = 0 , e_ehsize = fromIntegral elfHeaderSize } - takeStringZ stringTable Elf32_Sym{ st_name } - = StringTable.index 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 $ gets $ getField @"objectHeaders" - 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 = StringTable.size sectionNames - , sh_link = fromIntegral $ Vector.length sectionHeaders + 2 - , sh_info = 1 - , sh_flags = 0 - , sh_entsize = 16 - , sh_addralign = 4 - , sh_addr = 0 - } - putSectionHeader ".symtab" symHeader encodedSymbols - pure $ fromIntegral $ Vector.length sectionHeaders - symrel symbols relocations = do - let UnresolvedRelocations relocationList index = relocations - ElfHeaderResult stringTable entries = symbols - sectionHeadersLength <- symtab entries - ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders" - - 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 = StringTable.size sectionNames - , sh_link = sectionHeadersLength - , sh_info = index - , sh_flags = shfInfoLink - , sh_entsize = 8 - , sh_addralign = 4 - , sh_addr = 0 - } - putSectionHeader ".rel.text" relHeader encodedRelocations - pure stringTable - strtab stringTable = do - ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders" - let strHeader = Elf32_Shdr - { sh_type = SHT_STRTAB - , sh_size = StringTable.size stringTable - , sh_offset = elfSectionsSize sectionHeaders - , sh_name = StringTable.size sectionNames - , sh_link = 0 - , sh_info = 0 - , sh_flags = 0 - , sh_entsize = 0 - , sh_addralign = 1 - , sh_addr = 0 +text :: Vector Statement -> ElfWriter UnresolvedRelocations +text code = do + ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders" + let textTabIndex = fromIntegral $ Vector.length sectionHeaders + initialHeaders = ElfHeaderResult mempty + $ Vector.singleton + $ Elf32_Sym + { st_value = 0 + , st_size = 0 + , st_shndx = 0 + , st_other = 0 + , st_name = 0 + , st_info = 0 } - putSectionHeader ".strtab" strHeader $ StringTable.encode stringTable - text = do - ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders" - let textTabIndex = fromIntegral $ Vector.length sectionHeaders - initialHeaders = ElfHeaderResult mempty - $ 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) = - encodeFunctions textTabIndex (mempty, Vector.empty, initialHeaders, HashSet.empty) code - size = fromIntegral $ LazyByteString.length encoded - newHeader = Elf32_Shdr - { sh_type = SHT_PROGBITS - , sh_size = size - , sh_offset = elfSectionsSize sectionHeaders - , sh_name = StringTable.size sectionNames - , sh_link = 0 - , sh_info = 0 - , sh_flags = 0b110 - , sh_entsize = 0 - , sh_addralign = 4 - , sh_addr = 0 + TextAccumulator{..} = encodeFunctions textTabIndex code + $ TextAccumulator + { encodedAccumulator = mempty + , relocationAccumulator = Vector.empty + , symbolAccumulator = initialHeaders + , definitionAccumulator = HashSet.empty } - putSectionHeader ".text" newHeader $ LazyByteString.toStrict encoded - let filterPredicate :: StrictByteString -> Bool - filterPredicate = not - . (`StringTable.elem` getField @"sectionNames" symbols) - symbolResult = HashSet.foldl' encodeEmptyDefinitions symbols - $ HashSet.filter filterPredicate definitions - pure (symbolResult, UnresolvedRelocations updatedRelocations $ fromIntegral $ Vector.length sectionHeaders) + size = fromIntegral $ LazyByteString.length encodedAccumulator + newHeader = Elf32_Shdr + { sh_type = SHT_PROGBITS + , sh_size = size + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = StringTable.size sectionNames + , sh_link = 0 + , sh_info = 0 + , sh_flags = 0b110 + , sh_entsize = 0 + , sh_addralign = 4 + , sh_addr = 0 + } + putSectionHeader ".text" newHeader $ LazyByteString.toStrict encodedAccumulator + let filterPredicate :: StrictByteString -> Bool + filterPredicate = not + . (`StringTable.elem` getField @"sectionNames" symbolAccumulator) + symbolResult = HashSet.foldl' encodeEmptyDefinitions symbolAccumulator + $ HashSet.filter filterPredicate definitionAccumulator + pure $ UnresolvedRelocations relocationAccumulator symbolResult + $ fromIntegral $ Vector.length sectionHeaders + where encodeEmptyDefinitions (ElfHeaderResult names entries) definition = let nextEntry = Elf32_Sym { st_value = 0 @@ -219,34 +144,38 @@ riscv32Elf code = text } in ElfHeaderResult (StringTable.append definition names) $ Vector.snoc entries nextEntry - encodeFunctions shndx (encoded, relocations, ElfHeaderResult names symbols, definitions) instructions + encodeFunctions shndx instructions textAccumulator | Just (instruction, rest) <- Vector.uncons instructions = case instruction of Instruction _ -> - let (encoded', relocations', rest', definitions') = - encodeInstructions (encoded, relocations, instructions, definitions) - in encodeFunctions shndx (encoded', relocations', ElfHeaderResult names symbols, definitions') rest' - JumpLabel labelName _ -> - let (encoded', relocations', rest', definitions') = - encodeInstructions (encoded, relocations, rest, definitions) + let (textAccumulator', rest') = encodeInstructions shndx (textAccumulator, instructions) + in encodeFunctions shndx rest' textAccumulator' + JumpLabel labelName directives -> + let (TextAccumulator{..}, rest') = + encodeInstructions shndx (textAccumulator, rest) newEntry = Elf32_Sym - { st_value = fromIntegral $ LazyByteString.length encoded - , st_size = fromIntegral $ LazyByteString.length encoded' + { st_value = fromIntegral + $ LazyByteString.length + $ getField @"encodedAccumulator" textAccumulator + , st_size = fromIntegral $ LazyByteString.length encodedAccumulator , st_shndx = shndx , st_other = 0 - , st_name = StringTable.size names - , st_info = stInfo STB_GLOBAL STT_FUNC + , st_name = StringTable.size $ getField @"sectionNames" symbolAccumulator + , st_info = stInfo (directivesBinding directives) STT_FUNC + } + in encodeFunctions shndx rest' + $ TextAccumulator + { encodedAccumulator = encodedAccumulator + , relocationAccumulator = relocationAccumulator + , symbolAccumulator = + addHeaderToResult (Text.encodeUtf8 labelName) newEntry symbolAccumulator + , definitionAccumulator = definitionAccumulator } - result = - ( encoded' - , relocations' - , ElfHeaderResult (StringTable.append (Text.encodeUtf8 labelName) names) - $ Vector.snoc symbols newEntry - , definitions' - ) - in encodeFunctions shndx result rest' - | otherwise = (encoded, relocations, ElfHeaderResult names symbols, definitions) - encodeInstructions (encoded, relocations, instructions, definitions) + | otherwise = textAccumulator + directivesBinding directives + | GlobalDirective `elem` directives = STB_GLOBAL + | otherwise = STB_LOCAL + encodeInstructions shndx (TextAccumulator encoded relocations symbolResult definitions, instructions) | Just (Instruction instruction, rest) <- Vector.uncons instructions = let offset = fromIntegral $ LazyByteString.length encoded unresolvedRelocation = case instruction of @@ -272,14 +201,134 @@ riscv32Elf code = text 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, instructions, definitions) + result = TextAccumulator + (encoded <> chunk) + (maybe relocations (Vector.snoc relocations) unresolvedRelocation) + symbolResult + (addDefinition unresolvedRelocation definitions) + in encodeInstructions shndx (result, rest) + | Just (JumpLabel labelName directives , rest) <- Vector.uncons instructions + , FunctionDirective `notElem` directives = + let newEntry = Elf32_Sym + { st_value = fromIntegral $ LazyByteString.length encoded + , st_size = 0 + , st_shndx = shndx + , st_other = 0 + , st_name = StringTable.size $ getField @"sectionNames" symbolResult + , st_info = stInfo (directivesBinding directives) STT_NOTYPE + } + result = TextAccumulator + encoded + relocations + (addHeaderToResult (Text.encodeUtf8 labelName) newEntry symbolResult) + definitions + in encodeInstructions shndx (result, rest) + | otherwise = (TextAccumulator encoded relocations symbolResult definitions, instructions) addDefinition (Just (UnresolvedRelocation symbolName _ _)) = HashSet.insert symbolName addDefinition Nothing = id + +shstrtab :: ElfWriter Elf32_Half +shstrtab = do + ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders" + let stringTable = ".shstrtab" + currentNamesSize = StringTable.size sectionNames + nextHeader = Elf32_Shdr + { sh_type = SHT_STRTAB + , sh_size = currentNamesSize -- Adding trailing null character. + + fromIntegral (succ $ ByteString.length stringTable) + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = currentNamesSize + , sh_link = 0 + , sh_info = 0 + , sh_flags = 0 + , sh_entsize = 0 + , sh_addralign = 1 + , sh_addr = 0 + } + addSectionHeader stringTable nextHeader + + ElfEnvironment{..} <- ElfWriter get + liftIO $ ByteString.hPut objectHandle + $ StringTable.encode + $ getField @"sectionNames" objectHeaders + pure $ fromIntegral $ Vector.length sectionHeaders + +symtab :: UnresolvedRelocations -> ElfWriter (Elf32_Word, UnresolvedRelocations) +symtab (UnresolvedRelocations relocationList symbolResult index) = do + ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders" + let (localSymbols, globalSymbols) = partitionSymbols symbolResult + sortedSymbols = localSymbols <> globalSymbols + sortedResult = symbolResult{ sectionHeaders = sortedSymbols } + encodedSymbols = LazyByteString.toStrict + $ ByteString.Builder.toLazyByteString + $ foldMap (elf32Sym LSB) sortedSymbols + symHeader = Elf32_Shdr + { sh_type = SHT_SYMTAB + , sh_size = fromIntegral $ ByteString.length encodedSymbols + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = StringTable.size sectionNames + , sh_link = fromIntegral $ Vector.length sectionHeaders + 2 + , sh_info = fromIntegral $ Vector.length localSymbols + , sh_flags = 0 + , sh_entsize = 16 + , sh_addralign = 4 + , sh_addr = 0 + } + putSectionHeader ".symtab" symHeader encodedSymbols + pure + ( fromIntegral $ Vector.length sectionHeaders + , UnresolvedRelocations relocationList sortedResult index + ) + +symrel :: Elf32_Word -> UnresolvedRelocations -> ElfWriter StringTable +symrel sectionHeadersLength relocations = do + ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders" + + let UnresolvedRelocations relocationList symbols index = relocations + 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 = StringTable.size sectionNames + , sh_link = sectionHeadersLength + , sh_info = index + , sh_flags = shfInfoLink + , sh_entsize = 8 + , sh_addralign = 4 + , sh_addr = 0 + } + putSectionHeader ".rel.text" relHeader encodedRelocations + pure $ getField @"sectionNames" symbols + where + takeStringZ stringTable Elf32_Sym{ st_name } + = StringTable.index 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 + +strtab :: StringTable -> ElfWriter () +strtab stringTable = do + ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders" + let strHeader = Elf32_Shdr + { sh_type = SHT_STRTAB + , sh_size = StringTable.size stringTable + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = StringTable.size sectionNames + , sh_link = 0 + , sh_info = 0 + , sh_flags = 0 + , sh_entsize = 0 + , sh_addralign = 1 + , sh_addr = 0 + } + putSectionHeader ".strtab" strHeader $ StringTable.encode stringTable |