elna/lib/Language/Elna/RiscV/ElfWriter.hs

{- This Source Code Form is subject to the terms of the Mozilla Public License,
   v. 2.0. If a copy of the MPL was not distributed with this file, You can
   obtain one at https://mozilla.org/MPL/2.0/. -}

-- | Writer assembler to an object file.
module Language.Elna.RiscV.ElfWriter
    ( riscv32Elf
    ) where

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_Ehdr(..)
    , Elf32_Half
    , Elf32_Word
    , Elf32_Sym(..)
    , ElfMachine(..)
    , ElfType(..)
    , ElfVersion(..)
    , ElfIdentification(..)
    , ElfClass(..)
    , ElfData(..)
    , Elf32_Shdr(..)
    , ElfSectionType(..)
    , ElfSymbolBinding(..)
    , ElfSymbolType(..)
    , Elf32_Rel(..)
    , ElfWriter(..)
    , ElfHeaderResult(..)
    , ElfEnvironment(..)
    , UnresolvedRelocation(..)
    , UnresolvedRelocations(..)
    , addHeaderToResult
    , addSectionHeader
    , elf32Sym
    , elfHeaderSize
    , elfSectionsSize
    , stInfo
    , rInfo
    , elf32Rel
    , shfInfoLink
    , 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 (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 TextAccumulator = TextAccumulator
    { encodedAccumulator :: LazyByteString
    , relocationAccumulator :: Vector UnresolvedRelocation
    , symbolAccumulator :: ElfHeaderResult Elf32_Sym
    , definitionAccumulator :: HashSet StrictByteString
    }

riscv32Elf :: Vector Statement -> ElfWriter Elf32_Ehdr
riscv32Elf code = text code
    >>= symtab
    >>= uncurry symrel
    >>= strtab
    >> shstrtab
    >>= riscv32Header
  where
    riscv32Header :: Elf32_Half -> ElfWriter Elf32_Ehdr
    riscv32Header shstrndx = do
        ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
        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
            }

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
                }
        TextAccumulator{..} = encodeFunctions textTabIndex code
            $ TextAccumulator
                { encodedAccumulator = mempty 
                , relocationAccumulator = Vector.empty
                , symbolAccumulator = initialHeaders
                , definitionAccumulator = HashSet.empty
                }
        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
                , st_size = 0
                , st_shndx = 0
                , st_other = 0
                , st_name = StringTable.size names
                , st_info = stInfo STB_GLOBAL STT_FUNC
                }
         in ElfHeaderResult (StringTable.append definition names)
            $ Vector.snoc entries nextEntry
    encodeFunctions shndx instructions textAccumulator
        | Just (instruction, rest) <- Vector.uncons instructions =
            case instruction of
                Instruction _ ->
                    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
                                $ getField @"encodedAccumulator" textAccumulator
                            , st_size = fromIntegral $ LazyByteString.length encodedAccumulator
                            , st_shndx = shndx
                            , st_other = 0
                            , 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
                            }
        | 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
                    RiscV.RelocatableInstruction _ instructionType
                        | RiscV.RHigher20 _ symbolName <- instructionType
                            -> Just -- R_RISCV_HI20
                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 26
                        | RiscV.RLower12I _ _ _ symbolName <- instructionType
                            -> Just -- R_RISCV_LO12_I
                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 27
                        | RiscV.RLower12S symbolName _ _ _ <- instructionType
                            -> Just -- R_RISCV_LO12_S
                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 28
                        | RiscV.RBranch symbolName _ _ _ <- instructionType
                            -> Just -- R_RISCV_BRANCH
                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 16
                        | RiscV.RJal _ symbolName <- instructionType
                            -> Just -- R_RISCV_JAL
                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 17
                    RiscV.CallInstruction symbolName
                        -> Just -- R_RISCV_CALL_PLT
                        $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 19
                    RiscV.BaseInstruction _ _ -> Nothing
                chunk = ByteString.Builder.toLazyByteString
                    $ RiscV.instruction instruction
                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