belka/elna
1
0
Fork 0
Code Issues 5 Pull Requests Releases Activity

Implement the while loop

Browse Source
This commit is contained in:
Eugen Wissner
2024-11-24 13:05:11 +01:00
parent 0c9799b887
commit 57b51c5538
10 changed files with 62 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files

54
lib/Language/Elna/Backend/Allocator.hs
View File

@ -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)