Add branch relocation type

2 files changed, 93 insertions, 42 deletions

diff --git a/lib/Language/Elna/RiscV/CodeGenerator.hs b/lib/Language/Elna/RiscV/CodeGenerator.hs
index 5bc9228..e3fac72 100644
--- 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
 
+newtype RiscVGenerator a = RiscVGenerator
+    { runRiscVGenerator :: State Word32 a }
+
+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 = HashMap.foldlWithKey' go Vector.empty
+generateRiscV = flip evalState 0
+    . runRiscVGenerator
+    . foldlM go Vector.empty
+    . HashMap.toList
   where
-    go accumulator (Identifier key) value =
-        let code = Vector.cons (JumpLabel (Text.Encoding.encodeUtf8 key) [GlobalDirective, FunctionDirective])
-                $ Vector.foldMap quadruple value
-         in accumulator <> code
+    go accumulator (Identifier key, value) =
+        let code = Vector.cons (JumpLabel key [GlobalDirective, FunctionDirective])
+                . fold <$> mapM quadruple value
+         in (accumulator <>) <$> code
 
-quadruple :: RiscVQuadruple -> Vector Statement
-quadruple StartQuadruple = Vector.fromList
+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
diff --git a/lib/Language/Elna/RiscV/ElfWriter.hs b/lib/Language/Elna/RiscV/ElfWriter.hs
index a83aca3..d3b0e94 100644
--- 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