Make IR for array access

lib/Language/Elna/Backend/Allocator.hs

@@ -5,6 +5,7 @@ module Language.Elna.Backend.Allocator
     ) where
 
 import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import Data.Int (Int32)
 import Data.Word (Word32)
 import Data.Vector (Vector)
@@ -16,11 +17,13 @@ import Language.Elna.Backend.Intermediate
     )
 import Language.Elna.Location (Identifier(..))
 import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
-import Control.Monad.Trans.State (State, runState, modify')
+import Control.Monad.Trans.State (State, runState)
 import GHC.Records (HasField(..))
 import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
 import Data.List ((!?))
+import Language.Elna.Frontend.SymbolTable (Info(..), SymbolTable)
+import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
 
 data Store r
     = RegisterStore r
@@ -38,7 +41,7 @@ newtype MachineConfiguration r = MachineConfiguration
     }
 
 newtype MachineState = MachineState
-    { stackSize :: Word32
+    { symbolTable :: SymbolTable
     } deriving (Eq, Show)
 
 newtype Allocator r a = Allocator
@@ -61,87 +64,92 @@ instance forall r. Monad (Allocator r)
 allocate
     :: forall r
     . MachineConfiguration r
+    -> SymbolTable
     -> HashMap Identifier (Vector (Quadruple Variable))
     -> Either AllocationError (HashMap Identifier (ProcedureQuadruples (Store r)))
-allocate machineConfiguration = traverse function
+allocate machineConfiguration globalTable = HashMap.traverseWithKey function
   where
-    run = flip runState (MachineState{ stackSize = 0 })
+    run localTable = flip runState (MachineState{ symbolTable = localTable })
         . flip runReaderT machineConfiguration
         . runExceptT
         . runAllocator
         . mapM quadruple
-    function :: Vector (Quadruple Variable) -> Either AllocationError (ProcedureQuadruples (Store r))
+    function :: Identifier -> Vector (Quadruple Variable) -> Either AllocationError (ProcedureQuadruples (Store r))
-    function quadruples' =
+    function identifier quadruples' =
-        let (result, lastState) = run quadruples'
+        let Just (ProcedureInfo localTable _) = SymbolTable.lookup identifier globalTable
+            (result, lastState) = run localTable quadruples'
          in makeResult lastState <$> result
-    makeResult MachineState{ stackSize } result = ProcedureQuadruples
+    makeResult MachineState{ symbolTable } result = ProcedureQuadruples
         { quadruples = result
-        , stackSize = stackSize
+        , stackSize = fromIntegral $ SymbolTable.size symbolTable * 4
         }
 
 quadruple :: Quadruple Variable -> Allocator r (Quadruple (Store r))
 quadruple = \case
     StartQuadruple -> pure StartQuadruple
     StopQuadruple -> pure StopQuadruple
-    ParameterQuadruple operand1 -> do
+    ParameterQuadruple operand1 -> ParameterQuadruple
-        operand1' <- operand operand1
+        <$> operand operand1
-        pure $ ParameterQuadruple operand1'
     CallQuadruple name count -> pure $ CallQuadruple name count
-    AddQuadruple operand1 operand2 variable -> do
+    AddQuadruple operand1 operand2 variable -> AddQuadruple
-        operand1' <- operand operand1
+        <$> operand operand1
-        operand2' <- operand operand2
+        <*> operand operand2
-        AddQuadruple operand1' operand2' <$> storeVariable variable
+        <*> storeVariable variable
-    SubtractionQuadruple operand1 operand2 variable -> do
+    SubtractionQuadruple operand1 operand2 variable -> SubtractionQuadruple
-        operand1' <- operand operand1
+        <$> operand operand1
-        operand2' <- operand operand2
+        <*> operand operand2
-        SubtractionQuadruple operand1' operand2' <$> storeVariable variable
+        <*> storeVariable variable
-    NegationQuadruple operand1 variable -> do
+    NegationQuadruple operand1 variable -> NegationQuadruple
-        operand1' <- operand operand1
+        <$> operand operand1
-        NegationQuadruple operand1' <$> storeVariable variable
+        <*> storeVariable variable
-    ProductQuadruple operand1 operand2 variable -> do
+    ProductQuadruple operand1 operand2 variable -> ProductQuadruple
-        operand1' <- operand operand1
+        <$> operand operand1
-        operand2' <- operand operand2
+        <*> operand operand2
-        ProductQuadruple operand1' operand2' <$> storeVariable variable
+        <*> storeVariable variable
-    DivisionQuadruple operand1 operand2 variable -> do
+    DivisionQuadruple operand1 operand2 variable -> DivisionQuadruple
-        operand1' <- operand operand1
+        <$> operand operand1
-        operand2' <- operand operand2
+        <*> operand operand2
-        DivisionQuadruple operand1' operand2' <$> storeVariable variable
+        <*> storeVariable variable
     LabelQuadruple label -> pure $ LabelQuadruple label
     GoToQuadruple label -> pure $ GoToQuadruple label
-    EqualQuadruple operand1 operand2 goToLabel -> do
+    EqualQuadruple operand1 operand2 goToLabel -> EqualQuadruple
-        operand1' <- operand operand1
+        <$> operand operand1
-        operand2' <- operand operand2
+        <*> operand operand2
-        pure $ EqualQuadruple operand1' operand2' goToLabel
+        <*> pure goToLabel
-    NonEqualQuadruple operand1 operand2 goToLabel -> do
+    NonEqualQuadruple operand1 operand2 goToLabel -> NonEqualQuadruple
-        operand1' <- operand operand1
+        <$> operand operand1
-        operand2' <- operand operand2
+        <*> operand operand2
-        pure $ NonEqualQuadruple operand1' operand2' goToLabel
+        <*> pure goToLabel
-    LessQuadruple operand1 operand2 goToLabel -> do
+    LessQuadruple operand1 operand2 goToLabel -> LessQuadruple
-        operand1' <- operand operand1
+        <$> operand operand1
-        operand2' <- operand operand2
+        <*> operand operand2
-        pure $ LessQuadruple operand1' operand2' goToLabel
+        <*> pure goToLabel
     GreaterQuadruple operand1 operand2 goToLabel -> do
         operand1' <- operand operand1
         operand2' <- operand operand2
         pure $ GreaterQuadruple operand1' operand2' goToLabel
-    LessOrEqualQuadruple operand1 operand2 goToLabel -> do
+    LessOrEqualQuadruple operand1 operand2 goToLabel -> LessOrEqualQuadruple
-        operand1' <- operand operand1
+        <$> operand operand1
-        operand2' <- operand operand2
+        <*> operand operand2
-        pure $ LessOrEqualQuadruple operand1' operand2' goToLabel
+        <*> pure goToLabel
-    GreaterOrEqualQuadruple operand1 operand2 goToLabel -> do
+    GreaterOrEqualQuadruple operand1 operand2 goToLabel -> GreaterOrEqualQuadruple
-        operand1' <- operand operand1
+        <$> operand operand1
-        operand2' <- operand operand2
+        <*> operand operand2
-        pure $ GreaterOrEqualQuadruple operand1' operand2' goToLabel
+        <*> pure goToLabel
-    AssignQuadruple operand1 variable -> do
+    AssignQuadruple operand1 variable -> AssignQuadruple 
-        operand1' <- operand operand1
+        <$> operand operand1
-        AssignQuadruple operand1' <$> storeVariable variable
+        <*> storeVariable variable
-    ArrayAssignQuadruple operand1 operand2 variable -> do
+    ArrayAssignQuadruple operand1 operand2 variable -> ArrayAssignQuadruple 
-        operand1' <- operand operand1
+        <$> operand operand1
-        operand2' <- operand operand2
+        <*> operand operand2
-        ArrayAssignQuadruple operand1' operand2' <$> storeVariable variable
+        <*> storeVariable variable
+    ArrayQuadruple variable1 operand1 variable2 -> ArrayQuadruple 
+        <$> storeVariable variable1
+        <*> operand operand1
+        <*> storeVariable variable2
 
 operand :: Operand Variable -> Allocator r (Operand (Store r))
-operand (IntOperand x) = pure $ IntOperand x
+operand (IntOperand literalOperand) = pure $ IntOperand literalOperand
 operand (VariableOperand variableOperand) =
     VariableOperand <$> storeVariable variableOperand
 
@@ -152,7 +160,6 @@ storeVariable (TempVariable index) = do
         $ temporaryRegisters' !? fromIntegral index
 storeVariable (LocalVariable index) = do
     temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters"
-    Allocator $ lift $ lift $ modify' $ MachineState . (+ 4) . getField @"stackSize"
     maybe (Allocator $ throwE AllocationError) (pure . StackStore (fromIntegral (succ index) * (-4)))
         $ temporaryRegisters' !? pred (length temporaryRegisters' - fromIntegral index)
 storeVariable (ParameterVariable index) = do

