Negate integral expressions

2 files changed, 432 insertions, 0 deletions

diff --git a/lib/Language/Elna/RiscV/CodeGenerator.hs b/lib/Language/Elna/RiscV/CodeGenerator.hs
new file mode 100644
index 0000000..d20488c
--- /dev/null
+++ b/lib/Language/Elna/RiscV/CodeGenerator.hs
@@ -0,0 +1,156 @@
+module Language.Elna.RiscV.CodeGenerator
+    ( Statement(..)
+    , generateRiscV
+    , riscVConfiguration
+    ) where
+
+import Data.ByteString (ByteString)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Int (Int32)
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import qualified Data.Text.Encoding as Text.Encoding
+import qualified Language.Elna.Architecture.RiscV as RiscV
+import Language.Elna.Backend.Allocator (MachineConfiguration(..), Store(..))
+import Language.Elna.Backend.Intermediate (Operand(..), Quadruple(..))
+import Language.Elna.Location (Identifier(..))
+import Data.Bits (Bits(..))
+
+data Directive
+    = GlobalDirective
+    | FunctionDirective
+    deriving (Eq, Show)
+
+data Statement
+    = Instruction RiscV.Instruction
+    | JumpLabel ByteString [Directive]
+    deriving Eq
+
+riscVConfiguration :: MachineConfiguration RiscV.XRegister
+riscVConfiguration = MachineConfiguration
+    { temporaryRegister = RiscV.T0
+    }
+
+type RiscVStore = Store RiscV.XRegister
+type RiscVQuadruple = Quadruple RiscVStore
+type RiscVOperand = Operand RiscVStore
+
+generateRiscV :: HashMap Identifier (Vector RiscVQuadruple) -> Vector Statement
+generateRiscV = HashMap.foldlWithKey' go Vector.empty
+  where
+    go accumulator (Identifier key) value =
+        let code = Vector.cons (JumpLabel (Text.Encoding.encodeUtf8 key) [GlobalDirective, FunctionDirective])
+                $ Vector.foldMap quadruple value
+         in accumulator <> code
+
+quadruple :: RiscVQuadruple -> Vector Statement
+quadruple StartQuadruple = Vector.fromList
+    [ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate 4))
+    , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP RiscV.S0)
+    , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 4 RiscV.SW RiscV.SP RiscV.RA)
+    , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.S0 RiscV.ADDI RiscV.SP 4)
+    ]
+quadruple (ParameterQuadruple operand1) =
+    let (operandRegister, statements) = loadImmediateOrRegister operand1 RiscV.A0
+     in mappend statements $ Vector.fromList
+        [ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate 4))
+        , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP operandRegister)
+        ]
+quadruple (CallQuadruple callName numberOfArguments) = Vector.fromList
+    [ Instruction (RiscV.CallInstruction callName)
+    , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (numberOfArguments * 4))
+    ]
+quadruple StopQuadruple = Vector.fromList
+    [ Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.S0 RiscV.LW RiscV.SP 0)
+    , Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.RA RiscV.LW RiscV.SP 4)
+    , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP 4)
+    , Instruction (RiscV.BaseInstruction RiscV.Jalr $ RiscV.I RiscV.RA RiscV.JALR RiscV.Zero 0)
+    ]
+quadruple (AddQuadruple operand1 operand2 (Store register))
+    | IntOperand immediateOperand1 <- operand1
+    , IntOperand immediateOperand2 <- operand2 =
+        lui (immediateOperand1 + immediateOperand2) register
+    | VariableOperand variableOperand1 <- operand1
+    , VariableOperand variableOperand2 <- operand2 =
+        let Store operandRegister1 = variableOperand1
+            Store operandRegister2 = variableOperand2
+        in pure $ Instruction
+            $ RiscV.BaseInstruction RiscV.Op
+            $ RiscV.R register RiscV.ADD operandRegister1 operandRegister2 (RiscV.Funct7 0b0000000)
+    | VariableOperand variableOperand1 <- operand1
+    , IntOperand immediateOperand2 <- operand2 =
+        addImmediateRegister variableOperand1 immediateOperand2
+    | IntOperand immediateOperand1 <- operand1
+    , VariableOperand variableOperand2 <- operand2 =
+        addImmediateRegister variableOperand2 immediateOperand1
+  where
+    addImmediateRegister variableOperand immediateOperand = 
+        let statements = lui immediateOperand register
+            Store operandRegister = variableOperand
+        in Vector.snoc statements
+            $ Instruction
+            $ RiscV.BaseInstruction RiscV.Op
+            $ RiscV.R register RiscV.ADD register operandRegister
+            $ RiscV.Funct7 0b0000000
+quadruple (SubtractionQuadruple operand1 operand2 (Store register))
+    | IntOperand immediateOperand1 <- operand1
+    , IntOperand immediateOperand2 <- operand2 =
+        lui (immediateOperand1 - immediateOperand2) register
+    | VariableOperand variableOperand1 <- operand1
+    , VariableOperand variableOperand2 <- operand2 =
+        let Store operandRegister1 = variableOperand1
+            Store operandRegister2 = variableOperand2
+        in pure $ Instruction
+            $ RiscV.BaseInstruction RiscV.Op
+            $ RiscV.R register RiscV.SUB operandRegister1 operandRegister2
+            $ RiscV.Funct7 0b0100000
+    | IntOperand immediateOperand1 <- operand1
+    , VariableOperand variableOperand2 <- operand2 =
+        let statements1 = lui immediateOperand1 register
+            Store operandRegister2 = variableOperand2
+         in Vector.snoc statements1
+            $ Instruction
+            $ RiscV.BaseInstruction RiscV.Op
+            $ RiscV.R register RiscV.SUB register operandRegister2
+            $ RiscV.Funct7 0b0100000
+    | VariableOperand variableOperand1 <- operand1
+    , IntOperand immediateOperand2 <- operand2 =
+        let statements2 = lui (negate immediateOperand2) register
+            Store operandRegister1 = variableOperand1
+         in Vector.snoc statements2
+            $ Instruction
+            $ RiscV.BaseInstruction RiscV.Op
+            $ RiscV.R register RiscV.ADD register operandRegister1
+            $ RiscV.Funct7 0b0000000
+quadruple (NegationQuadruple operand1 (Store register))
+    | IntOperand immediateOperand1 <- operand1 = lui (negate immediateOperand1) register
+    | VariableOperand variableOperand1 <- operand1 =
+        let Store operandRegister1 = variableOperand1
+         in Vector.singleton
+            $ Instruction
+            $ RiscV.BaseInstruction RiscV.Op
+            $ RiscV.R register RiscV.SUB RiscV.Zero operandRegister1
+            $ RiscV.Funct7 0b0100000
+
+loadImmediateOrRegister :: RiscVOperand -> RiscV.XRegister -> (RiscV.XRegister, Vector Statement)
+loadImmediateOrRegister (IntOperand intValue) targetRegister =
+    (targetRegister, lui intValue targetRegister)
+loadImmediateOrRegister (VariableOperand (Store register)) _ = (register, Vector.empty)
+
+lui :: Int32 -> RiscV.XRegister -> Vector Statement
+lui intValue targetRegister
+    | intValue >= -2048
+    , intValue <= 2047 = Vector.singleton
+        $ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI RiscV.Zero lo)
+    | intValue .&. 0x800 /= 0 = Vector.fromList
+        [ Instruction (RiscV.BaseInstruction RiscV.Lui $ RiscV.U targetRegister $ fromIntegral $ succ hi)
+        , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI targetRegister lo)
+        ]
+    | otherwise = Vector.fromList
+        [ Instruction (RiscV.BaseInstruction RiscV.Lui $ RiscV.U targetRegister $ fromIntegral hi)
+        , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI targetRegister lo)
+        ]
+  where
+    hi = intValue `shiftR` 12
+    lo = fromIntegral intValue
diff --git a/lib/Language/Elna/RiscV/ElfWriter.hs b/lib/Language/Elna/RiscV/ElfWriter.hs
new file mode 100644
index 0000000..a83aca3
--- /dev/null
+++ b/lib/Language/Elna/RiscV/ElfWriter.hs
@@ -0,0 +1,276 @@
+-- | Writer assembler to an object file.
+module Language.Elna.RiscV.ElfWriter
+    ( 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.RiscV.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