276 lines
17 KiB
Haskell
276 lines
17 KiB
Haskell
module ByteCode.Assembler where
|
|
|
|
import ByteCode.Constants
|
|
import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..), opcodeEncodingLength)
|
|
import ByteCode.Util
|
|
import Ast
|
|
import Data.Char
|
|
import Data.List
|
|
import Data.Word
|
|
|
|
type Assembler a = ([ConstantInfo], [Operation], [String]) -> a -> ([ConstantInfo], [Operation], [String])
|
|
|
|
assembleExpression :: Assembler Expression
|
|
assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation op a b))
|
|
| op `elem` [Addition, Subtraction, Multiplication, Division, Modulo, BitwiseAnd, BitwiseOr, BitwiseXor, And, Or] = let
|
|
(aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a
|
|
(bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b
|
|
in
|
|
(bConstants, bOps ++ [binaryOperation op], lvars)
|
|
| op `elem` [CompareEqual, CompareNotEqual, CompareLessThan, CompareLessOrEqual, CompareGreaterThan, CompareGreaterOrEqual] = let
|
|
(aConstants, aOps, _) = assembleExpression (constants, ops, lvars) a
|
|
(bConstants, bOps, _) = assembleExpression (aConstants, aOps, lvars) b
|
|
cmp_op = comparisonOperation op 9
|
|
cmp_ops = [cmp_op, Opsipush 0, Opgoto 6, Opsipush 1]
|
|
in
|
|
(bConstants, bOps ++ cmp_ops, lvars)
|
|
|
|
assembleExpression (constants, ops, lvars) (TypedExpression _ (BinaryOperation NameResolution (TypedExpression atype a) (TypedExpression btype (FieldVariable b)))) = let
|
|
(fConstants, fieldIndex) = getFieldIndex constants (atype, b, datatypeDescriptor btype)
|
|
(aConstants, aOps, _) = assembleExpression (fConstants, ops, lvars) (TypedExpression atype a)
|
|
in
|
|
(aConstants, aOps ++ [Opgetfield (fromIntegral fieldIndex)], lvars)
|
|
|
|
assembleExpression (constants, ops, lvars) (TypedExpression _ (CharacterLiteral literal)) =
|
|
(constants, ops ++ [Opsipush (fromIntegral (ord literal))], lvars)
|
|
|
|
assembleExpression (constants, ops, lvars) (TypedExpression _ (BooleanLiteral literal)) =
|
|
(constants, ops ++ [Opsipush (if literal then 1 else 0)], lvars)
|
|
|
|
assembleExpression (constants, ops, lvars) (TypedExpression _ (IntegerLiteral literal))
|
|
| literal <= 32767 && literal >= -32768 = (constants, ops ++ [Opsipush (fromIntegral literal)], lvars)
|
|
| otherwise = (constants ++ [IntegerInfo (fromIntegral literal)], ops ++ [Opldc_w (fromIntegral (1 + length constants))], lvars)
|
|
|
|
assembleExpression (constants, ops, lvars) (TypedExpression _ NullLiteral) =
|
|
(constants, ops ++ [Opaconst_null], lvars)
|
|
|
|
assembleExpression (constants, ops, lvars) (TypedExpression etype (UnaryOperation Not expr)) = let
|
|
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
|
|
newConstant = fromIntegral (1 + length exprConstants)
|
|
in case etype of
|
|
"int" -> (exprConstants ++ [IntegerInfo 0x7FFFFFFF], exprOps ++ [Opldc_w newConstant, Opixor], lvars)
|
|
"char" -> (exprConstants, exprOps ++ [Opsipush 0xFFFF, Opixor], lvars)
|
|
"boolean" -> (exprConstants, exprOps ++ [Opsipush 0x01, Opixor], lvars)
|
|
|
|
assembleExpression (constants, ops, lvars) (TypedExpression _ (UnaryOperation Minus expr)) = let
|
|
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
|
|
in
|
|
(exprConstants, exprOps ++ [Opineg], lvars)
|
|
|
|
assembleExpression (constants, ops, lvars) (TypedExpression dtype (LocalVariable name))
|
|
| name == "this" = (constants, ops ++ [Opaload 0], lvars)
|
|
| otherwise = let
|
|
localIndex = elemIndex name lvars
|
|
isPrimitive = elem dtype ["char", "boolean", "int"]
|
|
in case localIndex of
|
|
Just index -> (constants, ops ++ if isPrimitive then [Opiload (fromIntegral index)] else [Opaload (fromIntegral index)], lvars)
|
|
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
|
|
|
assembleExpression (constants, ops, lvars) (TypedExpression dtype (StatementExpressionExpression stmtexp)) =
|
|
assembleStatementExpression (constants, ops, lvars) stmtexp
|
|
|
|
assembleExpression _ expr = error ("Unknown expression: " ++ show expr)
|
|
|
|
assembleNameChain :: Assembler Expression
|
|
assembleNameChain input (TypedExpression _ (BinaryOperation NameResolution (TypedExpression atype a) (TypedExpression _ (FieldVariable _)))) =
|
|
assembleExpression input (TypedExpression atype a)
|
|
assembleNameChain input expr = assembleExpression input expr
|
|
|
|
|
|
assembleStatementExpression :: Assembler StatementExpression
|
|
assembleStatementExpression
|
|
(constants, ops, lvars)
|
|
(TypedStatementExpression _ (Assignment (TypedExpression dtype receiver) expr)) = let
|
|
target = resolveNameChain (TypedExpression dtype receiver)
|
|
in case target of
|
|
(TypedExpression dtype (LocalVariable name)) -> let
|
|
localIndex = elemIndex name lvars
|
|
(constants_a, ops_a, _) = assembleExpression (constants, ops, lvars) expr
|
|
isPrimitive = elem dtype ["char", "boolean", "int"]
|
|
in case localIndex of
|
|
Just index -> (constants_a, ops_a ++ if isPrimitive then [Opdup, Opistore (fromIntegral index)] else [Opastore (fromIntegral index)], lvars)
|
|
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
|
(TypedExpression dtype (FieldVariable name)) -> let
|
|
owner = resolveNameChainOwner (TypedExpression dtype receiver)
|
|
in case owner of
|
|
(TypedExpression otype _) -> let
|
|
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
|
|
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
|
|
(constants_a, ops_a, _) = assembleExpression (constants_r, ops_r, lvars) expr
|
|
in
|
|
(constants_a, ops_a ++ [Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars)
|
|
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
|
|
|
|
assembleStatementExpression
|
|
(constants, ops, lvars)
|
|
(TypedStatementExpression _ (PreIncrement (TypedExpression dtype receiver))) = let
|
|
target = resolveNameChain (TypedExpression dtype receiver)
|
|
in case target of
|
|
(TypedExpression dtype (LocalVariable name)) -> let
|
|
localIndex = elemIndex name lvars
|
|
expr = TypedExpression dtype (LocalVariable name)
|
|
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
|
|
in case localIndex of
|
|
Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opiadd, Opdup, Opistore (fromIntegral index)], lvars)
|
|
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
|
(TypedExpression dtype (FieldVariable name)) -> let
|
|
owner = resolveNameChainOwner (TypedExpression dtype receiver)
|
|
in case owner of
|
|
(TypedExpression otype _) -> let
|
|
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
|
|
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
|
|
in
|
|
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opsipush 1, Opiadd, Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars)
|
|
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
|
|
|
|
assembleStatementExpression
|
|
(constants, ops, lvars)
|
|
(TypedStatementExpression _ (PreDecrement (TypedExpression dtype receiver))) = let
|
|
target = resolveNameChain (TypedExpression dtype receiver)
|
|
in case target of
|
|
(TypedExpression dtype (LocalVariable name)) -> let
|
|
localIndex = elemIndex name lvars
|
|
expr = TypedExpression dtype (LocalVariable name)
|
|
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
|
|
in case localIndex of
|
|
Just index -> (exprConstants, exprOps ++ [Opsipush 1, Opisub, Opdup, Opistore (fromIntegral index)], lvars)
|
|
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
|
(TypedExpression dtype (FieldVariable name)) -> let
|
|
owner = resolveNameChainOwner (TypedExpression dtype receiver)
|
|
in case owner of
|
|
(TypedExpression otype _) -> let
|
|
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
|
|
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
|
|
in
|
|
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opsipush 1, Opisub, Opdup_x1, Opputfield (fromIntegral fieldIndex)], lvars)
|
|
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
|
|
|
|
assembleStatementExpression
|
|
(constants, ops, lvars)
|
|
(TypedStatementExpression _ (PostIncrement (TypedExpression dtype receiver))) = let
|
|
target = resolveNameChain (TypedExpression dtype receiver)
|
|
in case target of
|
|
(TypedExpression dtype (LocalVariable name)) -> let
|
|
localIndex = elemIndex name lvars
|
|
expr = TypedExpression dtype (LocalVariable name)
|
|
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
|
|
in case localIndex of
|
|
Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opiadd, Opistore (fromIntegral index)], lvars)
|
|
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
|
(TypedExpression dtype (FieldVariable name)) -> let
|
|
owner = resolveNameChainOwner (TypedExpression dtype receiver)
|
|
in case owner of
|
|
(TypedExpression otype _) -> let
|
|
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
|
|
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
|
|
in
|
|
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opdup_x1, Opsipush 1, Opiadd, Opputfield (fromIntegral fieldIndex)], lvars)
|
|
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
|
|
|
|
assembleStatementExpression
|
|
(constants, ops, lvars)
|
|
(TypedStatementExpression _ (PostDecrement (TypedExpression dtype receiver))) = let
|
|
target = resolveNameChain (TypedExpression dtype receiver)
|
|
in case target of
|
|
(TypedExpression dtype (LocalVariable name)) -> let
|
|
localIndex = elemIndex name lvars
|
|
expr = TypedExpression dtype (LocalVariable name)
|
|
(exprConstants, exprOps, _) = assembleExpression (constants, ops, lvars) expr
|
|
in case localIndex of
|
|
Just index -> (exprConstants, exprOps ++ [Opdup, Opsipush 1, Opisub, Opistore (fromIntegral index)], lvars)
|
|
Nothing -> error ("No such local variable found in local variable pool: " ++ name)
|
|
(TypedExpression dtype (FieldVariable name)) -> let
|
|
owner = resolveNameChainOwner (TypedExpression dtype receiver)
|
|
in case owner of
|
|
(TypedExpression otype _) -> let
|
|
(constants_f, fieldIndex) = getFieldIndex constants (otype, name, datatypeDescriptor dtype)
|
|
(constants_r, ops_r, _) = assembleNameChain (constants_f, ops, lvars) (TypedExpression dtype receiver)
|
|
in
|
|
(constants_r, ops_r ++ [Opdup, Opgetfield (fromIntegral fieldIndex), Opdup_x1, Opsipush 1, Opisub, Opputfield (fromIntegral fieldIndex)], lvars)
|
|
something_else -> error ("Expected TypedExpression, but got: " ++ show something_else)
|
|
|
|
assembleStatementExpression
|
|
(constants, ops, lvars)
|
|
(TypedStatementExpression rtype (MethodCall (TypedExpression otype receiver) name params)) = let
|
|
(constants_r, ops_r, lvars_r) = assembleExpression (constants, ops, lvars) (TypedExpression otype receiver)
|
|
(constants_p, ops_p, lvars_p) = foldl assembleExpression (constants_r, ops_r, lvars_r) params
|
|
(constants_m, methodIndex) = getMethodIndex constants_p (otype, name, methodDescriptorFromParamlist params rtype)
|
|
in
|
|
(constants_m, ops_p ++ [Opinvokevirtual (fromIntegral methodIndex)], lvars_p)
|
|
|
|
assembleStatementExpression
|
|
(constants, ops, lvars)
|
|
(TypedStatementExpression rtype (ConstructorCall name params)) = let
|
|
(constants_c, classIndex) = getClassIndex constants name
|
|
(constants_p, ops_p, lvars_p) = foldl assembleExpression (constants_c, ops ++ [Opnew (fromIntegral classIndex), Opdup], lvars) params
|
|
(constants_m, methodIndex) = getMethodIndex constants_p (name, "<init>", methodDescriptorFromParamlist params "void")
|
|
in
|
|
(constants_m, ops_p ++ [Opinvokespecial (fromIntegral methodIndex)], lvars_p)
|
|
|
|
|
|
assembleStatement :: Assembler Statement
|
|
assembleStatement (constants, ops, lvars) (TypedStatement stype (Return expr)) = case expr of
|
|
Nothing -> (constants, ops ++ [Opreturn], lvars)
|
|
Just expr -> let
|
|
(expr_constants, expr_ops, _) = assembleExpression (constants, ops, lvars) expr
|
|
in
|
|
(expr_constants, expr_ops ++ [returnOperation stype], lvars)
|
|
|
|
assembleStatement (constants, ops, lvars) (TypedStatement _ (Block statements)) =
|
|
foldl assembleStatement (constants, ops, lvars) statements
|
|
|
|
assembleStatement (constants, ops, lvars) (TypedStatement dtype (If expr if_stmt else_stmt)) = let
|
|
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
|
|
(constants_ifa, ops_ifa, lvars_ifa) = assembleStatement (constants_cmp, [], lvars) if_stmt
|
|
(constants_elsea, ops_elsea, _) = case else_stmt of
|
|
Nothing -> (constants_ifa, [], lvars_ifa)
|
|
Just stmt -> assembleStatement (constants_ifa, [], lvars_ifa) stmt
|
|
-- +6 because we insert 2 gotos, one for if, one for else
|
|
if_length = sum (map opcodeEncodingLength ops_ifa)
|
|
-- +3 because we need to account for the goto in the if statement.
|
|
else_length = sum (map opcodeEncodingLength ops_elsea)
|
|
in case dtype of
|
|
"void" -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 6)] ++ ops_ifa ++ [Opgoto (else_length + 3)] ++ ops_elsea, lvars_ifa)
|
|
_ -> (constants_ifa, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq (if_length + 3)] ++ ops_ifa ++ ops_elsea, lvars_ifa)
|
|
|
|
assembleStatement (constants, ops, lvars) (TypedStatement _ (While expr stmt)) = let
|
|
(constants_cmp, ops_cmp, _) = assembleExpression (constants, [], lvars) expr
|
|
(constants_stmta, ops_stmta, lvars_stmta) = assembleStatement (constants_cmp, [], lvars) stmt
|
|
-- +3 because we insert 2 gotos, one for the comparison, one for the goto back to the comparison
|
|
stmt_length = sum (map opcodeEncodingLength ops_stmta) + 6
|
|
entire_length = stmt_length + sum (map opcodeEncodingLength ops_cmp)
|
|
in
|
|
(constants_stmta, ops ++ ops_cmp ++ [Opsipush 0, Opif_icmpeq stmt_length] ++ ops_stmta ++ [Opgoto (-entire_length)], lvars_stmta)
|
|
|
|
assembleStatement (constants, ops, lvars) (TypedStatement _ (LocalVariableDeclaration (VariableDeclaration dtype name expr))) = let
|
|
isPrimitive = elem dtype ["char", "boolean", "int"]
|
|
(constants_init, ops_init, _) = case expr of
|
|
Just exp -> assembleExpression (constants, ops, lvars) exp
|
|
Nothing -> (constants, ops ++ if isPrimitive then [Opsipush 0] else [Opaconst_null], lvars)
|
|
localIndex = fromIntegral (length lvars)
|
|
storeLocal = if isPrimitive then [Opistore localIndex] else [Opastore localIndex]
|
|
in
|
|
(constants_init, ops_init ++ storeLocal, lvars ++ [name])
|
|
|
|
assembleStatement (constants, ops, lvars) (TypedStatement _ (StatementExpressionStatement expr)) = let
|
|
(constants_e, ops_e, lvars_e) = assembleStatementExpression (constants, ops, lvars) expr
|
|
in
|
|
(constants_e, ops_e ++ [Oppop], lvars_e)
|
|
|
|
assembleStatement _ stmt = error ("Unknown statement: " ++ show stmt)
|
|
|
|
|
|
assembleMethod :: Assembler MethodDeclaration
|
|
assembleMethod (constants, ops, lvars) (MethodDeclaration returntype name _ (TypedStatement _ (Block statements)))
|
|
| name == "<init>" = let
|
|
(constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements
|
|
in
|
|
(constants_a, [Opaload 0, Opinvokespecial 2] ++ ops_a ++ [Opreturn], lvars_a)
|
|
| otherwise = case returntype of
|
|
"void" -> let
|
|
(constants_a, ops_a, lvars_a) = foldl assembleStatement (constants, ops, lvars) statements
|
|
in
|
|
(constants_a, ops_a ++ [Opreturn], lvars_a)
|
|
_ -> foldl assembleStatement (constants, ops, lvars) statements
|
|
assembleMethod _ (MethodDeclaration _ _ _ stmt) = error ("Typed block expected for method body, got: " ++ show stmt)
|