Add branch relocation type

2024-10-08 17:29:08 +02:00
parent 699cc8684b
commit 87f183baad
5 changed files with 124 additions and 75 deletions
--- a/lib/Language/Elna/RiscV/CodeGenerator.hs
+++ b/lib/Language/Elna/RiscV/CodeGenerator.hs
@ -4,18 +4,23 @@ module Language.Elna.RiscV.CodeGenerator
    , riscVConfiguration
    ) where

-import Data.ByteString (ByteString)
+import Control.Monad.Trans.State (State, get, evalState, modify')
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import Data.Int (Int32)
+import Data.Word (Word32)
 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(..))
+import Data.Foldable (Foldable(..), foldlM)
+import Data.Text (Text)
+import qualified Data.Text.Lazy.Builder.Int as Text.Builder
+import qualified Data.Text.Lazy.Builder as Text.Builder
+import qualified Data.Text.Lazy as Text.Lazy

 data Directive
    = GlobalDirective
@ -24,7 +29,7 @@ data Directive

 data Statement
    = Instruction RiscV.Instruction
-    | JumpLabel ByteString [Directive]
+    | JumpLabel Text [Directive]
    deriving Eq

 riscVConfiguration :: MachineConfiguration RiscV.XRegister
@ -44,16 +49,45 @@ 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
+newtype RiscVGenerator a = RiscVGenerator
+    { runRiscVGenerator :: State Word32 a }

-quadruple :: RiscVQuadruple -> Vector Statement
-quadruple StartQuadruple = Vector.fromList
+instance Functor RiscVGenerator
+  where
+    fmap f (RiscVGenerator x) = RiscVGenerator $ f <$> x
+
+instance Applicative RiscVGenerator
+  where
+    pure = RiscVGenerator . pure
+    (RiscVGenerator f) <*> (RiscVGenerator x) = RiscVGenerator $ f <*> x
+
+instance Monad RiscVGenerator
+  where
+    (RiscVGenerator x) >>= f = RiscVGenerator $ x >>= (runRiscVGenerator . f)
+
+createLabel :: RiscVGenerator Text
+createLabel = do
+    currentCounter <- RiscVGenerator get
+    RiscVGenerator $ modify' (+ 1)
+    pure
+        $ mappend ".A"
+        $ Text.Lazy.toStrict
+        $ Text.Builder.toLazyText
+        $ Text.Builder.decimal currentCounter
+
+generateRiscV :: HashMap Identifier (Vector RiscVQuadruple) -> Vector Statement
+generateRiscV = flip evalState 0
+    . runRiscVGenerator
+    . foldlM go Vector.empty
+    . HashMap.toList
+  where
+    go accumulator (Identifier key, value) =
+        let code = Vector.cons (JumpLabel key [GlobalDirective, FunctionDirective])
+                . fold <$> mapM quadruple value
+         in (accumulator <>) <$> code
+
+quadruple :: RiscVQuadruple -> RiscVGenerator (Vector Statement)
+quadruple StartQuadruple = pure $ 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)
@ -61,15 +95,15 @@ quadruple StartQuadruple = Vector.fromList
    ]
 quadruple (ParameterQuadruple operand1) =
    let (operandRegister, statements) = loadImmediateOrRegister operand1 RiscV.A0
-     in mappend statements $ Vector.fromList
+     in pure $ 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
+quadruple (CallQuadruple callName numberOfArguments) = pure $ 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
+quadruple StopQuadruple = pure $ 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)
@ -78,12 +112,12 @@ quadruple StopQuadruple = Vector.fromList
 quadruple (AddQuadruple operand1 operand2 (Store register))
    | IntOperand immediateOperand1 <- operand1
    , IntOperand immediateOperand2 <- operand2 =
-        lui (immediateOperand1 + immediateOperand2) register
+        pure $ lui (immediateOperand1 + immediateOperand2) register
    | VariableOperand variableOperand1 <- operand1
    , VariableOperand variableOperand2 <- operand2 =
        let Store operandRegister1 = variableOperand1
            Store operandRegister2 = variableOperand2
-        in pure $ Instruction
+        in pure $ Vector.singleton $ Instruction
            $ RiscV.BaseInstruction RiscV.Op
            $ RiscV.R register RiscV.ADD operandRegister1 operandRegister2 (RiscV.Funct7 0b0000000)
    | VariableOperand variableOperand1 <- operand1
@ -96,7 +130,7 @@ quadruple (AddQuadruple operand1 operand2 (Store register))
    addImmediateRegister variableOperand immediateOperand = 
        let statements = lui immediateOperand register
            Store operandRegister = variableOperand