lib/Language/Elna/Backend/Intermediate.hs

@@ -50,7 +50,7 @@ data Quadruple v
     | DivisionQuadruple (Operand v) (Operand v) v
     | GoToQuadruple Label
     | AssignQuadruple (Operand v) v
-    {-| ArrayQuadruple Variable Operand Variable -}
+    | ArrayQuadruple v (Operand v) v
     | ArrayAssignQuadruple (Operand v) (Operand v) v
     | LessOrEqualQuadruple (Operand v) (Operand v) Label
     | GreaterOrEqualQuadruple (Operand v) (Operand v) Label

lib/Language/Elna/Frontend/SymbolTable.hs

@@ -9,6 +9,7 @@ module Language.Elna.Frontend.SymbolTable
     , lookup
     , member
     , scope
+    , size
     , toMap
     , update
     ) where
@@ -76,6 +77,9 @@ member :: Identifier -> SymbolTable -> Bool
 member identifier table =
     isJust $ lookup identifier table
 
+size :: SymbolTable -> Int
+size (SymbolTable _ map') = HashMap.size map'
+
 fromList :: [(Identifier, Info)] -> Either (NonEmpty Identifier) SymbolTable
 fromList elements
     | Just identifierDuplicates' <- identifierDuplicates =

lib/Language/Elna/Glue.hs

@@ -26,6 +26,7 @@ import Language.Elna.Frontend.SymbolTable (Info(..), SymbolTable)
 import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
 import GHC.Records (HasField(..))
 import Language.Elna.Frontend.AST (Identifier(..))
+import Debug.Trace (traceShow)
 
 data Paste = Paste
     { temporaryCounter :: Word32
@@ -71,11 +72,12 @@ declaration
     :: SymbolTable
     -> AST.Declaration
     -> Glue (Maybe (AST.Identifier, Vector (Quadruple Variable)))
-declaration globalTable (AST.ProcedureDeclaration procedureName parameters variableDeclarations statements)
+declaration globalTable (AST.ProcedureDeclaration procedureName parameters variableDeclarations statements) =
-    = Glue (modify' resetTemporaryCounter)
+    let Just (ProcedureInfo localTable _) = SymbolTable.lookup procedureName globalTable
-    >> traverseWithIndex registerVariable variableDeclarations
+     in Glue (modify' resetTemporaryCounter)
-    >> traverseWithIndex registerParameter (reverse parameters)
+        >> traverseWithIndex registerVariable variableDeclarations
-    >> nameQuadruplesTuple <$> traverse (statement globalTable) statements
+        >> traverseWithIndex registerParameter (reverse parameters)
+        >> nameQuadruplesTuple <$> traverse (statement localTable) statements
   where
     traverseWithIndex f = traverse_ (uncurry f) . zip [0..]
     registerParameter index (AST.Parameter identifier _ _) =
@@ -129,11 +131,11 @@ statement localTable (AST.AssignmentStatement variableAccess' assignee) = do
     let variableType' = variableType variableAccess' localTable
     accessResult <- variableAccess localTable variableAccess' Nothing variableType' mempty
     lhsStatements <- case accessResult of
-            {-(AST.Identifier identifier, Just accumulatedIndex, accumulatedStatements) ->
+            (identifier, Just accumulatedIndex, accumulatedStatements)
-                Vector.snoc accumulatedStatements
+                -> Vector.snoc accumulatedStatements
-                    $ ArrayAssignQuadruple rhsOperand accumulatedIndex
+                . ArrayAssignQuadruple rhsOperand accumulatedIndex
-                    $ LocalVariable identifier -}
+                <$> lookupLocal identifier
-            (identifier, _Nothing, accumulatedStatements)
+            (identifier, Nothing, accumulatedStatements)
                 -> Vector.snoc accumulatedStatements
                 . AssignQuadruple rhsOperand
                 <$> lookupLocal identifier
@@ -251,7 +253,8 @@ variableAccess _ _ _ _ _ = error "Array access operator doesn't match the type."
 variableType :: AST.VariableAccess -> SymbolTable -> Type
 variableType (AST.VariableAccess identifier) symbolTable
     | Just (TypeInfo type') <- SymbolTable.lookup identifier symbolTable = type'
-    | otherwise = error "Undefined type."
+    | Just (VariableInfo _ type') <- SymbolTable.lookup identifier symbolTable = type'
+    | otherwise = traceShow identifier $ error "Undefined type."
 variableType (AST.ArrayAccess arrayAccess' _) symbolTable =
     variableType arrayAccess' symbolTable
 
@@ -277,16 +280,17 @@ expression localTable = \case
         let variableType' = variableType variableExpression localTable
         variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty
         case variableAccess' of
-            (identifier, _Nothing, statements)
+            (identifier, Nothing, statements)
                 -> (, statements) . VariableOperand 
                 <$> lookupLocal identifier
-            {-(AST.Identifier identifier, Just operand, statements) -> do
+            (identifier, Just operand, statements) -> do
                 arrayAddress <- createTemporary
-                let arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress
+                localVariable <- lookupLocal identifier
+                let arrayStatement = ArrayQuadruple localVariable operand arrayAddress
                 pure
                     ( VariableOperand arrayAddress
                     , Vector.snoc statements arrayStatement
-                    ) -}
+                    )
   where
     binaryExpression f lhs rhs = do
         (lhsOperand, lhsStatements) <- expression localTable lhs

lib/Language/Elna/RiscV/CodeGenerator.hs

@@ -295,6 +295,38 @@ quadruple _ (ArrayAssignQuadruple assigneeOperand indexOperand store)
                 , storeInstruction
                 ]
         in (register, indexStatements <> statements)
+quadruple _ (ArrayQuadruple assigneeVariable indexOperand store) =
+    let (operandRegister1, statements1) = loadWithOffset assigneeVariable indexOperand
+        (storeRegister, storeStatements) = storeToStore store
+        instruction = Instruction
+            $ RiscV.BaseInstruction RiscV.OpImm
+            $ RiscV.I storeRegister RiscV.ADDI operandRegister1 0
+     in pure $ statements1 <> Vector.cons instruction storeStatements 
+  where
+    loadWithOffset :: RiscVStore -> Operand RiscVStore -> (RiscV.XRegister, Vector Statement)
+    loadWithOffset (RegisterStore register) _ = (register, mempty)
+    loadWithOffset (StackStore offset register) (IntOperand indexOffset) =
+        let loadInstruction = Instruction
+                $ RiscV.BaseInstruction RiscV.Load
+                $ RiscV.I register RiscV.LW RiscV.S0 (fromIntegral $ offset + indexOffset)
+        in (register, Vector.singleton loadInstruction)
+    loadWithOffset (StackStore offset register) (VariableOperand indexOffset) =
+        let baseRegisterInstruction = Instruction
+                $ RiscV.BaseInstruction RiscV.OpImm
+                $ RiscV.I immediateRegister RiscV.ADDI RiscV.S0 0
+            (indexRegister, indexStatements) = loadFromStore indexOffset
+            registerWithOffset = Instruction
+                $ RiscV.BaseInstruction RiscV.OpImm
+                $ RiscV.I immediateRegister RiscV.ADDI indexRegister 0
+            loadInstruction = Instruction
+                $ RiscV.BaseInstruction RiscV.Load
+                $ RiscV.I register RiscV.SW immediateRegister (fromIntegral offset)
+            statements = Vector.fromList
+                [ baseRegisterInstruction
+                , registerWithOffset
+                , loadInstruction
+                ]
+        in (register, indexStatements <> statements)
 
 unconditionalJal :: Label -> Statement
 unconditionalJal (Label goToLabel) = Instruction

src/Main.hs

@@ -48,7 +48,7 @@ main = execParser commandLine >>= withCommandLine
         | otherwise =
             let makeObject = elfObject output . riscv32Elf . generateRiscV
              in either (printAndExit 6) makeObject
-                $ allocate riscVConfiguration
+                $ allocate riscVConfiguration symbolTable
                 $ glue symbolTable program
     printAndExit :: Show b => forall a. Int -> b -> IO a
     printAndExit failureCode e = print e >> exitWith (ExitFailure failureCode)

tests/expectations/array_element_assignment.txt

@@ -0,0 +1 @@
+5

tests/expectations/print_array_element.txt

@@ -0,0 +1,2 @@
+5
+7

tests/vm/array_element_assignment.elna

@@ -1,3 +1,6 @@
 proc main() {
   var a: array[1] of int;
+  a[0] := 5;
+
+  printi(a[0]);
 }

tests/vm/print_array_element.elna

@@ -0,0 +1,8 @@
+proc main() {
+  var a: array[2] of int;
+  a[0] := 5;
+  a[1] := 7;
+
+  printi(a[0]);
+  printi(a[1]);
+}