From 57b51c55387bc9e8993e1178b1ad0eb12308cd86 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sun, 24 Nov 2024 13:05:11 +0100 Subject: [PATCH] Implement the while loop --- .ruby-version | 2 +- lib/Language/Elna/Backend/Allocator.hs | 54 +++++++++++++--------- lib/Language/Elna/Frontend/AST.hs | 6 +-- lib/Language/Elna/Frontend/NameAnalysis.hs | 6 +-- lib/Language/Elna/Frontend/Parser.hs | 6 +-- lib/Language/Elna/Frontend/TypeAnalysis.hs | 4 +- lib/Language/Elna/Glue.hs | 4 +- src/Main.hs | 9 ++-- tests/expectations/print_after_loop.txt | 1 + tests/vm/print_after_loop.elna | 9 ++++ 10 files changed, 62 insertions(+), 39 deletions(-) create mode 100644 tests/expectations/print_after_loop.txt create mode 100644 tests/vm/print_after_loop.elna diff --git a/.ruby-version b/.ruby-version index fa7adc7..9c25013 100644 --- a/.ruby-version +++ b/.ruby-version @@ -1 +1 @@ -3.3.5 +3.3.6 diff --git a/lib/Language/Elna/Backend/Allocator.hs b/lib/Language/Elna/Backend/Allocator.hs index 9a85605..202fd5b 100644 --- a/lib/Language/Elna/Backend/Allocator.hs +++ b/lib/Language/Elna/Backend/Allocator.hs @@ -17,12 +17,21 @@ import Language.Elna.Location (Identifier(..)) import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT) import Control.Monad.Trans.State (State, runState, modify') import GHC.Records (HasField(..)) -import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE) +import Data.List ((!?)) data Store r = RegisterStore r | StackStore Word32 r +data AllocationError = AllocationError + deriving Eq + +instance Show AllocationError + where + show = const "Ran out of registers during register allocation" + newtype MachineConfiguration r = MachineConfiguration { temporaryRegisters :: [r] } @@ -32,7 +41,7 @@ newtype MachineState = MachineState } deriving (Eq, Show) newtype Allocator r a = Allocator - { runAllocator :: ReaderT (MachineConfiguration r) (State MachineState) a + { runAllocator :: ExceptT AllocationError (ReaderT (MachineConfiguration r) (State MachineState)) a } instance forall r. Functor (Allocator r) @@ -52,20 +61,22 @@ allocate :: forall r . MachineConfiguration r -> HashMap Identifier (Vector (Quadruple Variable)) - -> HashMap Identifier (ProcedureQuadruples (Store r)) -allocate machineConfiguration = fmap function + -> Either AllocationError (HashMap Identifier (ProcedureQuadruples (Store r))) +allocate machineConfiguration = traverse function where - function :: Vector (Quadruple Variable) -> ProcedureQuadruples (Store r) + run = flip runState (MachineState{ stackSize = 0 }) + . flip runReaderT machineConfiguration + . runExceptT + . runAllocator + . mapM quadruple + function :: Vector (Quadruple Variable) -> Either AllocationError (ProcedureQuadruples (Store r)) function quadruples' = - let (result, lastState) - = flip runState (MachineState{ stackSize = 0 }) - $ flip runReaderT machineConfiguration - $ runAllocator - $ mapM quadruple quadruples' - in ProcedureQuadruples - { quadruples = result - , stackSize = getField @"stackSize" lastState - } + let (result, lastState) = run quadruples' + in makeResult lastState <$> result + makeResult MachineState{ stackSize } result = ProcedureQuadruples + { quadruples = result + , stackSize = stackSize + } quadruple :: Quadruple Variable -> Allocator r (Quadruple (Store r)) quadruple = \case @@ -131,11 +142,12 @@ operand (VariableOperand variableOperand) = storeVariable :: Variable -> Allocator r (Store r) storeVariable (TempVariable index) = do - temporaryRegisters' <- Allocator $ asks $ getField @"temporaryRegisters" - pure $ RegisterStore - $ temporaryRegisters' !! fromIntegral index + temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters" + maybe (Allocator $ throwE AllocationError) (pure . RegisterStore) + $ temporaryRegisters' !? fromIntegral index + storeVariable (LocalVariable index) = do - temporaryRegisters' <- Allocator $ asks $ getField @"temporaryRegisters" - Allocator $ lift $ modify' $ MachineState . (+ 4) . getField @"stackSize" - pure $ StackStore (index * 4) - $ temporaryRegisters' !! pred (length temporaryRegisters' - fromIntegral index) + temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters" + Allocator $ lift $ lift $ modify' $ MachineState . (+ 4) . getField @"stackSize" + maybe (Allocator $ throwE AllocationError) (pure . StackStore (index * 4)) + $ temporaryRegisters' !? pred (length temporaryRegisters' - fromIntegral index) diff --git a/lib/Language/Elna/Frontend/AST.hs b/lib/Language/Elna/Frontend/AST.hs index e334370..df00d4b 100644 --- a/lib/Language/Elna/Frontend/AST.hs +++ b/lib/Language/Elna/Frontend/AST.hs @@ -71,7 +71,7 @@ data Statement = EmptyStatement | IfStatement Condition Statement (Maybe Statement) | AssignmentStatement VariableAccess Expression - -- | WhileStatement Condition Statement + | WhileStatement Condition Statement | CompoundStatement [Statement] | CallStatement Identifier [Expression] deriving Eq @@ -86,8 +86,8 @@ instance Show Statement ] show (AssignmentStatement lhs rhs) = concat [show lhs, " := ", show rhs, ";"] - {-show (WhileStatement expression statement) = - concat ["while (", show expression, ") ", show statement, ";"]-} + show (WhileStatement expression statement) = + concat ["while (", show expression, ") ", show statement, ";"] show (CompoundStatement statements) = concat ["{\n", unlines (show <$> statements), " }"] show (CallStatement name parameters) = show name <> "(" diff --git a/lib/Language/Elna/Frontend/NameAnalysis.hs b/lib/Language/Elna/Frontend/NameAnalysis.hs index 97a79e3..fbf5d51 100644 --- a/lib/Language/Elna/Frontend/NameAnalysis.hs +++ b/lib/Language/Elna/Frontend/NameAnalysis.hs @@ -175,9 +175,9 @@ statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement) statement globalTable (AST.AssignmentStatement lvalue rvalue) = variableAccess globalTable lvalue >> expression globalTable rvalue ---statement globalTable (AST.WhileStatement whileCondition loop) --- = condition globalTable whileCondition --- >> statement globalTable loop +statement globalTable (AST.WhileStatement whileCondition loop) + = condition globalTable whileCondition + >> statement globalTable loop condition :: SymbolTable -> AST.Condition -> NameAnalysis () condition globalTable (AST.EqualCondition lhs rhs) diff --git a/lib/Language/Elna/Frontend/Parser.hs b/lib/Language/Elna/Frontend/Parser.hs index 98638f7..570c91f 100644 --- a/lib/Language/Elna/Frontend/Parser.hs +++ b/lib/Language/Elna/Frontend/Parser.hs @@ -188,7 +188,7 @@ statementP <|> ifElseP <|> CompoundStatement <$> blockP (many statementP) <|> try assignmentP - -- <|> try whileP + <|> try whileP <|> callP "statement" where @@ -200,9 +200,9 @@ statementP <$> (symbol "if" *> parensP conditionP) <*> statementP <*> optional (symbol "else" *> statementP) - {-whileP = WhileStatement + whileP = WhileStatement <$> (symbol "while" *> parensP conditionP) - <*> statementP -} + <*> statementP assignmentP = AssignmentStatement <$> variableAccessP <* symbol ":=" diff --git a/lib/Language/Elna/Frontend/TypeAnalysis.hs b/lib/Language/Elna/Frontend/TypeAnalysis.hs index b9dcac1..c43e80e 100644 --- a/lib/Language/Elna/Frontend/TypeAnalysis.hs +++ b/lib/Language/Elna/Frontend/TypeAnalysis.hs @@ -101,11 +101,11 @@ statement globalTable = \case $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError lhsType unless (rhsType == intType) $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError rhsType - {- AST.WhileStatement whileCondition whileStatement -> do + AST.WhileStatement whileCondition whileStatement -> do conditionType <- condition globalTable whileCondition unless (conditionType == booleanType) $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType - statement globalTable whileStatement -} + statement globalTable whileStatement AST.IfStatement ifCondition ifStatement elseStatement -> do conditionType <- condition globalTable ifCondition unless (conditionType == booleanType) diff --git a/lib/Language/Elna/Glue.hs b/lib/Language/Elna/Glue.hs index 02a9b9f..7ee9e4a 100644 --- a/lib/Language/Elna/Glue.hs +++ b/lib/Language/Elna/Glue.hs @@ -131,7 +131,7 @@ statement localTable (AST.AssignmentStatement variableAccess' assignee) = do . AssignQuadruple rhsOperand <$> lookupLocal identifier pure $ rhsStatements <> lhsStatements -{- statement localTable (AST.WhileStatement whileCondition whileStatement) = do +statement localTable (AST.WhileStatement whileCondition whileStatement) = do (conditionStatements, jumpConstructor) <- condition localTable whileCondition startLabel <- createLabel endLabel <- createLabel @@ -141,7 +141,7 @@ statement localTable (AST.AssignmentStatement variableAccess' assignee) = do <> conditionStatements <> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel] <> whileStatements - <> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel] -} + <> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel] createTemporary :: Glue Variable createTemporary = do diff --git a/src/Main.hs b/src/Main.hs index 81e5976..0d1387f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -25,6 +25,7 @@ import Control.Exception (IOException, catch) -- 3 - Parse error. -- 4 - Name analysis error. -- 5 - Type error. +-- 6 - Register allocation error. main :: IO () main = execParser commandLine >>= withCommandLine @@ -45,9 +46,9 @@ main = execParser commandLine >>= withCommandLine | Just typeError <- typeAnalysis symbolTable program = printAndExit 5 typeError | otherwise = - let instructions = generateRiscV - $ allocate riscVConfiguration - $ glue symbolTable program - in elfObject output $ riscv32Elf instructions + let makeObject = elfObject output . riscv32Elf . generateRiscV + in either (printAndExit 6) makeObject + $ allocate riscVConfiguration + $ glue symbolTable program printAndExit :: Show b => forall a. Int -> b -> IO a printAndExit failureCode e = print e >> exitWith (ExitFailure failureCode) diff --git a/tests/expectations/print_after_loop.txt b/tests/expectations/print_after_loop.txt new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/tests/expectations/print_after_loop.txt @@ -0,0 +1 @@ +2 diff --git a/tests/vm/print_after_loop.elna b/tests/vm/print_after_loop.elna new file mode 100644 index 0000000..3fd9175 --- /dev/null +++ b/tests/vm/print_after_loop.elna @@ -0,0 +1,9 @@ +proc main() { + var x: int; + + x := 0; + while (x < 2) { + x := x + 1; + } + printi(x); +}