belka/elna
1
0
Fork 0
Code Issues 34 Pull Requests Releases Activity

Make IR for array access

Browse Source
This commit is contained in:
Eugen Wissner
2024-12-04 16:11:06 +01:00
parent 0c40bca60b
commit 1c996b3c8b
10 changed files with 138 additions and 77 deletions
Download Patch File Download Diff File Expand all files Collapse all files

127
lib/Language/Elna/Backend/Allocator.hs
View File

@@ -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 quadruples' =
let (result, lastState) = run quadruples'
function :: Identifier -> Vector (Quadruple Variable) -> Either AllocationError (ProcedureQuadruples (Store r))
function identifier 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
operand1' <- operand operand1
pure $ ParameterQuadruple operand1'
ParameterQuadruple operand1 -> ParameterQuadruple
<$> operand operand1
CallQuadruple name count -> pure $ CallQuadruple name count
AddQuadruple operand1 operand2 variable -> do
operand1' <- operand operand1
operand2' <- operand operand2
AddQuadruple operand1' operand2' <$> storeVariable variable
SubtractionQuadruple operand1 operand2 variable -> do
operand1' <- operand operand1
operand2' <- operand operand2
SubtractionQuadruple operand1' operand2' <$> storeVariable variable
NegationQuadruple operand1 variable -> do
operand1' <- operand operand1
NegationQuadruple operand1' <$> storeVariable variable
ProductQuadruple operand1 operand2 variable -> do
operand1' <- operand operand1
operand2' <- operand operand2
ProductQuadruple operand1' operand2' <$> storeVariable variable
DivisionQuadruple operand1 operand2 variable -> do
operand1' <- operand operand1
operand2' <- operand operand2
DivisionQuadruple operand1' operand2' <$> storeVariable variable
AddQuadruple operand1 operand2 variable -> AddQuadruple
<$> operand operand1
<*> operand operand2
<*> storeVariable variable
SubtractionQuadruple operand1 operand2 variable -> SubtractionQuadruple
<$> operand operand1
<*> operand operand2
<*> storeVariable variable
NegationQuadruple operand1 variable -> NegationQuadruple
<$> operand operand1
<*> storeVariable variable
ProductQuadruple operand1 operand2 variable -> ProductQuadruple
<$> operand operand1
<*> operand operand2
<*> storeVariable variable
DivisionQuadruple operand1 operand2 variable -> DivisionQuadruple
<$> operand operand1
<*> operand operand2
<*> storeVariable variable
LabelQuadruple label -> pure $ LabelQuadruple label
GoToQuadruple label -> pure $ GoToQuadruple label
EqualQuadruple operand1 operand2 goToLabel -> do
operand1' <- operand operand1
operand2' <- operand operand2
pure $ EqualQuadruple operand1' operand2' goToLabel
NonEqualQuadruple operand1 operand2 goToLabel -> do
operand1' <- operand operand1
operand2' <- operand operand2
pure $ NonEqualQuadruple operand1' operand2' goToLabel
LessQuadruple operand1 operand2 goToLabel -> do
operand1' <- operand operand1
operand2' <- operand operand2
pure $ LessQuadruple operand1' operand2' goToLabel
EqualQuadruple operand1 operand2 goToLabel -> EqualQuadruple
<$> operand operand1
<*> operand operand2
<*> pure goToLabel
NonEqualQuadruple operand1 operand2 goToLabel -> NonEqualQuadruple
<$> operand operand1
<*> operand operand2
<*> pure goToLabel
LessQuadruple operand1 operand2 goToLabel -> LessQuadruple
<$> operand operand1
<*> operand operand2
<*> pure goToLabel
GreaterQuadruple operand1 operand2 goToLabel -> do
operand1' <- operand operand1
operand2' <- operand operand2
pure $ GreaterQuadruple operand1' operand2' goToLabel
LessOrEqualQuadruple operand1 operand2 goToLabel -> do
operand1' <- operand operand1
operand2' <- operand operand2
pure $ LessOrEqualQuadruple operand1' operand2' goToLabel
GreaterOrEqualQuadruple operand1 operand2 goToLabel -> do
operand1' <- operand operand1
operand2' <- operand operand2
pure $ GreaterOrEqualQuadruple operand1' operand2' goToLabel
AssignQuadruple operand1 variable -> do
operand1' <- operand operand1
AssignQuadruple operand1' <$> storeVariable variable
ArrayAssignQuadruple operand1 operand2 variable -> do
operand1' <- operand operand1
operand2' <- operand operand2
ArrayAssignQuadruple operand1' operand2' <$> storeVariable variable
LessOrEqualQuadruple operand1 operand2 goToLabel -> LessOrEqualQuadruple
<$> operand operand1
<*> operand operand2
<*> pure goToLabel
GreaterOrEqualQuadruple operand1 operand2 goToLabel -> GreaterOrEqualQuadruple
<$> operand operand1
<*> operand operand2
<*> pure goToLabel
AssignQuadruple operand1 variable -> AssignQuadruple
<$> operand operand1
<*> storeVariable variable
ArrayAssignQuadruple operand1 operand2 variable -> ArrayAssignQuadruple
<$> operand operand1
<*> operand operand2
<*> 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

2
lib/Language/Elna/Backend/Intermediate.hs
View File

@@ -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

4
lib/Language/Elna/Frontend/SymbolTable.hs
View File

@@ -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 =

34
lib/Language/Elna/Glue.hs
View File

@@ -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)
= Glue (modify' resetTemporaryCounter)
>> traverseWithIndex registerVariable variableDeclarations
>> traverseWithIndex registerParameter (reverse parameters)
>> nameQuadruplesTuple <$> traverse (statement globalTable) statements
declaration globalTable (AST.ProcedureDeclaration procedureName parameters variableDeclarations statements) =
let Just (ProcedureInfo localTable _) = SymbolTable.lookup procedureName globalTable
in Glue (modify' resetTemporaryCounter)
>> traverseWithIndex registerVariable variableDeclarations
>> 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) ->
Vector.snoc accumulatedStatements
$ ArrayAssignQuadruple rhsOperand accumulatedIndex
$ LocalVariable identifier -}
(identifier, _Nothing, accumulatedStatements)
(identifier, Just accumulatedIndex, accumulatedStatements)
-> Vector.snoc accumulatedStatements
. ArrayAssignQuadruple rhsOperand accumulatedIndex
<$> lookupLocal identifier
(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

32
lib/Language/Elna/RiscV/CodeGenerator.hs
View File

@@ -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

2
src/Main.hs
View File

@@ -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)

1
tests/expectations/array_element_assignment.txt
View File

@@ -0,0 +1 @@
5

2
tests/expectations/print_array_element.txt Normal file
View File

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

3
tests/vm/array_element_assignment.elna
View File

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

8
tests/vm/print_array_element.elna Normal file
View File

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