Add Intermediate monad stack for the code generation
This commit is contained in:
parent
2bd965bd5c
commit
0c45a9886a
GPG Key ID:
A27FDC1E8EE902C0
5
TODO
5
TODO
@ -1,4 +1,5 @@
|
||||
# Intermediate code generation
|
||||
|
||||
Execute the generation in a state monad and generate unique labels and
|
||||
temporary variable names.
|
||||
- Put symbol table in the reader monad and it to the stack
|
||||
or use the state monad for everything.
|
||||
- Add errors handling to the monad stack.
|
||||
|
||||
@ -21,6 +21,7 @@ common warnings
|
||||
text ^>= 2.0
|
||||
ghc-options: -Wall
|
||||
default-extensions:
|
||||
DataKinds,
|
||||
ExplicitForAll,
|
||||
LambdaCase,
|
||||
OverloadedStrings,
|
||||
|
||||
@ -6,6 +6,7 @@ module Language.Elna.Intermediate
|
||||
, intermediate
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.State (State, runState, gets, modify')
|
||||
import Data.Bifunctor (Bifunctor(..))
|
||||
import Data.Int (Int32)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
@ -18,6 +19,11 @@ import qualified Language.Elna.AST as AST
|
||||
import Language.Elna.Types (Type(..))
|
||||
import Language.Elna.SymbolTable (SymbolTable, Info(..))
|
||||
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
|
||||
= VariableOperand Variable
|
||||
@ -30,6 +36,39 @@ newtype Label = Label Text
|
||||
data Variable = Variable Text | TempVariable
|
||||
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
|
||||
= StartQuadruple
|
||||
| GoToQuadruple Label
|
||||
@ -53,24 +92,49 @@ data Quadruple
|
||||
| StopQuadruple
|
||||
deriving (Eq, Show)
|
||||
|
||||
intermediate :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector Quadruple)
|
||||
intermediate globalTable (AST.Program declarations) =
|
||||
foldr go HashMap.empty declarations
|
||||
createLabel :: Intermediate Label
|
||||
createLabel = do
|
||||
currentCounter <- Intermediate $ gets labelCounter
|
||||
Intermediate $ modify' modifier
|
||||
pure
|
||||
$ Label
|
||||
$ Text.Lazy.toStrict
|
||||
$ Text.Builder.toLazyText
|
||||
$ Text.Builder.decimal currentCounter
|
||||
where
|
||||
go (AST.TypeDefinition _ _) accumulator = accumulator
|
||||
go (AST.ProcedureDefinition procedureName _ _ statements) accumulator =
|
||||
let translatedStatements
|
||||
= Vector.cons StartQuadruple
|
||||
$ flip Vector.snoc StopQuadruple
|
||||
$ foldMap (statement globalTable) statements
|
||||
in HashMap.insert procedureName translatedStatements accumulator
|
||||
modifier generator = generator
|
||||
{ labelCounter = getField @"labelCounter" generator + 1
|
||||
}
|
||||
|
||||
statement :: SymbolTable -> AST.Statement -> Vector Quadruple
|
||||
statement _ AST.EmptyStatement = mempty
|
||||
statement localTable (AST.AssignmentStatement variableAccess' assignee) =
|
||||
let (rhsOperand, rhsStatements) = expression localTable assignee
|
||||
variableType' = variableType variableAccess' localTable
|
||||
lhsStatements = case variableAccess localTable variableAccess' Nothing variableType' mempty of
|
||||
intermediate :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector Quadruple)
|
||||
intermediate globalTable
|
||||
= fst
|
||||
. flip runState mempty
|
||||
. runIntermediate
|
||||
. 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) ->
|
||||
Vector.snoc accumulatedStatements
|
||||
$ ArrayAssignQuadruple rhsOperand accumulatedIndex
|
||||
@ -79,66 +143,85 @@ statement localTable (AST.AssignmentStatement variableAccess' assignee) =
|
||||
Vector.snoc accumulatedStatements
|
||||
$ AssignQuadruple rhsOperand
|
||||
$ Variable identifier
|
||||
in rhsStatements <> lhsStatements
|
||||
statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) =
|
||||
let (conditionStatements, jumpConstructor) = condition localTable ifCondition
|
||||
ifStatements = statement localTable ifStatement
|
||||
ifLabel = Label "L1"
|
||||
endLabel = Label "L2"
|
||||
in conditionStatements <> case statement localTable <$> elseStatement of
|
||||
statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) = do
|
||||
(conditionStatements, jumpConstructor) <- condition localTable ifCondition
|
||||
ifLabel <- createLabel
|
||||
endLabel <- createLabel
|
||||
ifStatements <- statement localTable ifStatement
|
||||
possibleElseStatements <- traverse (statement localTable) elseStatement
|
||||
pure $ conditionStatements <> case possibleElseStatements of
|
||||
Just elseStatements -> Vector.cons (jumpConstructor ifLabel) elseStatements
|
||||
<> Vector.fromList [GoToQuadruple endLabel, LabelQuadruple ifLabel]
|
||||
<> Vector.snoc ifStatements (LabelQuadruple endLabel)
|
||||
Nothing -> Vector.fromList [jumpConstructor ifLabel, GoToQuadruple endLabel, LabelQuadruple ifLabel]
|
||||
<> Vector.snoc ifStatements (LabelQuadruple endLabel)
|
||||
statement localTable (AST.WhileStatement whileCondition whileStatement) =
|
||||
let (conditionStatements, jumpConstructor) = condition localTable whileCondition
|
||||
whileStatements = statement localTable whileStatement
|
||||
startLabel = Label "L3"
|
||||
endLabel = Label "L4"
|
||||
conditionLabel = Label "L5"
|
||||
in Vector.fromList [LabelQuadruple conditionLabel]
|
||||
statement localTable (AST.WhileStatement whileCondition whileStatement) = do
|
||||
(conditionStatements, jumpConstructor) <- condition localTable whileCondition
|
||||
startLabel <- createLabel
|
||||
endLabel <- createLabel
|
||||
conditionLabel <- createLabel
|
||||
whileStatements <- statement localTable whileStatement
|
||||
pure $ Vector.fromList [LabelQuadruple conditionLabel]
|
||||
<> conditionStatements
|
||||
<> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel]
|
||||
<> whileStatements
|
||||
<> 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)
|
||||
= bimap (Vector.fromList . fmap ParameterQuadruple) Vector.concat
|
||||
$ unzip
|
||||
$ expression localTable <$> arguments
|
||||
in Vector.snoc (argumentStatements <> parameterStatements)
|
||||
$ unzip visitedArguments
|
||||
in pure
|
||||
$ Vector.snoc (argumentStatements <> parameterStatements)
|
||||
$ CallQuadruple (Variable callName)
|
||||
$ fromIntegral
|
||||
$ Vector.length argumentStatements
|
||||
statement localTable (AST.CompoundStatement statements) =
|
||||
foldMap (statement localTable) statements
|
||||
fold <$> traverse (statement localTable) statements
|
||||
|
||||
condition :: SymbolTable -> AST.Condition -> (Vector Quadruple, Label -> Quadruple)
|
||||
condition localTable (AST.EqualCondition lhs rhs) =
|
||||
let (lhsOperand, lhsStatements) = expression localTable lhs
|
||||
(rhsOperand, rhsStatements) = expression localTable rhs
|
||||
in (lhsStatements <> rhsStatements, EqualQuadruple lhsOperand rhsOperand)
|
||||
condition localTable (AST.NonEqualCondition lhs rhs) =
|
||||
let (lhsOperand, lhsStatements) = expression localTable lhs
|
||||
(rhsOperand, rhsStatements) = expression localTable rhs
|
||||
in (lhsStatements <> rhsStatements, NonEqualQuadruple lhsOperand rhsOperand)
|
||||
condition localTable (AST.LessCondition lhs rhs) =
|
||||
let (lhsOperand, lhsStatements) = expression localTable lhs
|
||||
(rhsOperand, rhsStatements) = expression localTable rhs
|
||||
in (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand)
|
||||
condition localTable (AST.GreaterCondition lhs rhs) =
|
||||
let (lhsOperand, lhsStatements) = expression localTable lhs
|
||||
(rhsOperand, rhsStatements) = expression localTable rhs
|
||||
in (lhsStatements <> rhsStatements, GreaterQuadruple lhsOperand rhsOperand)
|
||||
condition localTable (AST.LessOrEqualCondition lhs rhs) =
|
||||
let (lhsOperand, lhsStatements) = expression localTable lhs
|
||||
(rhsOperand, rhsStatements) = expression localTable rhs
|
||||
in (lhsStatements <> rhsStatements, LessOrEqualQuadruple lhsOperand rhsOperand)
|
||||
condition localTable (AST.GreaterOrEqualCondition lhs rhs) =
|
||||
let (lhsOperand, lhsStatements) = expression localTable lhs
|
||||
(rhsOperand, rhsStatements) = expression localTable rhs
|
||||
in (lhsStatements <> rhsStatements, GreaterOrEqualQuadruple lhsOperand rhsOperand)
|
||||
condition
|
||||
:: SymbolTable
|
||||
-> AST.Condition
|
||||
-> Intermediate (Vector Quadruple, Label -> Quadruple)
|
||||
condition localTable (AST.EqualCondition lhs rhs) = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(rhsOperand, rhsStatements) <- expression localTable rhs
|
||||
pure
|
||||
( lhsStatements <> rhsStatements
|
||||
, EqualQuadruple lhsOperand rhsOperand
|
||||
)
|
||||
condition localTable (AST.NonEqualCondition lhs rhs) = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(rhsOperand, rhsStatements) <- expression localTable rhs
|
||||
pure
|
||||
( lhsStatements <> rhsStatements
|
||||
, NonEqualQuadruple lhsOperand rhsOperand
|
||||
)
|
||||
condition localTable (AST.LessCondition lhs rhs) = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(rhsOperand, rhsStatements) <- expression localTable rhs
|
||||
pure (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand)
|
||||
condition localTable (AST.GreaterCondition lhs rhs) = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(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
|
||||
:: SymbolTable
|
||||
@ -146,15 +229,15 @@ variableAccess
|
||||
-> Maybe Operand
|
||||
-> Type
|
||||
-> Vector Quadruple
|
||||
-> (AST.Identifier, Maybe Operand, Vector Quadruple)
|
||||
-> Intermediate (AST.Identifier, Maybe Operand, Vector Quadruple)
|
||||
variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements =
|
||||
(identifier, accumulatedIndex, accumulatedStatements)
|
||||
variableAccess localTable (AST.ArrayAccess access1 index1) Nothing (ArrayType _ baseType) _ =
|
||||
let (indexPlace, statements) = expression localTable index1
|
||||
in variableAccess localTable access1 (Just indexPlace) baseType statements
|
||||
variableAccess localTable (AST.ArrayAccess arrayAccess' arrayIndex) (Just baseIndex) (ArrayType arraySize baseType) statements =
|
||||
let (indexPlace, statements') = expression localTable arrayIndex
|
||||
resultVariable = TempVariable
|
||||
pure (identifier, accumulatedIndex, accumulatedStatements)
|
||||
variableAccess localTable (AST.ArrayAccess access1 index1) Nothing (ArrayType _ baseType) _ = do
|
||||
(indexPlace, statements) <- expression localTable index1
|
||||
variableAccess localTable access1 (Just indexPlace) baseType statements
|
||||
variableAccess localTable (AST.ArrayAccess arrayAccess' arrayIndex) (Just baseIndex) (ArrayType arraySize baseType) statements = do
|
||||
(indexPlace, statements') <- expression localTable arrayIndex
|
||||
let resultVariable = TempVariable
|
||||
resultOperand = VariableOperand resultVariable
|
||||
indexCalculation = Vector.fromList
|
||||
[ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable
|
||||
@ -171,23 +254,30 @@ variableType (AST.VariableAccess identifier) symbolTable
|
||||
variableType (AST.ArrayAccess arrayAccess' _) symbolTable =
|
||||
variableType arrayAccess' symbolTable
|
||||
|
||||
expression :: SymbolTable -> AST.Expression -> (Operand, Vector Quadruple)
|
||||
expression :: SymbolTable -> AST.Expression -> Intermediate (Operand, Vector Quadruple)
|
||||
expression localTable = \case
|
||||
(AST.VariableExpression variableExpression) ->
|
||||
(AST.VariableExpression variableExpression) -> do
|
||||
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) ->
|
||||
(VariableOperand (Variable identifier), statements)
|
||||
pure (VariableOperand (Variable identifier), statements)
|
||||
(AST.Identifier identifier, Just operand, statements) ->
|
||||
let arrayAddress = TempVariable
|
||||
arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress
|
||||
in (VariableOperand arrayAddress, Vector.snoc statements arrayStatement)
|
||||
(AST.LiteralExpression literal') -> (literal literal', mempty)
|
||||
(AST.NegationExpression negation) ->
|
||||
let (operand, statements) = expression localTable negation
|
||||
tempVariable = TempVariable
|
||||
in pure
|
||||
( VariableOperand arrayAddress
|
||||
, Vector.snoc statements arrayStatement
|
||||
)
|
||||
(AST.LiteralExpression literal') -> pure (literal literal', mempty)
|
||||
(AST.NegationExpression negation) -> do
|
||||
(operand, statements) <- expression localTable negation
|
||||
let tempVariable = 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.SubtractionExpression lhs rhs) ->
|
||||
binaryExpression SubtractionQuadruple lhs rhs
|
||||
@ -196,12 +286,15 @@ expression localTable = \case
|
||||
(AST.DivisionExpression lhs rhs) ->
|
||||
binaryExpression DivisionQuadruple lhs rhs
|
||||
where
|
||||
binaryExpression f lhs rhs =
|
||||
let (lhsOperand, lhsStatements) = expression localTable lhs
|
||||
(rhsOperand, rhsStatements) = expression localTable rhs
|
||||
tempVariable = TempVariable
|
||||
binaryExpression f lhs rhs = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(rhsOperand, rhsStatements) <- expression localTable rhs
|
||||
let tempVariable = 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.IntegerLiteral integer) = IntOperand integer
|
||||
|
||||
Loading…
Reference in New Issue
Block a user