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

Add Intermediate monad stack for the code generation

Browse Source
This commit is contained in:
Eugen Wissner 2024-08-27 14:21:50 +02:00
parent 2bd965bd5c
commit 0c45a9886a
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
3 changed files with 180 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
TODO
View File

@ -1,4 +1,5 @@
# Intermediate code generation # Intermediate code generation
Execute the generation in a state monad and generate unique labels and - Put symbol table in the reader monad and it to the stack
temporary variable names. or use the state monad for everything.
- Add errors handling to the monad stack.

1
elna.cabal
View File

@ -21,6 +21,7 @@ common warnings
text ^>= 2.0 text ^>= 2.0
ghc-options: -Wall ghc-options: -Wall
default-extensions: default-extensions:
DataKinds,
ExplicitForAll, ExplicitForAll,
LambdaCase, LambdaCase,
OverloadedStrings, OverloadedStrings,

259
lib/Language/Elna/Intermediate.hs
View File

@ -6,6 +6,7 @@ module Language.Elna.Intermediate
, intermediate , intermediate
) where ) where
import Control.Monad.Trans.State (State, runState, gets, modify')
import Data.Bifunctor (Bifunctor(..)) import Data.Bifunctor (Bifunctor(..))
import Data.Int (Int32) import Data.Int (Int32)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
@ -18,6 +19,11 @@ import qualified Language.Elna.AST as AST
import Language.Elna.Types (Type(..)) import Language.Elna.Types (Type(..))
import Language.Elna.SymbolTable (SymbolTable, Info(..)) import Language.Elna.SymbolTable (SymbolTable, Info(..))
import qualified Language.Elna.SymbolTable as SymbolTable import qualified Language.Elna.SymbolTable as SymbolTable
import Data.Foldable (Foldable(..), foldrM)
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
data Operand data Operand
= VariableOperand Variable = VariableOperand Variable
@ -30,6 +36,39 @@ newtype Label = Label Text
data Variable = Variable Text | TempVariable data Variable = Variable Text | TempVariable
deriving (Eq, Show) deriving (Eq, Show)
newtype Generator = Generator
{ labelCounter :: Int32
} deriving (Eq, Show)
instance Semigroup Generator
where
lhs <> rhs = Generator
{ labelCounter = getField @"labelCounter" lhs + getField @"labelCounter" rhs
}
instance Monoid Generator
where
mempty = Generator
{ labelCounter = 0
}
newtype Intermediate a = Intermediate
{ runIntermediate :: State Generator a
}
instance Functor Intermediate
where
fmap f (Intermediate x) = Intermediate $ f <$> x
instance Applicative Intermediate
where
pure = Intermediate . pure
(Intermediate f) <*> (Intermediate x) = Intermediate $ f <*> x
instance Monad Intermediate
where
(Intermediate x) >>= f = Intermediate $ x >>= (runIntermediate . f)
data Quadruple data Quadruple
= StartQuadruple = StartQuadruple
| GoToQuadruple Label | GoToQuadruple Label
@ -53,24 +92,49 @@ data Quadruple
| StopQuadruple | StopQuadruple
deriving (Eq, Show) deriving (Eq, Show)
intermediate :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector Quadruple) createLabel :: Intermediate Label
intermediate globalTable (AST.Program declarations) = createLabel = do
foldr go HashMap.empty declarations currentCounter <- Intermediate $ gets labelCounter
Intermediate $ modify' modifier
pure
$ Label
$ Text.Lazy.toStrict
$ Text.Builder.toLazyText
$ Text.Builder.decimal currentCounter
where where
go (AST.TypeDefinition _ _) accumulator = accumulator modifier generator = generator
go (AST.ProcedureDefinition procedureName _ _ statements) accumulator = { labelCounter = getField @"labelCounter" generator + 1
let translatedStatements }
= Vector.cons StartQuadruple
$ flip Vector.snoc StopQuadruple
$ foldMap (statement globalTable) statements
in HashMap.insert procedureName translatedStatements accumulator
statement :: SymbolTable -> AST.Statement -> Vector Quadruple intermediate :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector Quadruple)
statement _ AST.EmptyStatement = mempty intermediate globalTable
statement localTable (AST.AssignmentStatement variableAccess' assignee) = = fst
let (rhsOperand, rhsStatements) = expression localTable assignee . flip runState mempty
variableType' = variableType variableAccess' localTable . runIntermediate
lhsStatements = case variableAccess localTable variableAccess' Nothing variableType' mempty of . program globalTable
program
:: SymbolTable
-> AST.Program
-> Intermediate (HashMap AST.Identifier (Vector Quadruple))
program globalTable (AST.Program declarations) =
foldrM go HashMap.empty declarations
where
go (AST.TypeDefinition _ _) accumulator = pure accumulator
go (AST.ProcedureDefinition procedureName _ _ statements) accumulator = do
translatedStatements <- Vector.cons StartQuadruple
. flip Vector.snoc StopQuadruple
. fold
<$> traverse (statement globalTable) statements
pure $ HashMap.insert procedureName translatedStatements accumulator
statement :: SymbolTable -> AST.Statement -> Intermediate (Vector Quadruple)
statement _ AST.EmptyStatement = pure mempty
statement localTable (AST.AssignmentStatement variableAccess' assignee) = do
(rhsOperand, rhsStatements) <- expression localTable assignee
let variableType' = variableType variableAccess' localTable
accessResult <- variableAccess localTable variableAccess' Nothing variableType' mempty
pure $ rhsStatements <> case accessResult of
(AST.Identifier identifier, Just accumulatedIndex, accumulatedStatements) -> (AST.Identifier identifier, Just accumulatedIndex, accumulatedStatements) ->
Vector.snoc accumulatedStatements Vector.snoc accumulatedStatements
$ ArrayAssignQuadruple rhsOperand accumulatedIndex $ ArrayAssignQuadruple rhsOperand accumulatedIndex
@ -79,66 +143,85 @@ statement localTable (AST.AssignmentStatement variableAccess' assignee) =
Vector.snoc accumulatedStatements Vector.snoc accumulatedStatements
$ AssignQuadruple rhsOperand $ AssignQuadruple rhsOperand
$ Variable identifier $ Variable identifier
in rhsStatements <> lhsStatements statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) = do
statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) = (conditionStatements, jumpConstructor) <- condition localTable ifCondition
let (conditionStatements, jumpConstructor) = condition localTable ifCondition ifLabel <- createLabel
ifStatements = statement localTable ifStatement endLabel <- createLabel
ifLabel = Label "L1" ifStatements <- statement localTable ifStatement
endLabel = Label "L2" possibleElseStatements <- traverse (statement localTable) elseStatement
in conditionStatements <> case statement localTable <$> elseStatement of pure $ conditionStatements <> case possibleElseStatements of
Just elseStatements -> Vector.cons (jumpConstructor ifLabel) elseStatements Just elseStatements -> Vector.cons (jumpConstructor ifLabel) elseStatements
<> Vector.fromList [GoToQuadruple endLabel, LabelQuadruple ifLabel] <> Vector.fromList [GoToQuadruple endLabel, LabelQuadruple ifLabel]
<> Vector.snoc ifStatements (LabelQuadruple endLabel) <> Vector.snoc ifStatements (LabelQuadruple endLabel)
Nothing -> Vector.fromList [jumpConstructor ifLabel, GoToQuadruple endLabel, LabelQuadruple ifLabel] Nothing -> Vector.fromList [jumpConstructor ifLabel, GoToQuadruple endLabel, LabelQuadruple ifLabel]
<> Vector.snoc ifStatements (LabelQuadruple endLabel) <> Vector.snoc ifStatements (LabelQuadruple endLabel)
statement localTable (AST.WhileStatement whileCondition whileStatement) = statement localTable (AST.WhileStatement whileCondition whileStatement) = do
let (conditionStatements, jumpConstructor) = condition localTable whileCondition (conditionStatements, jumpConstructor) <- condition localTable whileCondition
whileStatements = statement localTable whileStatement startLabel <- createLabel
startLabel = Label "L3" endLabel <- createLabel
endLabel = Label "L4" conditionLabel <- createLabel
conditionLabel = Label "L5" whileStatements <- statement localTable whileStatement
in Vector.fromList [LabelQuadruple conditionLabel] pure $ Vector.fromList [LabelQuadruple conditionLabel]
<> conditionStatements <> conditionStatements
<> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel] <> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel]
<> whileStatements <> whileStatements
<> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel] <> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel]
statement localTable (AST.CallStatement (AST.Identifier callName) arguments) = statement localTable (AST.CallStatement (AST.Identifier callName) arguments) = do
visitedArguments <- traverse (expression localTable) arguments
let (parameterStatements, argumentStatements) let (parameterStatements, argumentStatements)
= bimap (Vector.fromList . fmap ParameterQuadruple) Vector.concat = bimap (Vector.fromList . fmap ParameterQuadruple) Vector.concat
$ unzip $ unzip visitedArguments
$ expression localTable <$> arguments in pure
in Vector.snoc (argumentStatements <> parameterStatements) $ Vector.snoc (argumentStatements <> parameterStatements)
$ CallQuadruple (Variable callName) $ CallQuadruple (Variable callName)
$ fromIntegral $ fromIntegral
$ Vector.length argumentStatements $ Vector.length argumentStatements
statement localTable (AST.CompoundStatement statements) = statement localTable (AST.CompoundStatement statements) =
foldMap (statement localTable) statements fold <$> traverse (statement localTable) statements
condition :: SymbolTable -> AST.Condition -> (Vector Quadruple, Label -> Quadruple) condition
condition localTable (AST.EqualCondition lhs rhs) = :: SymbolTable
let (lhsOperand, lhsStatements) = expression localTable lhs -> AST.Condition
(rhsOperand, rhsStatements) = expression localTable rhs -> Intermediate (Vector Quadruple, Label -> Quadruple)
in (lhsStatements <> rhsStatements, EqualQuadruple lhsOperand rhsOperand) condition localTable (AST.EqualCondition lhs rhs) = do
condition localTable (AST.NonEqualCondition lhs rhs) = (lhsOperand, lhsStatements) <- expression localTable lhs
let (lhsOperand, lhsStatements) = expression localTable lhs (rhsOperand, rhsStatements) <- expression localTable rhs
(rhsOperand, rhsStatements) = expression localTable rhs pure
in (lhsStatements <> rhsStatements, NonEqualQuadruple lhsOperand rhsOperand) ( lhsStatements <> rhsStatements
condition localTable (AST.LessCondition lhs rhs) = , EqualQuadruple lhsOperand rhsOperand
let (lhsOperand, lhsStatements) = expression localTable lhs )
(rhsOperand, rhsStatements) = expression localTable rhs condition localTable (AST.NonEqualCondition lhs rhs) = do
in (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand) (lhsOperand, lhsStatements) <- expression localTable lhs
condition localTable (AST.GreaterCondition lhs rhs) = (rhsOperand, rhsStatements) <- expression localTable rhs
let (lhsOperand, lhsStatements) = expression localTable lhs pure
(rhsOperand, rhsStatements) = expression localTable rhs ( lhsStatements <> rhsStatements
in (lhsStatements <> rhsStatements, GreaterQuadruple lhsOperand rhsOperand) , NonEqualQuadruple lhsOperand rhsOperand
condition localTable (AST.LessOrEqualCondition lhs rhs) = )
let (lhsOperand, lhsStatements) = expression localTable lhs condition localTable (AST.LessCondition lhs rhs) = do
(rhsOperand, rhsStatements) = expression localTable rhs (lhsOperand, lhsStatements) <- expression localTable lhs
in (lhsStatements <> rhsStatements, LessOrEqualQuadruple lhsOperand rhsOperand) (rhsOperand, rhsStatements) <- expression localTable rhs
condition localTable (AST.GreaterOrEqualCondition lhs rhs) = pure (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand)
let (lhsOperand, lhsStatements) = expression localTable lhs condition localTable (AST.GreaterCondition lhs rhs) = do
(rhsOperand, rhsStatements) = expression localTable rhs (lhsOperand, lhsStatements) <- expression localTable lhs
in (lhsStatements <> rhsStatements, GreaterOrEqualQuadruple lhsOperand rhsOperand) (rhsOperand, rhsStatements) <- expression localTable rhs
pure
( lhsStatements <> rhsStatements
, GreaterQuadruple lhsOperand rhsOperand
)
condition localTable (AST.LessOrEqualCondition lhs rhs) = do
(lhsOperand, lhsStatements) <- expression localTable lhs
(rhsOperand, rhsStatements) <- expression localTable rhs
pure
( lhsStatements <> rhsStatements
, LessOrEqualQuadruple lhsOperand rhsOperand
)
condition localTable (AST.GreaterOrEqualCondition lhs rhs) = do
(lhsOperand, lhsStatements) <- expression localTable lhs
(rhsOperand, rhsStatements) <- expression localTable rhs
pure
( lhsStatements <> rhsStatements
, GreaterOrEqualQuadruple lhsOperand rhsOperand
)
variableAccess variableAccess
:: SymbolTable :: SymbolTable
@ -146,15 +229,15 @@ variableAccess
-> Maybe Operand -> Maybe Operand
-> Type -> Type
-> Vector Quadruple -> Vector Quadruple
-> (AST.Identifier, Maybe Operand, Vector Quadruple) -> Intermediate (AST.Identifier, Maybe Operand, Vector Quadruple)
variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements = variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements =
(identifier, accumulatedIndex, accumulatedStatements) pure (identifier, accumulatedIndex, accumulatedStatements)
variableAccess localTable (AST.ArrayAccess access1 index1) Nothing (ArrayType _ baseType) _ = variableAccess localTable (AST.ArrayAccess access1 index1) Nothing (ArrayType _ baseType) _ = do
let (indexPlace, statements) = expression localTable index1 (indexPlace, statements) <- expression localTable index1
in variableAccess localTable access1 (Just indexPlace) baseType statements variableAccess localTable access1 (Just indexPlace) baseType statements
variableAccess localTable (AST.ArrayAccess arrayAccess' arrayIndex) (Just baseIndex) (ArrayType arraySize baseType) statements = variableAccess localTable (AST.ArrayAccess arrayAccess' arrayIndex) (Just baseIndex) (ArrayType arraySize baseType) statements = do
let (indexPlace, statements') = expression localTable arrayIndex (indexPlace, statements') <- expression localTable arrayIndex
resultVariable = TempVariable let resultVariable = TempVariable
resultOperand = VariableOperand resultVariable resultOperand = VariableOperand resultVariable
indexCalculation = Vector.fromList indexCalculation = Vector.fromList
[ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable [ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable
@ -171,23 +254,30 @@ variableType (AST.VariableAccess identifier) symbolTable
variableType (AST.ArrayAccess arrayAccess' _) symbolTable = variableType (AST.ArrayAccess arrayAccess' _) symbolTable =
variableType arrayAccess' symbolTable variableType arrayAccess' symbolTable
expression :: SymbolTable -> AST.Expression -> (Operand, Vector Quadruple) expression :: SymbolTable -> AST.Expression -> Intermediate (Operand, Vector Quadruple)
expression localTable = \case expression localTable = \case
(AST.VariableExpression variableExpression) -> (AST.VariableExpression variableExpression) -> do
let variableType' = variableType variableExpression localTable let variableType' = variableType variableExpression localTable
in case variableAccess localTable variableExpression Nothing variableType' mempty of variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty
case variableAccess' of
(AST.Identifier identifier, Nothing, statements) -> (AST.Identifier identifier, Nothing, statements) ->
(VariableOperand (Variable identifier), statements) pure (VariableOperand (Variable identifier), statements)
(AST.Identifier identifier, Just operand, statements) -> (AST.Identifier identifier, Just operand, statements) ->
let arrayAddress = TempVariable let arrayAddress = TempVariable
arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress
in (VariableOperand arrayAddress, Vector.snoc statements arrayStatement) in pure
(AST.LiteralExpression literal') -> (literal literal', mempty) ( VariableOperand arrayAddress
(AST.NegationExpression negation) -> , Vector.snoc statements arrayStatement
let (operand, statements) = expression localTable negation )
tempVariable = TempVariable (AST.LiteralExpression literal') -> pure (literal literal', mempty)
(AST.NegationExpression negation) -> do
(operand, statements) <- expression localTable negation
let tempVariable = TempVariable
negationQuadruple = NegationQuadruple operand tempVariable negationQuadruple = NegationQuadruple operand tempVariable
in (VariableOperand tempVariable, Vector.snoc statements negationQuadruple) in pure
( VariableOperand tempVariable
, Vector.snoc statements negationQuadruple
)
(AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs (AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs
(AST.SubtractionExpression lhs rhs) -> (AST.SubtractionExpression lhs rhs) ->
binaryExpression SubtractionQuadruple lhs rhs binaryExpression SubtractionQuadruple lhs rhs
@ -196,12 +286,15 @@ expression localTable = \case
(AST.DivisionExpression lhs rhs) -> (AST.DivisionExpression lhs rhs) ->
binaryExpression DivisionQuadruple lhs rhs binaryExpression DivisionQuadruple lhs rhs
where where
binaryExpression f lhs rhs = binaryExpression f lhs rhs = do
let (lhsOperand, lhsStatements) = expression localTable lhs (lhsOperand, lhsStatements) <- expression localTable lhs
(rhsOperand, rhsStatements) = expression localTable rhs (rhsOperand, rhsStatements) <- expression localTable rhs
tempVariable = TempVariable let tempVariable = TempVariable
newQuadruple = f lhsOperand rhsOperand tempVariable newQuadruple = f lhsOperand rhsOperand tempVariable
in (VariableOperand tempVariable, Vector.snoc (lhsStatements <> rhsStatements) newQuadruple) in pure
( VariableOperand tempVariable
, Vector.snoc (lhsStatements <> rhsStatements) newQuadruple
)
literal :: AST.Literal -> Operand literal :: AST.Literal -> Operand
literal (AST.IntegerLiteral integer) = IntOperand integer literal (AST.IntegerLiteral integer) = IntOperand integer