Adjust stack size based on local variables
This commit is contained in:
parent
276d4c963b
commit
0c9799b887
lib/Language/Elna
tests
@ -15,8 +15,9 @@ import Language.Elna.Backend.Intermediate
|
|||||||
)
|
)
|
||||||
import Language.Elna.Location (Identifier(..))
|
import Language.Elna.Location (Identifier(..))
|
||||||
import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
|
import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
|
||||||
import Control.Monad.Trans.State (State, runState)
|
import Control.Monad.Trans.State (State, runState, modify')
|
||||||
import GHC.Records (HasField(..))
|
import GHC.Records (HasField(..))
|
||||||
|
import Control.Monad.Trans.Class (MonadTrans(lift))
|
||||||
|
|
||||||
data Store r
|
data Store r
|
||||||
= RegisterStore r
|
= RegisterStore r
|
||||||
@ -26,8 +27,12 @@ newtype MachineConfiguration r = MachineConfiguration
|
|||||||
{ temporaryRegisters :: [r]
|
{ temporaryRegisters :: [r]
|
||||||
}
|
}
|
||||||
|
|
||||||
|
newtype MachineState = MachineState
|
||||||
|
{ stackSize :: Word32
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
newtype Allocator r a = Allocator
|
newtype Allocator r a = Allocator
|
||||||
{ runAllocator :: ReaderT (MachineConfiguration r) (State Word32) a
|
{ runAllocator :: ReaderT (MachineConfiguration r) (State MachineState) a
|
||||||
}
|
}
|
||||||
|
|
||||||
instance forall r. Functor (Allocator r)
|
instance forall r. Functor (Allocator r)
|
||||||
@ -51,13 +56,15 @@ allocate
|
|||||||
allocate machineConfiguration = fmap function
|
allocate machineConfiguration = fmap function
|
||||||
where
|
where
|
||||||
function :: Vector (Quadruple Variable) -> ProcedureQuadruples (Store r)
|
function :: Vector (Quadruple Variable) -> ProcedureQuadruples (Store r)
|
||||||
function quadruples' = ProcedureQuadruples
|
function quadruples' =
|
||||||
{ quadruples = fst
|
let (result, lastState)
|
||||||
$ flip runState 0
|
= flip runState (MachineState{ stackSize = 0 })
|
||||||
$ flip runReaderT machineConfiguration
|
$ flip runReaderT machineConfiguration
|
||||||
$ runAllocator
|
$ runAllocator
|
||||||
$ mapM quadruple quadruples'
|
$ mapM quadruple quadruples'
|
||||||
, stackSize = 0
|
in ProcedureQuadruples
|
||||||
|
{ quadruples = result
|
||||||
|
, stackSize = getField @"stackSize" lastState
|
||||||
}
|
}
|
||||||
|
|
||||||
quadruple :: Quadruple Variable -> Allocator r (Quadruple (Store r))
|
quadruple :: Quadruple Variable -> Allocator r (Quadruple (Store r))
|
||||||
@ -129,5 +136,6 @@ storeVariable (TempVariable index) = do
|
|||||||
$ temporaryRegisters' !! fromIntegral index
|
$ temporaryRegisters' !! fromIntegral index
|
||||||
storeVariable (LocalVariable index) = do
|
storeVariable (LocalVariable index) = do
|
||||||
temporaryRegisters' <- Allocator $ asks $ getField @"temporaryRegisters"
|
temporaryRegisters' <- Allocator $ asks $ getField @"temporaryRegisters"
|
||||||
pure $ RegisterStore
|
Allocator $ lift $ modify' $ MachineState . (+ 4) . getField @"stackSize"
|
||||||
|
pure $ StackStore (index * 4)
|
||||||
$ temporaryRegisters' !! pred (length temporaryRegisters' - fromIntegral index)
|
$ temporaryRegisters' !! pred (length temporaryRegisters' - fromIntegral index)
|
||||||
|
@ -102,7 +102,7 @@ statement localTable (AST.CallStatement (AST.Identifier callName) arguments) = d
|
|||||||
$ Vector.snoc (argumentStatements <> parameterStatements)
|
$ Vector.snoc (argumentStatements <> parameterStatements)
|
||||||
$ CallQuadruple callName
|
$ CallQuadruple callName
|
||||||
$ fromIntegral
|
$ fromIntegral
|
||||||
$ Vector.length argumentStatements
|
$ length arguments
|
||||||
statement localTable (AST.CompoundStatement statements) =
|
statement localTable (AST.CompoundStatement statements) =
|
||||||
fold <$> traverse (statement localTable) statements
|
fold <$> traverse (statement localTable) statements
|
||||||
statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) = do
|
statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) = do
|
||||||
|
@ -91,39 +91,45 @@ generateRiscV = flip evalState 0
|
|||||||
. foldlM go Vector.empty
|
. foldlM go Vector.empty
|
||||||
. HashMap.toList
|
. HashMap.toList
|
||||||
where
|
where
|
||||||
go accumulator (Identifier key, ProcedureQuadruples{ quadruples = value }) =
|
go accumulator (Identifier key, ProcedureQuadruples{ stackSize, quadruples = value }) =
|
||||||
let code = Vector.cons (JumpLabel key [GlobalDirective, FunctionDirective])
|
let code = Vector.cons (JumpLabel key [GlobalDirective, FunctionDirective])
|
||||||
. fold <$> mapM quadruple value
|
. fold <$> mapM (quadruple stackSize) value
|
||||||
in (accumulator <>) <$> code
|
in (accumulator <>) <$> code
|
||||||
|
|
||||||
quadruple :: RiscVQuadruple -> RiscVGenerator (Vector Statement)
|
quadruple :: Word32 -> RiscVQuadruple -> RiscVGenerator (Vector Statement)
|
||||||
quadruple StartQuadruple = pure $ Vector.fromList
|
quadruple stackSize StartQuadruple =
|
||||||
[ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate 4))
|
let totalStackSize = stackSize + 4
|
||||||
|
in pure $ Vector.fromList
|
||||||
|
[ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate totalStackSize))
|
||||||
, Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP RiscV.S0)
|
, Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP RiscV.S0)
|
||||||
, Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 4 RiscV.SW RiscV.SP RiscV.RA)
|
, Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 4 RiscV.SW RiscV.SP RiscV.RA)
|
||||||
, Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.S0 RiscV.ADDI RiscV.SP 4)
|
, Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.S0 RiscV.ADDI RiscV.SP totalStackSize)
|
||||||
]
|
]
|
||||||
quadruple (ParameterQuadruple operand1) =
|
quadruple stackSize StopQuadruple =
|
||||||
|
let totalStackSize = stackSize + 4
|
||||||
|
in pure $ Vector.fromList
|
||||||
|
[ Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.S0 RiscV.LW RiscV.SP 0)
|
||||||
|
, Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.RA RiscV.LW RiscV.SP 4)
|
||||||
|
, Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP totalStackSize)
|
||||||
|
, Instruction (RiscV.BaseInstruction RiscV.Jalr $ RiscV.I RiscV.RA RiscV.JALR RiscV.Zero 0)
|
||||||
|
]
|
||||||
|
quadruple _ (ParameterQuadruple operand1) =
|
||||||
let (operandRegister, statements) = loadImmediateOrRegister operand1 RiscV.A0
|
let (operandRegister, statements) = loadImmediateOrRegister operand1 RiscV.A0
|
||||||
in pure $ mappend statements $ Vector.fromList
|
in pure $ mappend statements $ Vector.fromList
|
||||||
[ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate 4))
|
[ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate 4))
|
||||||
, Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP operandRegister)
|
, Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP operandRegister)
|
||||||
]
|
]
|
||||||
quadruple (CallQuadruple callName numberOfArguments) = pure $ Vector.fromList
|
quadruple _ (CallQuadruple callName numberOfArguments) =
|
||||||
|
let restoreStackSize = numberOfArguments * 4
|
||||||
|
in pure $ Vector.fromList
|
||||||
[ Instruction (RiscV.CallInstruction callName)
|
[ Instruction (RiscV.CallInstruction callName)
|
||||||
, Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (numberOfArguments * 4))
|
, Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP restoreStackSize)
|
||||||
]
|
]
|
||||||
quadruple StopQuadruple = pure $ Vector.fromList
|
quadruple _ (AddQuadruple operand1 operand2 store) =
|
||||||
[ Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.S0 RiscV.LW RiscV.SP 0)
|
|
||||||
, Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.RA RiscV.LW RiscV.SP 4)
|
|
||||||
, Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP 4)
|
|
||||||
, Instruction (RiscV.BaseInstruction RiscV.Jalr $ RiscV.I RiscV.RA RiscV.JALR RiscV.Zero 0)
|
|
||||||
]
|
|
||||||
quadruple (AddQuadruple operand1 operand2 store) =
|
|
||||||
commutativeBinary (+) RiscV.ADD (RiscV.Funct7 0b0000000) (operand1, operand2) store
|
commutativeBinary (+) RiscV.ADD (RiscV.Funct7 0b0000000) (operand1, operand2) store
|
||||||
quadruple (ProductQuadruple operand1 operand2 store) =
|
quadruple _ (ProductQuadruple operand1 operand2 store) =
|
||||||
commutativeBinary (*) RiscV.MUL (RiscV.Funct7 0b0000001) (operand1, operand2) store
|
commutativeBinary (*) RiscV.MUL (RiscV.Funct7 0b0000001) (operand1, operand2) store
|
||||||
quadruple (SubtractionQuadruple operand1 operand2 store)
|
quadruple _ (SubtractionQuadruple operand1 operand2 store)
|
||||||
| IntOperand immediateOperand1 <- operand1
|
| IntOperand immediateOperand1 <- operand1
|
||||||
, IntOperand immediateOperand2 <- operand2 =
|
, IntOperand immediateOperand2 <- operand2 =
|
||||||
let (storeRegister, storeStatements) = storeToStore store
|
let (storeRegister, storeStatements) = storeToStore store
|
||||||
@ -158,7 +164,7 @@ quadruple (SubtractionQuadruple operand1 operand2 store)
|
|||||||
$ RiscV.R storeRegister RiscV.ADD storeRegister operandRegister1
|
$ RiscV.R storeRegister RiscV.ADD storeRegister operandRegister1
|
||||||
$ RiscV.Funct7 0b0000000
|
$ RiscV.Funct7 0b0000000
|
||||||
in pure $ statements1 <> statements2 <> Vector.cons instruction storeStatements
|
in pure $ statements1 <> statements2 <> Vector.cons instruction storeStatements
|
||||||
quadruple (NegationQuadruple operand1 store)
|
quadruple _ (NegationQuadruple operand1 store)
|
||||||
| IntOperand immediateOperand1 <- operand1 =
|
| IntOperand immediateOperand1 <- operand1 =
|
||||||
let (storeRegister, storeStatements) = storeToStore store
|
let (storeRegister, storeStatements) = storeToStore store
|
||||||
in pure $ lui (negate immediateOperand1) storeRegister <> storeStatements
|
in pure $ lui (negate immediateOperand1) storeRegister <> storeStatements
|
||||||
@ -170,7 +176,7 @@ quadruple (NegationQuadruple operand1 store)
|
|||||||
$ RiscV.R storeRegister RiscV.SUB RiscV.Zero operandRegister1
|
$ RiscV.R storeRegister RiscV.SUB RiscV.Zero operandRegister1
|
||||||
$ RiscV.Funct7 0b0100000
|
$ RiscV.Funct7 0b0100000
|
||||||
in pure $ statements1 <> Vector.cons instruction storeStatements
|
in pure $ statements1 <> Vector.cons instruction storeStatements
|
||||||
quadruple (DivisionQuadruple operand1 operand2 store)
|
quadruple _ (DivisionQuadruple operand1 operand2 store)
|
||||||
| IntOperand immediateOperand1 <- operand1
|
| IntOperand immediateOperand1 <- operand1
|
||||||
, IntOperand immediateOperand2 <- operand2 =
|
, IntOperand immediateOperand2 <- operand2 =
|
||||||
if immediateOperand2 == 0
|
if immediateOperand2 == 0
|
||||||
@ -228,21 +234,21 @@ quadruple (DivisionQuadruple operand1 operand2 store)
|
|||||||
, JumpLabel branchLabel []
|
, JumpLabel branchLabel []
|
||||||
, divisionInstruction
|
, divisionInstruction
|
||||||
] <> storeStatements
|
] <> storeStatements
|
||||||
quadruple (LabelQuadruple (Label label)) = pure $ Vector.singleton $ JumpLabel label mempty
|
quadruple _ (LabelQuadruple (Label label)) = pure $ Vector.singleton $ JumpLabel label mempty
|
||||||
quadruple (GoToQuadruple label) = pure $ Vector.singleton $ unconditionalJal label
|
quadruple _ (GoToQuadruple label) = pure $ Vector.singleton $ unconditionalJal label
|
||||||
quadruple (EqualQuadruple operand1 operand2 goToLabel) =
|
quadruple _ (EqualQuadruple operand1 operand2 goToLabel) =
|
||||||
commutativeComparison (==) RiscV.BEQ (operand1, operand2) goToLabel
|
commutativeComparison (==) RiscV.BEQ (operand1, operand2) goToLabel
|
||||||
quadruple (NonEqualQuadruple operand1 operand2 goToLabel) =
|
quadruple _ (NonEqualQuadruple operand1 operand2 goToLabel) =
|
||||||
commutativeComparison (/=) RiscV.BNE (operand1, operand2) goToLabel
|
commutativeComparison (/=) RiscV.BNE (operand1, operand2) goToLabel
|
||||||
quadruple (LessQuadruple operand1 operand2 goToLabel) =
|
quadruple _ (LessQuadruple operand1 operand2 goToLabel) =
|
||||||
lessThan (operand1, operand2) goToLabel
|
lessThan (operand1, operand2) goToLabel
|
||||||
quadruple (GreaterQuadruple operand1 operand2 goToLabel) =
|
quadruple _ (GreaterQuadruple operand1 operand2 goToLabel) =
|
||||||
lessThan (operand2, operand1) goToLabel
|
lessThan (operand2, operand1) goToLabel
|
||||||
quadruple (LessOrEqualQuadruple operand1 operand2 goToLabel) =
|
quadruple _ (LessOrEqualQuadruple operand1 operand2 goToLabel) =
|
||||||
lessOrEqualThan (operand1, operand2) goToLabel
|
lessOrEqualThan (operand1, operand2) goToLabel
|
||||||
quadruple (GreaterOrEqualQuadruple operand1 operand2 goToLabel) =
|
quadruple _ (GreaterOrEqualQuadruple operand1 operand2 goToLabel) =
|
||||||
lessOrEqualThan (operand2, operand1) goToLabel
|
lessOrEqualThan (operand2, operand1) goToLabel
|
||||||
quadruple (AssignQuadruple operand1 store)
|
quadruple _ (AssignQuadruple operand1 store)
|
||||||
| IntOperand immediateOperand1 <- operand1 =
|
| IntOperand immediateOperand1 <- operand1 =
|
||||||
let (storeRegister, storeStatements) = storeToStore store
|
let (storeRegister, storeStatements) = storeToStore store
|
||||||
in pure $ lui immediateOperand1 storeRegister <> storeStatements
|
in pure $ lui immediateOperand1 storeRegister <> storeStatements
|
||||||
@ -432,7 +438,7 @@ loadFromStore (RegisterStore register) = (register, mempty)
|
|||||||
loadFromStore (StackStore offset register) =
|
loadFromStore (StackStore offset register) =
|
||||||
let loadInstruction = Instruction
|
let loadInstruction = Instruction
|
||||||
$ RiscV.BaseInstruction RiscV.Load
|
$ RiscV.BaseInstruction RiscV.Load
|
||||||
$ RiscV.I register RiscV.LW RiscV.SP offset
|
$ RiscV.I register RiscV.LW RiscV.S0 offset
|
||||||
in (register, Vector.singleton loadInstruction)
|
in (register, Vector.singleton loadInstruction)
|
||||||
|
|
||||||
storeToStore :: RiscVStore -> (RiscV.XRegister, Vector Statement)
|
storeToStore :: RiscVStore -> (RiscV.XRegister, Vector Statement)
|
||||||
@ -440,5 +446,5 @@ storeToStore (RegisterStore register) = (register, mempty)
|
|||||||
storeToStore (StackStore offset register) =
|
storeToStore (StackStore offset register) =
|
||||||
let storeInstruction = Instruction
|
let storeInstruction = Instruction
|
||||||
$ RiscV.BaseInstruction RiscV.Store
|
$ RiscV.BaseInstruction RiscV.Store
|
||||||
$ RiscV.S offset RiscV.SW RiscV.SP register
|
$ RiscV.S offset RiscV.SW RiscV.S0 register
|
||||||
in (register, Vector.singleton storeInstruction)
|
in (register, Vector.singleton storeInstruction)
|
||||||
|
2
tests/expectations/two_variables.txt
Normal file
2
tests/expectations/two_variables.txt
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
58
|
||||||
|
28
|
10
tests/vm/two_variables.elna
Normal file
10
tests/vm/two_variables.elna
Normal file
@ -0,0 +1,10 @@
|
|||||||
|
proc main() {
|
||||||
|
var i: int;
|
||||||
|
var j: int;
|
||||||
|
|
||||||
|
i := 58;
|
||||||
|
j := 28;
|
||||||
|
|
||||||
|
printi(i);
|
||||||
|
printi(j);
|
||||||
|
}
|
Loading…
Reference in New Issue
Block a user