273 lines
11 KiB
Haskell
273 lines
11 KiB
Haskell
module Language.Elna.Glue
|
|
( glue
|
|
) where
|
|
|
|
import Control.Monad.Trans.State (State, gets, modify', runState)
|
|
import Data.Bifunctor (Bifunctor(..))
|
|
import Data.Foldable (Foldable(..))
|
|
import Data.HashMap.Strict (HashMap)
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import Data.Maybe (catMaybes)
|
|
import Data.Vector (Vector)
|
|
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
|
|
import qualified Data.Vector as Vector
|
|
import Data.Word (Word32)
|
|
import qualified Language.Elna.Frontend.AST as AST
|
|
import Language.Elna.Backend.Intermediate
|
|
( Label(..)
|
|
, Operand(..)
|
|
, Quadruple(..)
|
|
, Variable(..)
|
|
)
|
|
import Language.Elna.Frontend.SymbolTable (SymbolTable)
|
|
import GHC.Records (HasField(..))
|
|
|
|
data Paste = Paste
|
|
{ temporaryCounter :: Word32
|
|
, labelCounter :: Word32
|
|
}
|
|
|
|
newtype Glue a = Glue
|
|
{ runGlue :: State Paste a }
|
|
|
|
instance Functor Glue
|
|
where
|
|
fmap f (Glue x) = Glue $ f <$> x
|
|
|
|
instance Applicative Glue
|
|
where
|
|
pure = Glue . pure
|
|
(Glue f) <*> (Glue x) = Glue $ f <*> x
|
|
|
|
instance Monad Glue
|
|
where
|
|
(Glue x) >>= f = Glue $ x >>= (runGlue . f)
|
|
|
|
glue :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector (Quadruple Variable))
|
|
glue globalTable
|
|
= fst
|
|
. flip runState Paste{ temporaryCounter = 0, labelCounter = 0 }
|
|
. runGlue
|
|
. program globalTable
|
|
|
|
program
|
|
:: SymbolTable
|
|
-> AST.Program
|
|
-> Glue (HashMap AST.Identifier (Vector (Quadruple Variable)))
|
|
program globalTable (AST.Program declarations) = HashMap.fromList . catMaybes
|
|
<$> traverse (declaration globalTable) declarations
|
|
|
|
declaration
|
|
:: SymbolTable
|
|
-> AST.Declaration
|
|
-> Glue (Maybe (AST.Identifier, Vector (Quadruple Variable)))
|
|
declaration globalTable (AST.ProcedureDeclaration procedureName _ _ statements)
|
|
= Just
|
|
. (procedureName,)
|
|
. Vector.cons StartQuadruple
|
|
. flip Vector.snoc StopQuadruple
|
|
. fold
|
|
<$> traverse (statement globalTable) statements
|
|
declaration _ (AST.TypeDefinition _ _) = pure Nothing
|
|
|
|
statement :: SymbolTable -> AST.Statement -> Glue (Vector (Quadruple Variable))
|
|
statement _ AST.EmptyStatement = pure mempty
|
|
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 visitedArguments
|
|
in pure
|
|
$ Vector.snoc (argumentStatements <> parameterStatements)
|
|
$ CallQuadruple callName
|
|
$ fromIntegral
|
|
$ Vector.length argumentStatements
|
|
statement localTable (AST.CompoundStatement statements) =
|
|
fold <$> traverse (statement localTable) statements
|
|
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.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
|
|
$ Variable identifier
|
|
(AST.Identifier identifier, Nothing, accumulatedStatements) ->
|
|
Vector.snoc accumulatedStatements
|
|
$ AssignQuadruple rhsOperand
|
|
$ Variable identifier
|
|
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] -}
|
|
|
|
createTemporary :: Glue Variable
|
|
createTemporary = do
|
|
currentCounter <- Glue $ gets $ getField @"temporaryCounter"
|
|
Glue $ modify' modifier
|
|
pure $ TempVariable currentCounter
|
|
where
|
|
modifier generator = generator
|
|
{ temporaryCounter = getField @"temporaryCounter" generator + 1
|
|
}
|
|
|
|
createLabel :: Glue Label
|
|
createLabel = do
|
|
currentCounter <- Glue $ gets $ getField @"labelCounter"
|
|
Glue $ modify' modifier
|
|
pure $ Label
|
|
$ Text.Lazy.toStrict
|
|
$ Text.Builder.toLazyText
|
|
$ "L" <> Text.Builder.decimal currentCounter
|
|
where
|
|
modifier generator = generator
|
|
{ labelCounter = getField @"labelCounter" generator + 1
|
|
}
|
|
|
|
condition
|
|
:: SymbolTable
|
|
-> AST.Condition
|
|
-> Glue (Vector (Quadruple Variable), Label -> Quadruple Variable)
|
|
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
|
|
)
|
|
{-
|
|
import Language.Elna.Types (Type(..))
|
|
import qualified Language.Elna.SymbolTable as SymbolTable
|
|
|
|
variableAccess
|
|
:: SymbolTable
|
|
-> AST.VariableAccess
|
|
-> Maybe Operand
|
|
-> Type
|
|
-> Vector Quadruple
|
|
-> Glue (AST.Identifier, Maybe Operand, Vector Quadruple)
|
|
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
|
|
resultVariable <- createTemporary
|
|
let 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 -> Glue (Operand Variable, Vector (Quadruple Variable))
|
|
expression localTable = \case
|
|
(AST.LiteralExpression literal') -> pure (literal literal', mempty)
|
|
(AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs
|
|
(AST.SubtractionExpression lhs rhs) ->
|
|
binaryExpression SubtractionQuadruple lhs rhs
|
|
(AST.NegationExpression negation) -> do
|
|
(operand, statements) <- expression localTable negation
|
|
tempVariable <- createTemporary
|
|
let negationQuadruple = NegationQuadruple operand tempVariable
|
|
pure
|
|
( VariableOperand tempVariable
|
|
, Vector.snoc statements negationQuadruple
|
|
)
|
|
(AST.ProductExpression lhs rhs) ->
|
|
binaryExpression ProductQuadruple lhs rhs
|
|
(AST.DivisionExpression lhs rhs) ->
|
|
binaryExpression DivisionQuadruple lhs rhs
|
|
{- (AST.VariableExpression variableExpression) -> do
|
|
let variableType' = variableType variableExpression localTable
|
|
variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty
|
|
case variableAccess' of
|
|
(AST.Identifier identifier, Nothing, statements) ->
|
|
pure (VariableOperand (Variable identifier), statements)
|
|
(AST.Identifier identifier, Just operand, statements) -> do
|
|
arrayAddress <- createTemporary
|
|
let arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress
|
|
pure
|
|
( VariableOperand arrayAddress
|
|
, Vector.snoc statements arrayStatement
|
|
) -}
|
|
where
|
|
binaryExpression f lhs rhs = do
|
|
(lhsOperand, lhsStatements) <- expression localTable lhs
|
|
(rhsOperand, rhsStatements) <- expression localTable rhs
|
|
tempVariable <- createTemporary
|
|
let newQuadruple = f lhsOperand rhsOperand tempVariable
|
|
pure
|
|
( VariableOperand tempVariable
|
|
, Vector.snoc (lhsStatements <> rhsStatements) newQuadruple
|
|
)
|
|
|
|
literal :: AST.Literal -> Operand Variable
|
|
literal (AST.IntegerLiteral integer) = IntOperand integer
|
|
literal (AST.HexadecimalLiteral integer) = IntOperand integer
|
|
literal (AST.CharacterLiteral character) = IntOperand $ fromIntegral character
|