Encode labels as untyped local symbols in ELF

TODO

@@ -9,10 +9,7 @@
 
 - Don't ignore relocations where the symbol is not defined in the symbol table.
   Report an error about an undefined symbol.
-- JumpLabels inside functions are encoded as functions. Distinguish between
+- Labels should start with a dot, ".L", not just "L0" or "L1".
-  labels (e.g. .A0 or .L0) and global functions. Lables are NOTYPE LOCAL.
-- Sort the symbols so that local symbols come first. Some table header had a
-  number specifiying the index of the first non-local symbol. Adjust that number.
 
 # Name analysis
 

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 } =
+    modifier elfEnvironment@ElfEnvironment{ objectHeaders } = elfEnvironment
-        let ElfHeaderResult{..} = objectHeaders
+        { objectHeaders = addHeaderToResult name newHeader objectHeaders
-         in elfEnvironment
+        }
-            { objectHeaders = ElfHeaderResult
-                { sectionHeaders = Vector.snoc sectionHeaders newHeader
-                , sectionNames = StringTable.append name sectionNames
-                }
-            }
 
 putSectionHeader :: StrictByteString -> Elf32_Shdr -> StrictByteString -> ElfWriter ()
 putSectionHeader name newHeader encoded = do

lib/Language/Elna/RiscV/CodeGenerator.hs

@@ -1,5 +1,6 @@
 module Language.Elna.RiscV.CodeGenerator
