diff --git a/TODO b/TODO index e1bdc64..e676d1d 100644 --- a/TODO +++ b/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. diff --git a/elna.cabal b/elna.cabal index e82cffc..9f07012 100644 --- a/elna.cabal +++ b/elna.cabal @@ -21,6 +21,7 @@ common warnings text ^>= 2.0 ghc-options: -Wall default-extensions: + DataKinds, ExplicitForAll, LambdaCase, OverloadedStrings, diff --git a/lib/Language/Elna/Intermediate.hs b/lib/Language/Elna/Intermediate.hs index c2445ae..0cda806 100644 --- a/lib/Language/Elna/Intermediate.hs +++ b/lib/Language/Elna/Intermediate.hs @@ -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