Stub the implementation for all phases

1 files changed, 172 insertions, 0 deletions

diff --git a/lib/Language/Elna/PrinterWriter.hs b/lib/Language/Elna/PrinterWriter.hs
new file mode 100644
index 0000000..38c3549
--- /dev/null
+++ b/lib/Language/Elna/PrinterWriter.hs
@@ -0,0 +1,172 @@
+-- | Writer assembler to an object file.
+module Language.Elna.PrinterWriter
+    ( riscv32Elf
+    , riscv32Header
+    ) where
+
+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_Ehdr(..)
+    , Elf32_Half
+    , Elf32_Sym(..)
+    , ElfMachine(..)
+    , ElfType(..)
+    , ElfVersion(..)
+    , ElfIdentification(..)
+    , ElfClass(..)
+    , ElfData(..)
+    , Elf32_Shdr(..)
+    , ElfSectionType(..)
+    , ElfSymbolBinding(..)
+    , ElfSymbolType(..)
+    , elf32Sym
+    , elfHeaderSize
+    , elfSectionsSize
+    , stInfo
+    )
+import System.IO (Handle)
+import qualified Language.Elna.Architecture.RiscV as RiscV
+
+data ElfHeaderResult a = ElfHeaderResult ByteString (Vector a)
+
+riscv32Elf :: Vector RiscV.Instruction -> Handle -> IO (Vector Elf32_Shdr)
+riscv32Elf code objectHandle =
+    let zeroHeader = Elf32_Shdr
+            { sh_type = SHT_NULL
+            , sh_size = 0
+            , sh_offset = 0
+            , sh_name = 0
+            , sh_link = 0
+            , sh_info = 0
+            , sh_flags = 0
+            , sh_entsize = 0
+            , sh_addralign = 0
+            , sh_addr = 0
+            }
+     in text (ElfHeaderResult "\0" $ Vector.singleton zeroHeader)
+        >>= shstrtab
+        >>= finalize
+  where
+    finalize (ElfHeaderResult _ headers) = pure headers
+    shstrtab (ElfHeaderResult names headers) = do
+        let stringTable = names <> ".shstrtab\0"
+            nextHeader = Elf32_Shdr
+                { sh_type = SHT_STRTAB
+                , sh_size = fromIntegral $ ByteString.length stringTable
+                , sh_offset = elfSectionsSize headers
+                , sh_name = fromIntegral $ ByteString.length names
+                , sh_link = 0
+                , sh_info = 0
+                , sh_flags = 0
+                , sh_entsize = 0
+                , sh_addralign = 0
+                , sh_addr = 0
+                }
+        ByteString.hPut objectHandle stringTable
+        pure $ ElfHeaderResult stringTable
+            $ Vector.snoc headers nextHeader
+    strtab stringTable (ElfHeaderResult names headers) = do
+        let newHeader = Elf32_Shdr
+                { sh_type = SHT_STRTAB
+                , sh_size = fromIntegral $ ByteString.length stringTable
+                , sh_offset = elfSectionsSize headers
+                , sh_name = fromIntegral $ ByteString.length names
+                , sh_link = 0
+                , sh_info = 0
+                , sh_flags = 0
+                , sh_entsize = 0
+                , sh_addralign = 0
+                , sh_addr = 0
+                }
+        ByteString.hPut objectHandle stringTable
+        pure $ ElfHeaderResult (names <> ".strtab\0")
+            $ Vector.snoc headers newHeader
+    symtab strtabIndex entries (ElfHeaderResult names headers) = do
+        let encoded = LazyByteString.toStrict
+                $ ByteString.Builder.toLazyByteString
+                $ foldMap (elf32Sym LSB) entries 
+            newHeader = Elf32_Shdr
+                { sh_type = SHT_SYMTAB
+                , sh_size = fromIntegral $ ByteString.length encoded
+                , sh_offset = elfSectionsSize headers
+                , sh_name = fromIntegral $ ByteString.length names
+                , sh_link = strtabIndex
+                , sh_info = 1
+                , sh_flags = 0
+                , sh_entsize = 16
+                , sh_addralign = 0
+                , sh_addr = 0
+                }
+        ByteString.hPut objectHandle encoded
+        pure $ ElfHeaderResult (names <> ".symtab\0")
+            $ Vector.snoc headers newHeader
+    text (ElfHeaderResult names headers) = do
+        let textTabIndex = fromIntegral $ Vector.length headers
+            strtabIndex = fromIntegral $ textTabIndex + 2
+        ElfHeaderResult stringTable  entries <- symbolEntry textTabIndex code
+            $ ElfHeaderResult "\0"
+            $ Vector.singleton
+            $ Elf32_Sym
+                { st_value = 0
+                , st_size = 0
+                , st_shndx = 0
+                , st_other = 0
+                , st_name = 0
+                , st_info = 0
+                }
+        let newHeader = Elf32_Shdr
+                { sh_type = SHT_PROGBITS
+                , sh_size = fromIntegral $ foldr ((+) . st_size) 0 entries
+                , sh_offset = elfSectionsSize headers
+                , sh_name = fromIntegral $ ByteString.length names
+                , sh_link = 0
+                , sh_info = 0
+                , sh_flags = 0b110
+                , sh_entsize = 0
+                , sh_addralign = 0
+                , sh_addr = 0
+                }
+            newResult = ElfHeaderResult (names <> ".text\0")
+                $ Vector.snoc headers newHeader
+        symtab strtabIndex entries newResult
+            >>= strtab stringTable
+    symbolEntry :: Elf32_Half -> Vector RiscV.Instruction -> ElfHeaderResult Elf32_Sym -> IO (ElfHeaderResult Elf32_Sym)
+    symbolEntry shndx instructions (ElfHeaderResult names entries) = do
+        let encoded = LazyByteString.toStrict
+                $ ByteString.Builder.toLazyByteString
+                $ foldMap RiscV.instruction instructions
+            newEntry = Elf32_Sym
+                { st_value = 0
+                , st_size = fromIntegral $ ByteString.length encoded
+                , st_shndx = shndx
+                , st_other = 0
+                , st_name = fromIntegral $ ByteString.length names
+                , st_info = stInfo STB_GLOBAL STT_FUNC
+                }
+        ByteString.hPut objectHandle encoded
+        pure $ ElfHeaderResult (names <> "_start\0")
+            $ Vector.snoc entries newEntry
+
+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
+    }