-    ( Statement(..)
+    ( Directive(..)
+    , Statement(..)
     , generateRiscV
     , riscVConfiguration
     ) where

lib/Language/Elna/RiscV/ElfWriter.hs

@@ -3,7 +3,6 @@ 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
@@ -12,7 +11,6 @@ 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 +29,10 @@ import Language.Elna.Object.ElfCoder
     , ElfWriter(..)
     , ElfHeaderResult(..)
     , ElfEnvironment(..)
+    , UnresolvedRelocation(..)
+    , UnresolvedRelocations(..)
+    , addHeaderToResult
+    , addSectionHeader
     , elf32Sym
     , elfHeaderSize
     , elfSectionsSize
@@ -38,53 +40,27 @@ 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 qualified Data.HashSet as HashSet
 import GHC.Records (HasField(..))
 
-data UnresolvedRelocation = UnresolvedRelocation StrictByteString Elf32_Addr Word8
-data UnresolvedRelocations = UnresolvedRelocations (Vector UnresolvedRelocation) Elf32_Word
-
 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 +80,45 @@ 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
+text :: Vector Statement -> ElfWriter UnresolvedRelocations
-        ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
+text code = do
-
+    ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
-        let encodedRelocations = LazyByteString.toStrict
+    let textTabIndex = fromIntegral $ Vector.length sectionHeaders
-                $ ByteString.Builder.toLazyByteString
+        initialHeaders = ElfHeaderResult mempty
-                $ Vector.foldMap (either (const mempty) (elf32Rel LSB))
+            $ Vector.singleton
-                $ resolveRelocation symbols <$> relocationList
+            $ Elf32_Sym
-            relHeader = Elf32_Shdr
+                { st_value = 0
-                { sh_type = SHT_REL
+                , st_size = 0
-                , sh_size = fromIntegral $ ByteString.length encodedRelocations
+                , st_shndx = 0
-                , sh_offset = elfSectionsSize sectionHeaders
+                , st_other = 0
-                , sh_name = StringTable.size sectionNames
+                , st_name = 0
-                , sh_link = sectionHeadersLength
+                , st_info = 0
-                , sh_info = index
-                , sh_flags = shfInfoLink
-                , sh_entsize = 8
-                , sh_addralign = 4
-                , sh_addr = 0
                 }
-        putSectionHeader ".rel.text" relHeader encodedRelocations
+        (encoded, updatedRelocations, symbols, definitions) = 
-        pure stringTable
+            encodeFunctions textTabIndex (mempty, Vector.empty, initialHeaders, HashSet.empty) code
-    strtab stringTable = do
+        size = fromIntegral $ LazyByteString.length encoded
-        ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
+        newHeader = Elf32_Shdr
-        let strHeader = Elf32_Shdr
+            { sh_type = SHT_PROGBITS
-                { sh_type = SHT_STRTAB
+            , sh_size = size
-                , sh_size = StringTable.size stringTable
+            , sh_offset = elfSectionsSize sectionHeaders
-                , sh_offset = elfSectionsSize sectionHeaders
+            , sh_name = StringTable.size sectionNames
-                , sh_name = StringTable.size sectionNames
+            , sh_link = 0
-                , sh_link = 0
+            , sh_info = 0
-                , sh_info = 0
+            , sh_flags = 0b110
-                , sh_flags = 0
+            , sh_entsize = 0
-                , sh_entsize = 0
+            , sh_addralign = 4
-                , sh_addralign = 1
+            , sh_addr = 0
-                , sh_addr = 0
+            }
-                }
+    putSectionHeader ".text" newHeader $ LazyByteString.toStrict encoded
-        putSectionHeader ".strtab" strHeader $ StringTable.encode stringTable
+    let filterPredicate :: StrictByteString -> Bool
-    text = do
+        filterPredicate = not
-        ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
+            . (`StringTable.elem` getField @"sectionNames" symbols)
-        let textTabIndex = fromIntegral $ Vector.length sectionHeaders
+        symbolResult = HashSet.foldl' encodeEmptyDefinitions symbols
-            initialHeaders = ElfHeaderResult mempty
+            $ HashSet.filter filterPredicate definitions
-                $ Vector.singleton
+    pure $ UnresolvedRelocations updatedRelocations symbolResult
-                $ Elf32_Sym
+        $ fromIntegral $ Vector.length sectionHeaders
-                    { st_value = 0
+  where
-                    , 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
-                }
-        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)
     encodeEmptyDefinitions (ElfHeaderResult names entries) definition =
         let nextEntry = Elf32_Sym
                 { st_value = 0
@@ -219,34 +130,36 @@ riscv32Elf code = text
                 }
          in ElfHeaderResult (StringTable.append definition names)
             $ Vector.snoc entries nextEntry
-    encodeFunctions shndx (encoded, relocations, ElfHeaderResult names symbols, definitions) instructions
+    encodeFunctions shndx (encoded, relocations, symbolResult, definitions) instructions
         | Just (instruction, rest) <- Vector.uncons instructions =
             case instruction of
                 Instruction _ ->
-                    let (encoded', relocations', rest', definitions') =
+                    let (encoded', relocations', symbolResult', definitions', rest') =
-                            encodeInstructions (encoded, relocations, instructions, definitions)
+                            encodeInstructions shndx (encoded, relocations, symbolResult, definitions, instructions)
-                     in encodeFunctions shndx (encoded', relocations', ElfHeaderResult names symbols, definitions') rest'
+                     in encodeFunctions shndx (encoded', relocations', symbolResult', definitions') rest'
-                JumpLabel labelName _ ->
+                JumpLabel labelName directives ->
-                    let (encoded', relocations', rest', definitions') =
+                    let (encoded', relocations', ElfHeaderResult _names _symbols, definitions', rest') =
-                            encodeInstructions (encoded, relocations, rest, definitions)
+                            encodeInstructions shndx (encoded, relocations, symbolResult, definitions, rest)
+                        isGlobal = GlobalDirective `elem` directives
                         newEntry = Elf32_Sym
                             { st_value = fromIntegral $ LazyByteString.length encoded
-                            , st_size = fromIntegral $ LazyByteString.length encoded'
+                            , st_size = if isGlobal then fromIntegral $ LazyByteString.length encoded' else 0
                             , st_shndx = shndx
                             , st_other = 0
-                            , st_name = StringTable.size names
+                            , st_name = StringTable.size _names
-                            , st_info = stInfo STB_GLOBAL STT_FUNC
+                            , st_info = stInfo (if isGlobal then STB_GLOBAL else STB_LOCAL)
+                                $ if FunctionDirective `elem` directives then STT_FUNC else STT_NOTYPE
                             }
                         result =
                             ( encoded'
                             , relocations'
-                            , ElfHeaderResult (StringTable.append (Text.encodeUtf8 labelName) names)
+                            , ElfHeaderResult (StringTable.append (Text.encodeUtf8 labelName) _names)
-                                $ Vector.snoc symbols newEntry
+                                $ Vector.snoc _symbols newEntry
                             , definitions'
                             )
                      in encodeFunctions shndx result rest'
-        | otherwise = (encoded, relocations, ElfHeaderResult names symbols, definitions)
+        | otherwise = (encoded, relocations, symbolResult, definitions)
-    encodeInstructions (encoded, relocations, instructions, definitions)
+    encodeInstructions shndx (encoded, relocations, ElfHeaderResult names symbols, definitions, instructions)
         | Just (Instruction instruction, rest) <- Vector.uncons instructions =
             let offset = fromIntegral $ LazyByteString.length encoded
                 unresolvedRelocation = case instruction of
@@ -275,11 +188,136 @@ riscv32Elf code = text
                 result =
                     ( encoded <> chunk
                     , maybe relocations (Vector.snoc relocations) unresolvedRelocation
-                    , rest
+                    , ElfHeaderResult names symbols
                     , addDefinition unresolvedRelocation definitions
+                    , rest
                     )
-             in encodeInstructions result
+             in encodeInstructions shndx result
-        | otherwise = (encoded, relocations, instructions, definitions)
+        | 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 names
+                    , st_info = stInfo (if GlobalDirective `elem` directives then STB_GLOBAL else STB_LOCAL) STT_NOTYPE
+                    }
+                result =
+                    ( encoded
+                    , relocations
+                    , ElfHeaderResult (StringTable.append (Text.encodeUtf8 labelName) names)
+                        $ Vector.snoc symbols newEntry
+                    , definitions
+                    , rest
+                    )
+                in encodeInstructions shndx result
+        | otherwise = (encoded, relocations, ElfHeaderResult names symbols, 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