Make IR for array access
This commit is contained in:
@ -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
|
||||
|
||||
@ -50,7 +50,7 @@ data Quadruple v
|
||||
| DivisionQuadruple (Operand v) (Operand v) v
|
||||
| GoToQuadruple Label
|
||||
| AssignQuadruple (Operand v) v
|
||||
{-| ArrayQuadruple Variable Operand Variable -}
|
||||
| ArrayQuadruple v (Operand v) v
|
||||
| ArrayAssignQuadruple (Operand v) (Operand v) v
|
||||
| LessOrEqualQuadruple (Operand v) (Operand v) Label
|
||||
| GreaterOrEqualQuadruple (Operand v) (Operand v) Label
|
||||
|
||||
Reference in New Issue
Block a user