1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
-- | Writer assembler to an object file.
module Language.Elna.PrinterWriter
( riscv32Elf
, riscv32Header
) 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_Sym(..)
, ElfMachine(..)
, ElfType(..)
, ElfVersion(..)
, ElfIdentification(..)
, ElfClass(..)
, ElfData(..)
, Elf32_Shdr(..)
, ElfSectionType(..)
, ElfSymbolBinding(..)
, ElfSymbolType(..)
, Elf32_Rel (..)
, elf32Sym
, elfHeaderSize
, elfSectionsSize
, stInfo
, rInfo
, elf32Rel
, shfInfoLink
, ElfWriter(..)
, ElfHeaderResult(..)
, 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)
data UnresolvedRelocation = UnresolvedRelocation ByteString Elf32_Addr Word8
riscv32Elf :: Vector RiscV.Instruction -> Handle -> ElfWriter ()
riscv32Elf code objectHandle = text
>>= symstrtab
where
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
symstrtab (symbols@(ElfHeaderResult stringTable entries), relocations) = do
ElfHeaderResult{..} <- ElfWriter get
let encodedSymbols = LazyByteString.toStrict
$ ByteString.Builder.toLazyByteString
$ foldMap (elf32Sym LSB) entries
namesLength = fromIntegral $ ByteString.length sectionNames
symHeader = Elf32_Shdr
{ sh_type = SHT_SYMTAB
, sh_size = fromIntegral $ ByteString.length encodedSymbols
, sh_offset = elfSectionsSize sectionHeaders
, sh_name = namesLength
, sh_link = fromIntegral $ Vector.length sectionHeaders + 2
, sh_info = 1
, sh_flags = 0
, sh_entsize = 16
, sh_addralign = 0
, sh_addr = 0
}
liftIO $ ByteString.hPut objectHandle encodedSymbols
let headers1 = Vector.snoc sectionHeaders 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 sectionHeaders
, sh_info = 1
, sh_flags = shfInfoLink
, sh_entsize = 8
, sh_addralign = 0
, sh_addr = 0
}
liftIO $ 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
}
liftIO $ ByteString.hPut objectHandle stringTable
addSectionHeader ".symtab" symHeader
addSectionHeader ".rel.text" relHeader
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
}
(symbolResult, size, relocations) <- symbolEntry textTabIndex code
(initialHeaders, 0, mempty)
let 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 = 0
, sh_addr = 0
}
addSectionHeader ".text" newHeader
pure (symbolResult, relocations)
symbolEntry
:: Elf32_Half
-> Vector RiscV.Instruction
-> (ElfHeaderResult Elf32_Sym, Elf32_Addr, Vector UnresolvedRelocation)
-> ElfWriter (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 = offset
, st_size = fromIntegral size
, st_shndx = shndx
, st_other = 0
, st_name = fromIntegral $ ByteString.length names
, st_info = stInfo STB_GLOBAL STT_FUNC
}
liftIO $ 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
{ e_version = EV_CURRENT
, e_type = ET_REL
, e_shstrndx = 2 -- String table. SHN_UNDEF
, e_shoff = 0
, e_shnum = 0
, 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
}
|
