diff options
Diffstat (limited to 'lib/Language/Elna/Backend/Allocator.hs')
| -rw-r--r-- | lib/Language/Elna/Backend/Allocator.hs | 127 |
1 files changed, 67 insertions, 60 deletions
diff --git a/lib/Language/Elna/Backend/Allocator.hs b/lib/Language/Elna/Backend/Allocator.hs index acdf3e5..df50d6e 100644 --- a/lib/Language/Elna/Backend/Allocator.hs +++ b/lib/Language/Elna/Backend/Allocator.hs @@ -5,6 +5,7 @@ module Language.Elna.Backend.Allocator ) where import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.Int (Int32) import Data.Word (Word32) import Data.Vector (Vector) @@ -16,11 +17,13 @@ import Language.Elna.Backend.Intermediate ) import Language.Elna.Location (Identifier(..)) import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT) -import Control.Monad.Trans.State (State, runState, modify') +import Control.Monad.Trans.State (State, runState) import GHC.Records (HasField(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE) import Data.List ((!?)) +import Language.Elna.Frontend.SymbolTable (Info(..), SymbolTable) +import qualified Language.Elna.Frontend.SymbolTable as SymbolTable data Store r = RegisterStore r @@ -38,7 +41,7 @@ newtype MachineConfiguration r = MachineConfiguration } newtype MachineState = MachineState - { stackSize :: Word32 + { symbolTable :: SymbolTable } deriving (Eq, Show) newtype Allocator r a = Allocator @@ -61,87 +64,92 @@ instance forall r. Monad (Allocator r) allocate :: forall r . MachineConfiguration r + -> SymbolTable -> HashMap Identifier (Vector (Quadruple Variable)) -> Either AllocationError (HashMap Identifier (ProcedureQuadruples (Store r))) -allocate machineConfiguration = traverse function +allocate machineConfiguration globalTable = HashMap.traverseWithKey function where - run = flip runState (MachineState{ stackSize = 0 }) + run localTable = flip runState (MachineState{ symbolTable = localTable }) . flip runReaderT machineConfiguration . runExceptT . runAllocator . mapM quadruple - function :: Vector (Quadruple Variable) -> Either AllocationError (ProcedureQuadruples (Store r)) - function quadruples' = - let (result, lastState) = run quadruples' + function :: Identifier -> Vector (Quadruple Variable) -> Either AllocationError (ProcedureQuadruples (Store r)) + function identifier quadruples' = + let Just (ProcedureInfo localTable _) = SymbolTable.lookup identifier globalTable + (result, lastState) = run localTable quadruples' in makeResult lastState <$> result - makeResult MachineState{ stackSize } result = ProcedureQuadruples + makeResult MachineState{ symbolTable } result = ProcedureQuadruples { quadruples = result - , stackSize = stackSize + , stackSize = fromIntegral $ SymbolTable.size symbolTable * 4 } quadruple :: Quadruple Variable -> Allocator r (Quadruple (Store r)) quadruple = \case StartQuadruple -> pure StartQuadruple StopQuadruple -> pure StopQuadruple - ParameterQuadruple operand1 -> do - operand1' <- operand operand1 - pure $ ParameterQuadruple operand1' + ParameterQuadruple operand1 -> ParameterQuadruple + <$> operand operand1 CallQuadruple name count -> pure $ CallQuadruple name count - AddQuadruple operand1 operand2 variable -> do - operand1' <- operand operand1 - operand2' <- operand operand2 - AddQuadruple operand1' operand2' <$> storeVariable variable - SubtractionQuadruple operand1 operand2 variable -> do - operand1' <- operand operand1 - operand2' <- operand operand2 - SubtractionQuadruple operand1' operand2' <$> storeVariable variable - NegationQuadruple operand1 variable -> do - operand1' <- operand operand1 - NegationQuadruple operand1' <$> storeVariable variable - ProductQuadruple operand1 operand2 variable -> do - operand1' <- operand operand1 - operand2' <- operand operand2 - ProductQuadruple operand1' operand2' <$> storeVariable variable - DivisionQuadruple operand1 operand2 variable -> do - operand1' <- operand operand1 - operand2' <- operand operand2 - DivisionQuadruple operand1' operand2' <$> storeVariable variable + AddQuadruple operand1 operand2 variable -> AddQuadruple + <$> operand operand1 + <*> operand operand2 + <*> storeVariable variable + SubtractionQuadruple operand1 operand2 variable -> SubtractionQuadruple + <$> operand operand1 + <*> operand operand2 + <*> storeVariable variable + NegationQuadruple operand1 variable -> NegationQuadruple + <$> operand operand1 + <*> storeVariable variable + ProductQuadruple operand1 operand2 variable -> ProductQuadruple + <$> operand operand1 + <*> operand operand2 + <*> storeVariable variable + DivisionQuadruple operand1 operand2 variable -> DivisionQuadruple + <$> operand operand1 + <*> operand operand2 + <*> storeVariable variable LabelQuadruple label -> pure $ LabelQuadruple label GoToQuadruple label -> pure $ GoToQuadruple label - EqualQuadruple operand1 operand2 goToLabel -> do - operand1' <- operand operand1 - operand2' <- operand operand2 - pure $ EqualQuadruple operand1' operand2' goToLabel - NonEqualQuadruple operand1 operand2 goToLabel -> do - operand1' <- operand operand1 - operand2' <- operand operand2 - pure $ NonEqualQuadruple operand1' operand2' goToLabel - LessQuadruple operand1 operand2 goToLabel -> do - operand1' <- operand operand1 - operand2' <- operand operand2 - pure $ LessQuadruple operand1' operand2' goToLabel + EqualQuadruple operand1 operand2 goToLabel -> EqualQuadruple + <$> operand operand1 + <*> operand operand2 + <*> pure goToLabel + NonEqualQuadruple operand1 operand2 goToLabel -> NonEqualQuadruple + <$> operand operand1 + <*> operand operand2 + <*> pure goToLabel + LessQuadruple operand1 operand2 goToLabel -> LessQuadruple + <$> operand operand1 + <*> operand operand2 + <*> pure goToLabel GreaterQuadruple operand1 operand2 goToLabel -> do operand1' <- operand operand1 operand2' <- operand operand2 pure $ GreaterQuadruple operand1' operand2' goToLabel - LessOrEqualQuadruple operand1 operand2 goToLabel -> do - operand1' <- operand operand1 - operand2' <- operand operand2 - pure $ LessOrEqualQuadruple operand1' operand2' goToLabel - GreaterOrEqualQuadruple operand1 operand2 goToLabel -> do - operand1' <- operand operand1 - operand2' <- operand operand2 - pure $ GreaterOrEqualQuadruple operand1' operand2' goToLabel - AssignQuadruple operand1 variable -> do - operand1' <- operand operand1 - AssignQuadruple operand1' <$> storeVariable variable - ArrayAssignQuadruple operand1 operand2 variable -> do - operand1' <- operand operand1 - operand2' <- operand operand2 - ArrayAssignQuadruple operand1' operand2' <$> storeVariable variable + LessOrEqualQuadruple operand1 operand2 goToLabel -> LessOrEqualQuadruple + <$> operand operand1 + <*> operand operand2 + <*> pure goToLabel + GreaterOrEqualQuadruple operand1 operand2 goToLabel -> GreaterOrEqualQuadruple + <$> operand operand1 + <*> operand operand2 + <*> pure goToLabel + AssignQuadruple operand1 variable -> AssignQuadruple + <$> operand operand1 + <*> storeVariable variable + ArrayAssignQuadruple operand1 operand2 variable -> ArrayAssignQuadruple + <$> operand operand1 + <*> operand operand2 + <*> storeVariable variable + ArrayQuadruple variable1 operand1 variable2 -> ArrayQuadruple + <$> storeVariable variable1 + <*> operand operand1 + <*> storeVariable variable2 operand :: Operand Variable -> Allocator r (Operand (Store r)) -operand (IntOperand x) = pure $ IntOperand x +operand (IntOperand literalOperand) = pure $ IntOperand literalOperand operand (VariableOperand variableOperand) = VariableOperand <$> storeVariable variableOperand @@ -152,7 +160,6 @@ storeVariable (TempVariable index) = do $ temporaryRegisters' !? fromIntegral index storeVariable (LocalVariable index) = do temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters" - Allocator $ lift $ lift $ modify' $ MachineState . (+ 4) . getField @"stackSize" maybe (Allocator $ throwE AllocationError) (pure . StackStore (fromIntegral (succ index) * (-4))) $ temporaryRegisters' !? pred (length temporaryRegisters' - fromIntegral index) storeVariable (ParameterVariable index) = do |