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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Backend.Allocator
( MachineConfiguration(..)
, Store(..)
, allocate
) where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Int (Int32)
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)
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
| StackStore Int32 r
data AllocationError
= OutOfRegistersError
| UnexpectedProcedureInfoError Info
| UndefinedSymbolError Identifier
deriving Eq
instance Show AllocationError
where
show OutOfRegistersError = "Ran out of registers during register allocation"
show (UnexpectedProcedureInfoError info) =
"Expected to encounter a procedure, got: " <> show info
show (UndefinedSymbolError identifier) =
concat ["Symbol \"", show identifier, "\" is not defined"]
newtype MachineConfiguration r = MachineConfiguration
{ temporaryRegisters :: [r]
}
newtype MachineState = MachineState
{ symbolTable :: SymbolTable
} 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
-> SymbolTable
-> HashMap Identifier (Vector (Quadruple Variable))
-> Either AllocationError (HashMap Identifier (ProcedureQuadruples (Store r)))
allocate machineConfiguration globalTable = HashMap.traverseWithKey function
where
run localTable = flip runState (MachineState{ symbolTable = localTable })
. flip runReaderT machineConfiguration
. runExceptT
. runAllocator
. mapM quadruple
function :: Identifier -> Vector (Quadruple Variable) -> Either AllocationError (ProcedureQuadruples (Store r))
function procedureName quadruples' =
case SymbolTable.lookup procedureName globalTable of
Just (ProcedureInfo localTable _) ->
let (result, lastState) = run localTable quadruples'
in makeResult lastState <$> result
Just anotherInfo -> Left $ UnexpectedProcedureInfoError anotherInfo
Nothing -> Left $ UndefinedSymbolError procedureName
makeResult MachineState{ symbolTable } result = ProcedureQuadruples
{ quadruples = result
, stackSize = fromIntegral $ SymbolTable.size symbolTable * 4
}
quadruple :: Quadruple Variable -> Allocator r (Quadruple (Store r))
quadruple = \case
StartQuadruple -> pure StartQuadruple
StopQuadruple -> pure StopQuadruple
ParameterQuadruple operand1 -> ParameterQuadruple
<$> operand operand1
CallQuadruple name count -> pure $ 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 -> pure $ LabelQuadruple label
GoToQuadruple label -> pure $ GoToQuadruple label
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 -> 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 literalOperand) = pure $ IntOperand literalOperand
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 OutOfRegistersError) (pure . RegisterStore)
$ temporaryRegisters' !? fromIntegral index
storeVariable (LocalVariable index) = do
temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters"
maybe (Allocator $ throwE OutOfRegistersError) (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 OutOfRegistersError) (pure . StackStore (fromIntegral index * 4))
$ temporaryRegisters' !? fromIntegral index
|
