Split the allocator and add state to it

1 files changed, 98 insertions, 48 deletions

diff --git a/lib/Language/Elna/Backend/Allocator.hs b/lib/Language/Elna/Backend/Allocator.hs
index ac54c78..6c379dc 100644
--- a/lib/Language/Elna/Backend/Allocator.hs
+++ b/lib/Language/Elna/Backend/Allocator.hs
@@ -14,6 +14,9 @@ import Language.Elna.Backend.Intermediate
     , Variable(..)
     )
 import Language.Elna.Location (Identifier(..))
+import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
+import Control.Monad.Trans.State (State, runState)
+import GHC.Records (HasField(..))
 
 data Store r
     = RegisterStore r
@@ -23,61 +26,108 @@ newtype MachineConfiguration r = MachineConfiguration
     { temporaryRegisters :: [r]
     }
 
+newtype Allocator r a = Allocator
+    { runAllocator :: ReaderT (MachineConfiguration r) (State Word32) a
+    }
+
+instance forall r. Functor (Allocator r)
+  where
+    fmap f = Allocator . fmap f . runAllocator
+
+instance forall r. Applicative (Allocator r)
+  where
+    pure = Allocator . pure
+    (Allocator x) <*> (Allocator y) = Allocator $ x <*> y
+
+instance forall r. Monad (Allocator r)
+  where
+    (Allocator allocator) >>= f = Allocator $ allocator >>= (runAllocator . f)
+
 allocate
     :: forall r
     . MachineConfiguration r
     -> HashMap Identifier (Vector (Quadruple Variable))
     -> HashMap Identifier (ProcedureQuadruples (Store r))
-allocate MachineConfiguration{..} = fmap function
+allocate machineConfiguration = fmap function
   where
     function :: Vector (Quadruple Variable) -> ProcedureQuadruples (Store r)
     function quadruples' = ProcedureQuadruples
-        { quadruples = quadruple <$> quadruples'
+        { quadruples = fst
+            $ flip runState 0
+            $ flip runReaderT machineConfiguration
+            $ runAllocator
+            $ mapM quadruple quadruples'
         , stackSize = 0
         }
-    quadruple :: Quadruple Variable -> Quadruple (Store r)
-    quadruple = \case
-        StartQuadruple -> StartQuadruple
-        StopQuadruple -> StopQuadruple
-        ParameterQuadruple operand1 ->
-            ParameterQuadruple (operand operand1)
-        CallQuadruple name count -> CallQuadruple name count
-        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 -> LabelQuadruple label
-        GoToQuadruple label -> GoToQuadruple label
-        EqualQuadruple operand1 operand2 goToLabel ->
-            EqualQuadruple (operand operand1) (operand operand2) goToLabel
-        NonEqualQuadruple operand1 operand2 goToLabel ->
-            NonEqualQuadruple (operand operand1) (operand operand2) goToLabel
-        LessQuadruple operand1 operand2 goToLabel ->
-            LessQuadruple (operand operand1) (operand operand2) goToLabel
-        GreaterQuadruple operand1 operand2 goToLabel ->
-            GreaterQuadruple (operand operand1) (operand operand2) goToLabel
-        LessOrEqualQuadruple operand1 operand2 goToLabel ->
-            LessOrEqualQuadruple (operand operand1) (operand operand2) goToLabel
-        GreaterOrEqualQuadruple operand1 operand2 goToLabel ->
-            GreaterOrEqualQuadruple (operand operand1) (operand operand2) goToLabel
-        AssignQuadruple operand1 variable ->
-            AssignQuadruple (operand operand1) $ storeVariable variable
-    operand :: Operand Variable -> Operand (Store r)
-    operand (IntOperand x) = IntOperand x
-    operand (VariableOperand variableOperand) =
-        VariableOperand $ storeVariable variableOperand
-    storeVariable (TempVariable index) = RegisterStore
-        $ temporaryRegisters !! fromIntegral index
-    storeVariable (LocalVariable index) = RegisterStore
-        $ temporaryRegisters !! pred (length temporaryRegisters - fromIntegral index)
+
+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'
+    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
+    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
+    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
+
+operand :: Operand Variable -> Allocator r (Operand (Store r))
+operand (IntOperand x) = pure $ IntOperand x
+operand (VariableOperand variableOperand) =
+    VariableOperand <$> storeVariable variableOperand
+
+storeVariable :: Variable -> Allocator r (Store r)
+storeVariable (TempVariable index) = do
+    temporaryRegisters' <- Allocator $ asks $ getField @"temporaryRegisters"
+    pure $ RegisterStore
+        $ temporaryRegisters' !! fromIntegral index
+storeVariable (LocalVariable index) = do
+    temporaryRegisters' <- Allocator $ asks $ getField @"temporaryRegisters"
+    pure $ RegisterStore
+        $ temporaryRegisters' !! pred (length temporaryRegisters' - fromIntegral index)