-        in Vector.snoc statements
+        in pure $ Vector.snoc statements
            $ Instruction
            $ RiscV.BaseInstruction RiscV.Op
            $ RiscV.R register RiscV.ADD register operandRegister
@ -104,12 +138,12 @@ quadruple (AddQuadruple operand1 operand2 (Store register))
 quadruple (SubtractionQuadruple operand1 operand2 (Store register))
    | IntOperand immediateOperand1 <- operand1
    , IntOperand immediateOperand2 <- operand2 =
-        lui (immediateOperand1 - immediateOperand2) register
+        pure $ lui (immediateOperand1 - immediateOperand2) register
    | VariableOperand variableOperand1 <- operand1
    , VariableOperand variableOperand2 <- operand2 =
        let Store operandRegister1 = variableOperand1
            Store operandRegister2 = variableOperand2
-        in pure $ Instruction
+        in pure $ Vector.singleton $ Instruction
            $ RiscV.BaseInstruction RiscV.Op
            $ RiscV.R register RiscV.SUB operandRegister1 operandRegister2
            $ RiscV.Funct7 0b0100000
@ -117,7 +151,7 @@ quadruple (SubtractionQuadruple operand1 operand2 (Store register))
    , VariableOperand variableOperand2 <- operand2 =
        let statements1 = lui immediateOperand1 register
            Store operandRegister2 = variableOperand2
-         in Vector.snoc statements1
+         in pure $ Vector.snoc statements1
            $ Instruction
            $ RiscV.BaseInstruction RiscV.Op
            $ RiscV.R register RiscV.SUB register operandRegister2
@ -126,16 +160,17 @@ quadruple (SubtractionQuadruple operand1 operand2 (Store register))
    , IntOperand immediateOperand2 <- operand2 =
        let statements2 = lui (negate immediateOperand2) register
            Store operandRegister1 = variableOperand1
-         in Vector.snoc statements2
+         in pure $ 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
+    | IntOperand immediateOperand1 <- operand1 =
+        pure $ lui (negate immediateOperand1) register
    | VariableOperand variableOperand1 <- operand1 =
        let Store operandRegister1 = variableOperand1
-         in Vector.singleton
+         in pure $ Vector.singleton
            $ Instruction
            $ RiscV.BaseInstruction RiscV.Op
            $ RiscV.R register RiscV.SUB RiscV.Zero operandRegister1
@ -143,12 +178,12 @@ quadruple (NegationQuadruple operand1 (Store register))
 quadruple (ProductQuadruple operand1 operand2 (Store register))
    | IntOperand immediateOperand1 <- operand1
    , IntOperand immediateOperand2 <- operand2 =
-        lui (immediateOperand1 * immediateOperand2) register
+        pure $ lui (immediateOperand1 * immediateOperand2) register
    | VariableOperand variableOperand1 <- operand1
    , VariableOperand variableOperand2 <- operand2 =
        let Store operandRegister1 = variableOperand1
            Store operandRegister2 = variableOperand2
-        in pure $ Instruction
+        in pure $ Vector.singleton $ Instruction
            $ RiscV.BaseInstruction RiscV.Op
            $ RiscV.R register RiscV.MUL operandRegister1 operandRegister2 (RiscV.Funct7 0b0000001)
    | VariableOperand variableOperand1 <- operand1
@ -161,7 +196,7 @@ quadruple (ProductQuadruple operand1 operand2 (Store register))
    multiplyImmediateRegister variableOperand immediateOperand = 
        let statements = lui immediateOperand register
            Store operandRegister = variableOperand
-        in Vector.snoc statements
+        in pure $ Vector.snoc statements
            $ Instruction
            $ RiscV.BaseInstruction RiscV.Op
            $ RiscV.R register RiscV.MUL register operandRegister
@ -169,19 +204,32 @@ quadruple (ProductQuadruple operand1 operand2 (Store register))
 quadruple (DivisionQuadruple operand1 operand2 (Store register))
    | IntOperand immediateOperand1 <- operand1
    , IntOperand immediateOperand2 <- operand2 =
-        lui (quot immediateOperand1 immediateOperand2) register
+        if immediateOperand2 == 0
+        then pure $ Vector.singleton
+            $ Instruction (RiscV.CallInstruction "_divide_by_zero_error")
+        else pure $ lui (quot immediateOperand1 immediateOperand2) register
    | VariableOperand variableOperand1 <- operand1
-    , VariableOperand variableOperand2 <- operand2 =
+    , VariableOperand variableOperand2 <- operand2 = do
        let Store operandRegister1 = variableOperand1
            Store operandRegister2 = variableOperand2
