elna/lib/Language/Elna/Intermediate.hs

306 lines
12 KiB
Haskell
Raw Normal View History

2024-08-12 21:00:52 +02:00
module Language.Elna.Intermediate
( Label(..)
, Operand(..)
, Quadruple(..)
, Variable(..)
2024-08-15 20:13:56 +02:00
, intermediate
2024-08-12 21:00:52 +02:00
) where
import Control.Monad.Trans.State (State, runState, gets, modify')
2024-08-18 20:13:59 +02:00
import Data.Bifunctor (Bifunctor(..))
2024-08-12 21:00:52 +02:00
import Data.Int (Int32)
2024-08-15 20:13:56 +02:00
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
2024-08-12 21:00:52 +02:00
import Data.Text (Text)
2024-08-15 20:13:56 +02:00
import Data.Word (Word32)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
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
2024-08-12 21:00:52 +02:00
data Operand
2024-08-15 20:13:56 +02:00
= VariableOperand Variable
2024-08-12 21:00:52 +02:00
| IntOperand Int32
deriving (Eq, Show)
newtype Label = Label Text
deriving (Eq, Show)
2024-08-15 20:13:56 +02:00
data Variable = Variable Text | TempVariable
2024-08-12 21:00:52 +02:00
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)
2024-08-12 21:00:52 +02:00
data Quadruple
= StartQuadruple
| GoToQuadruple Label
| AssignQuadruple Operand Variable
2024-08-15 20:13:56 +02:00
| ArrayQuadruple Variable Operand Variable
2024-08-17 14:16:16 +02:00
| ArrayAssignQuadruple Operand Operand Variable
2024-08-12 21:00:52 +02:00
| AddQuadruple Operand Operand Variable
| SubtractionQuadruple Operand Operand Variable
| ProductQuadruple Operand Operand Variable
| DivisionQuadruple Operand Operand Variable
| NegationQuadruple Operand Variable
| EqualQuadruple Operand Operand Label
| NonEqualQuadruple Operand Operand Label
| LessQuadruple Operand Operand Label
| GreaterQuadruple Operand Operand Label
| LessOrEqualQuadruple Operand Operand Label
| GreaterOrEqualQuadruple Operand Operand Label
| LabelQuadruple Label
| ParameterQuadruple Operand
| CallQuadruple Variable Word32
| StopQuadruple
deriving (Eq, Show)
2024-08-15 20:13:56 +02:00
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
modifier generator = generator
{ labelCounter = getField @"labelCounter" generator + 1
}
2024-08-15 20:13:56 +02:00
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
2024-08-15 20:13:56 +02:00
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
2024-08-17 14:16:16 +02:00
(AST.Identifier identifier, Just accumulatedIndex, accumulatedStatements) ->
Vector.snoc accumulatedStatements
$ ArrayAssignQuadruple rhsOperand accumulatedIndex
$ Variable identifier
(AST.Identifier identifier, Nothing, accumulatedStatements) ->
Vector.snoc accumulatedStatements
$ AssignQuadruple rhsOperand
$ Variable identifier
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
2024-08-17 14:16:16 +02:00
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) = do
(conditionStatements, jumpConstructor) <- condition localTable whileCondition
startLabel <- createLabel
endLabel <- createLabel
conditionLabel <- createLabel
whileStatements <- statement localTable whileStatement
pure $ Vector.fromList [LabelQuadruple conditionLabel]
2024-08-18 20:13:59 +02:00
<> conditionStatements
<> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel]
<> whileStatements
<> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel]
statement localTable (AST.CallStatement (AST.Identifier callName) arguments) = do
visitedArguments <- traverse (expression localTable) arguments
2024-08-18 20:13:59 +02:00
let (parameterStatements, argumentStatements)
= bimap (Vector.fromList . fmap ParameterQuadruple) Vector.concat
$ unzip visitedArguments
in pure
$ Vector.snoc (argumentStatements <> parameterStatements)
2024-08-18 20:13:59 +02:00
$ CallQuadruple (Variable callName)
$ fromIntegral
$ Vector.length argumentStatements
2024-08-17 14:16:16 +02:00
statement localTable (AST.CompoundStatement statements) =
fold <$> traverse (statement localTable) statements
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
)
2024-08-15 20:13:56 +02:00
variableAccess
:: SymbolTable
-> AST.VariableAccess
-> Maybe Operand
-> Type
-> Vector Quadruple
-> Intermediate (AST.Identifier, Maybe Operand, Vector Quadruple)
2024-08-15 20:13:56 +02:00
variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements =
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
2024-08-15 20:13:56 +02:00
resultOperand = VariableOperand resultVariable
indexCalculation = Vector.fromList
[ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable
, AddQuadruple indexPlace resultOperand resultVariable
]
in variableAccess localTable arrayAccess' (Just resultOperand) baseType
$ statements <> indexCalculation <> statements'
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."
variableType (AST.ArrayAccess arrayAccess' _) symbolTable =
variableType arrayAccess' symbolTable
expression :: SymbolTable -> AST.Expression -> Intermediate (Operand, Vector Quadruple)
2024-08-15 20:13:56 +02:00
expression localTable = \case
(AST.VariableExpression variableExpression) -> do
2024-08-15 20:13:56 +02:00
let variableType' = variableType variableExpression localTable
variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty
case variableAccess' of
2024-08-15 20:13:56 +02:00
(AST.Identifier identifier, Nothing, statements) ->
pure (VariableOperand (Variable identifier), statements)
2024-08-15 20:13:56 +02:00
(AST.Identifier identifier, Just operand, statements) ->
let arrayAddress = TempVariable
arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress
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
2024-08-15 20:13:56 +02:00
negationQuadruple = NegationQuadruple operand tempVariable
in pure
( VariableOperand tempVariable
, Vector.snoc statements negationQuadruple
)
2024-08-15 20:13:56 +02:00
(AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs
(AST.SubtractionExpression lhs rhs) ->
binaryExpression SubtractionQuadruple lhs rhs
(AST.ProductExpression lhs rhs) ->
binaryExpression ProductQuadruple lhs rhs
(AST.DivisionExpression lhs rhs) ->
binaryExpression DivisionQuadruple lhs rhs
where
binaryExpression f lhs rhs = do
(lhsOperand, lhsStatements) <- expression localTable lhs
(rhsOperand, rhsStatements) <- expression localTable rhs
let tempVariable = TempVariable
2024-08-15 20:13:56 +02:00
newQuadruple = f lhsOperand rhsOperand tempVariable
in pure
( VariableOperand tempVariable
, Vector.snoc (lhsStatements <> rhsStatements) newQuadruple
)
2024-08-15 20:13:56 +02:00
literal :: AST.Literal -> Operand
literal (AST.IntegerLiteral integer) = IntOperand integer
literal (AST.HexadecimalLiteral integer) = IntOperand integer
literal (AST.CharacterLiteral character) = IntOperand $ fromIntegral character
literal (AST.BooleanLiteral boolean)
| boolean = IntOperand 1
| otherwise = IntOperand 0