Add branch relocation type

TODO

@@ -9,6 +9,9 @@
 
 - Don't ignore relocations where the symbol is not defined in the symbol table.
   Report an error about an undefined symbol.
+- JumpLabels inside functions are encoded as functions. Distinguish between
+  labels (e.g. .A0 or .L0) and global functions.
+
 
 # Name analysis
 
@@ -28,4 +31,4 @@
 # Other
 
 - Type analysis.
-- Generate call a to _divide_by_zero_error on RiscV.
+- Generate a call to _divide_by_zero_error on RiscV.

lib/Language/Elna/Architecture/RiscV.hs

@@ -142,9 +142,10 @@ data Type
     deriving Eq
 
 data RelocationType
-    = Lower12I XRegister Funct3 XRegister Text
+    = RLower12I XRegister Funct3 XRegister Text
-    | Lower12S Text Funct3 XRegister XRegister
+    | RLower12S Text Funct3 XRegister XRegister
-    | Higher20 XRegister Text -- Type U.
+    | RHigher20 XRegister Text -- Type U.
+    | RBranch Text Funct3 XRegister XRegister -- Type B.
     deriving Eq
 
 data Instruction
@@ -299,9 +300,10 @@ type' (Type rd funct3' rs1 funct12')
     .|. (fromIntegral (funct12 funct12') `shiftL` 20);
 
 relocationType :: RelocationType -> Word32
-relocationType (Lower12I rd funct3' rs1 _) = type' $ I rd funct3' rs1 0
+relocationType (RLower12I rd funct3' rs1 _) = type' $ I rd funct3' rs1 0
-relocationType (Lower12S _ funct3' rs1 rs2) = type' $ S 0 funct3' rs1 rs2
+relocationType (RLower12S _ funct3' rs1 rs2) = type' $ S 0 funct3' rs1 rs2
-relocationType (Higher20 rd _) = type' $ U rd 0
+relocationType (RHigher20 rd _) = type' $ U rd 0
+relocationType (RBranch _ funct3' rs1 rs2) = type' $ B 0 funct3' rs1 rs2
 
 instruction :: Instruction -> ByteString.Builder.Builder
 instruction = \case

lib/Language/Elna/Glue.hs

@@ -2,7 +2,7 @@ module Language.Elna.Glue
     ( glue
     ) where
 
-import Control.Monad.Trans.State (State, get, modify', runState)
+import Control.Monad.Trans.State (State, gets, modify', runState)
 import Data.Bifunctor (Bifunctor(..))
 import Data.Foldable (Foldable(..))
 import Data.HashMap.Strict (HashMap)
@@ -13,10 +13,15 @@ import qualified Data.Vector as Vector
 import Data.Word (Word32)
 import qualified Language.Elna.Frontend.AST as AST
 import Language.Elna.Backend.Intermediate (Operand(..), Quadruple(..), Variable(..))
-import Language.Elna.Frontend.SymbolTable (SymbolTable{-, Info(..) -})
+import Language.Elna.Frontend.SymbolTable (SymbolTable)
+import GHC.Records (HasField(..))
+
+newtype Paste = Paste
+    { temporaryCounter :: Word32
+    }
 
 newtype Glue a = Glue
-    { runGlue :: State Word32 a }
+    { runGlue :: State Paste a }
 
 instance Functor Glue
   where
@@ -34,7 +39,7 @@ instance Monad Glue
 glue :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector (Quadruple Variable))
 glue globalTable
     = fst
-    . flip runState 0
+    . flip runState Paste{ temporaryCounter = 0 }
     . runGlue
     . program globalTable
 
@@ -111,17 +116,17 @@ statement localTable (AST.WhileStatement whileCondition whileStatement) = do
 
 createTemporary :: Glue Variable
 createTemporary = do
-    currentCounter <- Glue get
+    currentCounter <- Glue $ gets $ getField @"temporaryCounter"
-    Glue $ modify' (+ 1)
+    Glue $ modify' modifier
     pure $ TempVariable currentCounter
+  where
+    modifier generator = generator
+        { temporaryCounter = getField @"temporaryCounter" generator + 1
+        }
 
 {-
 import Language.Elna.Types (Type(..))
 import qualified Language.Elna.SymbolTable as SymbolTable
-import GHC.Records (HasField(..))
-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
 
 newtype Label = Label Text
     deriving Eq
@@ -130,20 +135,6 @@ instance Show Label
   where
     show (Label label) = '.' : Text.unpack label
 
-createLabel :: Glue Label
-createLabel = do
-    currentCounter <- Glue $ gets labelCounter
-    Glue $ modify' modifier
-    pure
-        $ Label
-        $ Text.Lazy.toStrict
-        $ Text.Builder.toLazyText
-        $ Text.Builder.decimal currentCounter
-  where
-    modifier generator = generator
-        { labelCounter = getField @"labelCounter" generator + 1
-        }
-
 condition
     :: SymbolTable
     -> AST.Condition

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
+newtype RiscVGenerator a = RiscVGenerator
-generateRiscV = HashMap.foldlWithKey' go Vector.empty
+    { runRiscVGenerator :: State Word32 a }
-  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
+instance Functor RiscVGenerator
-quadruple StartQuadruple = Vector.fromList
+  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
+            divisionInstruction = Instruction
-            $ RiscV.BaseInstruction RiscV.Op
+                $ RiscV.BaseInstruction RiscV.Op
-            $ RiscV.R register RiscV.DIV operandRegister1 operandRegister2 (RiscV.Funct7 0b0000001)
+                $ 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

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
+                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 26
-                        | RiscV.Lower12I _ _ _ symbolName <- instructionType
+                        | RiscV.RLower12I _ _ _ symbolName <- instructionType
                             -> Just -- R_RISCV_LO12_I
-                            $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 27
+                            $ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 27
-                        | RiscV.Lower12S symbolName _ _ _ <- instructionType
+                        | 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