-        in pure $ Instruction
-            $ RiscV.BaseInstruction RiscV.Op
-            $ RiscV.R register RiscV.DIV operandRegister1 operandRegister2 (RiscV.Funct7 0b0000001)
+            divisionInstruction = Instruction
+                $ RiscV.BaseInstruction RiscV.Op
+                $ RiscV.R register RiscV.DIV operandRegister1 operandRegister2 (RiscV.Funct7 0b0000001)
+        branchLabel <- createLabel
+        let branchInstruction = Instruction
+                $ RiscV.RelocatableInstruction RiscV.Branch
+                $ RiscV.RBranch branchLabel RiscV.BNE RiscV.Zero operandRegister2
+        pure $ Vector.fromList
+            [ branchInstruction
+            , Instruction (RiscV.CallInstruction "_divide_by_zero_error")
+            , JumpLabel branchLabel []
+            , divisionInstruction
+            ]
    | VariableOperand variableOperand1 <- operand1
    , IntOperand immediateOperand2 <- operand2 =
        let statements2 = lui immediateOperand2 register
            Store operandRegister1 = variableOperand1
-        in Vector.snoc statements2
+        in pure $ Vector.snoc statements2
            $ Instruction
            $ RiscV.BaseInstruction RiscV.Op
            $ RiscV.R register RiscV.DIV operandRegister1 register
@ -190,7 +238,7 @@ quadruple (DivisionQuadruple operand1 operand2 (Store register))
    , VariableOperand variableOperand2 <- operand2 =
        let statements1 = lui immediateOperand1 register
            Store operandRegister2 = variableOperand2
-        in Vector.snoc statements1
+        in pure $ Vector.snoc statements1
            $ Instruction
            $ RiscV.BaseInstruction RiscV.Op
            $ RiscV.R register RiscV.DIV register operandRegister2
--- a/lib/Language/Elna/RiscV/ElfWriter.hs
+++ b/lib/Language/Elna/RiscV/ElfWriter.hs
@ -41,7 +41,7 @@ import Language.Elna.Object.Elf
    )
 import System.IO (Handle)
 import qualified Language.Elna.Architecture.RiscV as RiscV
-import qualified Data.Text.Encoding as Text.Encoding
+import qualified Data.Text.Encoding as Text
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.State (get)
 import Language.Elna.RiscV.CodeGenerator (Statement(..))
@ -238,7 +238,7 @@ riscv32Elf code objectHandle = text
                        result =
                            ( encoded <> encoded'
                            , relocations <> relocations'
-                            , ElfHeaderResult (names <> labelName <> "\0") (Vector.snoc symbols newEntry)
+                            , ElfHeaderResult (names <> Text.encodeUtf8 labelName <> "\0") (Vector.snoc symbols newEntry)
                            , definitions'
                            )
                     in encodeAsm shndx result rest'
@ -248,18 +248,21 @@ riscv32Elf code objectHandle = text
            let offset = fromIntegral $ LazyByteString.length encoded
                unresolvedRelocation = case instruction of
                    RiscV.RelocatableInstruction _ instructionType
-                        | RiscV.Higher20 _ symbolName <- instructionType
+                        | RiscV.RHigher20 _ symbolName <- instructionType
                            -> Just -- R_RISCV_HI20
-                            $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 26
-                        | RiscV.Lower12I _ _ _ symbolName <- instructionType
+                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 26
+                        | RiscV.RLower12I _ _ _ symbolName <- instructionType
                            -> Just -- R_RISCV_LO12_I
-                            $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 27
-                        | RiscV.Lower12S symbolName _ _ _ <- instructionType
+                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 27
+                        | RiscV.RLower12S symbolName _ _ _ <- instructionType
                            -> Just -- R_RISCV_LO12_S
-                            $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 28
+                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 28
+                        | RiscV.RBranch symbolName _ _ _ <- instructionType
+                            -> Just -- R_RISCV_BRANCH
+                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 16
                    RiscV.CallInstruction symbolName
                        -> Just -- R_RISCV_CALL_PLT
-                        $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 19
+                        $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 19
                    RiscV.BaseInstruction _ _ -> Nothing
                chunk = ByteString.Builder.toLazyByteString
                    $ RiscV.instruction instruction
@ -270,7 +273,7 @@ riscv32Elf code objectHandle = text
                    , addDefinition unresolvedRelocation definitions
                    )
             in encodeInstructions result
-        | otherwise = (encoded, relocations, Vector.drop 1 instructions, definitions)
+        | otherwise = (encoded, relocations, instructions, definitions)
    addDefinition (Just (UnresolvedRelocation symbolName _ _)) =
        HashSet.insert symbolName
    addDefinition Nothing = id