Negate integral expressions

1 files changed, 0 insertions, 276 deletions

diff --git a/lib/Language/Elna/PrinterWriter.hs b/lib/Language/Elna/PrinterWriter.hs
deleted file mode 100644
index 40b60de..0000000
--- a/lib/Language/Elna/PrinterWriter.hs
+++ /dev/null
@@ -1,276 +0,0 @@
--- | Writer assembler to an object file.
-module Language.Elna.PrinterWriter
-    ( riscv32Elf
-    ) 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_Word
-    , Elf32_Sym(..)
-    , ElfMachine(..)
-    , ElfType(..)
-    , ElfVersion(..)
-    , ElfIdentification(..)
-    , ElfClass(..)
-    , ElfData(..)
-    , Elf32_Shdr(..)
-    , ElfSectionType(..)
-    , ElfSymbolBinding(..)
-    , ElfSymbolType(..)
-    , Elf32_Rel(..)
-    , ElfWriter(..)
-    , ElfHeaderResult(..)
-    , elf32Sym
-    , elfHeaderSize
-    , elfSectionsSize
-    , stInfo
-    , rInfo
-    , elf32Rel
-    , shfInfoLink
-    , 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)
-import Language.Elna.CodeGenerator (Statement(..))
-import qualified Data.HashSet as HashSet
-import GHC.Records (HasField(..))
-
-data UnresolvedRelocation = UnresolvedRelocation ByteString Elf32_Addr Word8
-data UnresolvedRelocations = UnresolvedRelocations (Vector UnresolvedRelocation) Elf32_Word
-
-riscv32Elf :: Vector Statement -> Handle -> ElfWriter Elf32_Ehdr
-riscv32Elf code objectHandle = text
-    >>= uncurry symrel
-    >>= strtab
-    >> shstrtab
-    >>= riscv32Header
-  where
-    shstrtab :: ElfWriter Elf32_Half
-    shstrtab = do
-        ElfHeaderResult{..} <- ElfWriter get
-        let stringTable = sectionNames <> ".shstrtab\0"
-            nextHeader = Elf32_Shdr
-                { sh_type = SHT_STRTAB
-                , sh_size = fromIntegral $ ByteString.length stringTable
-                , sh_offset = elfSectionsSize sectionHeaders
-                , sh_name = fromIntegral $ ByteString.length sectionNames
-                , sh_link = 0
-                , sh_info = 0
-                , sh_flags = 0
-                , sh_entsize = 0
-                , sh_addralign = 1
-                , sh_addr = 0
-                }
-        liftIO $ ByteString.hPut objectHandle stringTable
-        addSectionHeader ".shstrtab" nextHeader
-        pure $ fromIntegral $ Vector.length sectionHeaders
-    riscv32Header :: Elf32_Half -> ElfWriter Elf32_Ehdr
-    riscv32Header shstrndx = do
-        ElfHeaderResult{..} <- ElfWriter get
-        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
-            }
-    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
-    symtab entries = do 
-        ElfHeaderResult{..} <- ElfWriter get
-        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 = fromIntegral $ ByteString.length sectionNames
-                , sh_link = fromIntegral $ Vector.length sectionHeaders + 2
-                , sh_info = 1
-                , sh_flags = 0
-                , sh_entsize = 16
-                , sh_addralign = 4
-                , sh_addr = 0
-                }
-        liftIO $ ByteString.hPut objectHandle encodedSymbols
-        addSectionHeader ".symtab" symHeader
-        pure $ fromIntegral $ Vector.length sectionHeaders
-    symrel symbols relocations = do
-        let UnresolvedRelocations relocationList index = relocations
-            ElfHeaderResult stringTable entries = symbols
-
-        sectionHeadersLength <- symtab entries
-        ElfHeaderResult{..} <- ElfWriter get
-
-        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 = fromIntegral $ ByteString.length sectionNames
-                , sh_link = sectionHeadersLength
-                , sh_info = index
-                , sh_flags = shfInfoLink
-                , sh_entsize = 8
-                , sh_addralign = 4
-                , sh_addr = 0
-                }
-        liftIO $ ByteString.hPut objectHandle encodedRelocations
-        addSectionHeader ".rel.text" relHeader
-        pure stringTable
-    strtab stringTable = do
-        ElfHeaderResult{..} <- ElfWriter get
-        let strHeader = Elf32_Shdr
-                { sh_type = SHT_STRTAB
-                , sh_size = fromIntegral $ ByteString.length stringTable
-                , sh_offset = elfSectionsSize sectionHeaders
-                , sh_name = fromIntegral $ ByteString.length sectionNames
-                , sh_link = 0
-                , sh_info = 0
-                , sh_flags = 0
-                , sh_entsize = 0
-                , sh_addralign = 1
-                , sh_addr = 0
-                }
-        liftIO $ ByteString.hPut objectHandle stringTable
-        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
-                    }
-            (encoded, updatedRelocations, symbols, definitions) = 
-                encodeAsm textTabIndex (mempty, Vector.empty, initialHeaders, HashSet.empty) code
-
-            filterPredicate = not
-                . (`ByteString.isInfixOf` getField @"sectionNames" symbols)
-                . ("\0" <>) . (<> "\0")
-            symbolResult = HashSet.foldl' encodeEmptyDefinitions symbols
-                $ HashSet.filter filterPredicate definitions
-            size = fromIntegral $ LazyByteString.length encoded
-            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 = 4
-                , sh_addr = 0
-                }
-        liftIO $ ByteString.hPut objectHandle $ LazyByteString.toStrict encoded
-        addSectionHeader ".text" newHeader
-        pure (symbolResult, UnresolvedRelocations updatedRelocations $ fromIntegral $ Vector.length sectionHeaders)
-    encodeEmptyDefinitions (ElfHeaderResult names entries) definition =
-        let nextEntry = Elf32_Sym
-                { st_value = 0
-                , st_size = 0
-                , st_shndx = 0
-                , st_other = 0
-                , st_name = fromIntegral (ByteString.length names)
-                , st_info = stInfo STB_GLOBAL STT_FUNC
-                }
-         in ElfHeaderResult (names <> definition <> "\0")
-            $ Vector.snoc entries nextEntry
-    encodeAsm shndx (encoded, relocations, ElfHeaderResult names symbols, definitions) instructions
-        | Just (instruction, rest) <- Vector.uncons instructions =
-            case instruction of
-                Instruction _ ->
-                    let (encoded', relocations', rest', definitions') =
-                            encodeInstructions (encoded, relocations, instructions, definitions)
-                     in encodeAsm shndx (encoded', relocations', ElfHeaderResult names symbols, definitions') rest'
-                JumpLabel labelName _ ->
-                    let (encoded', relocations', rest', definitions') =
-                            encodeInstructions (encoded, relocations, rest, definitions)
-                        newEntry = Elf32_Sym
-                            { st_value = fromIntegral $ LazyByteString.length encoded
-                            , st_size = fromIntegral $ LazyByteString.length encoded'
-                            , st_shndx = shndx
-                            , st_other = 0
-                            , st_name = fromIntegral $ ByteString.length names
-                            , st_info = stInfo STB_GLOBAL STT_FUNC
-                            }
-                        result =
-                            ( encoded <> encoded'
-                            , relocations <> relocations'
-                            , ElfHeaderResult (names <> labelName <> "\0") (Vector.snoc symbols newEntry)
-                            , definitions'
-                            )
-                     in encodeAsm shndx result rest'
-        | otherwise = (encoded, relocations, ElfHeaderResult names symbols, definitions)
-    encodeInstructions (encoded, relocations, instructions, definitions)
-        | Just (Instruction instruction, rest) <- Vector.uncons instructions =
-            let offset = fromIntegral $ LazyByteString.length encoded
-                unresolvedRelocation = case instruction of
-                    RiscV.RelocatableInstruction _ instructionType
-                        | RiscV.Higher20 _ symbolName <- instructionType
-                            -> Just -- R_RISCV_HI20
-                            $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 26
-                        | RiscV.Lower12I _ _ _ symbolName <- instructionType
-                            -> Just -- R_RISCV_LO12_I
-                            $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 27
-                        | RiscV.Lower12S symbolName _ _ _ <- instructionType
-                            -> Just -- R_RISCV_LO12_S
-                            $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 28
-                    RiscV.CallInstruction symbolName
-                        -> Just -- R_RISCV_CALL_PLT
-                        $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 19
-                    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, Vector.drop 1 instructions, definitions)
-    addDefinition (Just (UnresolvedRelocation symbolName _ _)) =
-        HashSet.insert symbolName
-    addDefinition Nothing = id