1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
module Language.Elna.Backend.Allocator
( MachineConfiguration(..)
, Store(..)
, allocate
) where
import Data.HashMap.Strict (HashMap)
import Data.Int (Int32)
import Data.Word (Word32)
import Data.Vector (Vector)
import Language.Elna.Backend.Intermediate
( ProcedureQuadruples(..)
, Operand(..)
, Quadruple(..)
, Variable(..)
)
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(..))
import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
import Data.List ((!?))
data Store r
= RegisterStore r
| StackStore Int32 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]
}
newtype MachineState = MachineState
{ stackSize :: Word32
} deriving (Eq, Show)
newtype Allocator r a = Allocator
{ runAllocator :: ExceptT AllocationError (ReaderT (MachineConfiguration r) (State MachineState)) 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))
-> Either AllocationError (HashMap Identifier (ProcedureQuadruples (Store r)))
allocate machineConfiguration = traverse function
where
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) = 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
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 $ lift $ asks $ getField @"temporaryRegisters"
maybe (Allocator $ throwE AllocationError) (pure . RegisterStore)
$ 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
temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters"
maybe (Allocator $ throwE AllocationError) (pure . StackStore (fromIntegral index * 4))
$ temporaryRegisters' !? fromIntegral index
|
