Skip to content

Instantly share code, notes, and snippets.

@Bananattack
Last active April 24, 2017 02:39
Show Gist options
  • Save Bananattack/38c91ae587c216783d181fdbf18fc35d to your computer and use it in GitHub Desktop.
Save Bananattack/38c91ae587c216783d181fdbf18fc35d to your computer and use it in GitHub Desktop.
dumping ground for compiler prototyping
-- This is a dumping ground for some ideas on how to implement compiler internals for wiz.
-- Right now does various transformations + checks on statements and expression trees.
-- It's mostly for me to prototype the type-checking and code-generation stuff.
-- I want to dig myself out of a corner with the language, and writing this in a high-level declarative way is kinda nice.
-- After I'm satisfied with how it roughly works, I want to port the implementation in C++
--
-- In particular, I wanted to know how to handle translating expression trees into
-- accumulated/in-place operations on registers, and forbidding any expressions with temporaries.
--
-- It turns out if an expression tree of left-associative operations branches only on the left side,
-- it can be represented as a series of in-place operations. Right-side branches are forbidden, because
-- the require the presence of a stack frame or static storage to hold on to the temporary data, and
-- wiz does not allocate any memory sections the user does not explicitly ask for, including expression temporaries.
--
-- ie. `a = (b + c) + d` is ok, but `a = b + (c + d)` is not.
--
-- `a = (b + c) + d` can be translated into:
--
-- ld a, b
-- add a, c
-- add a, d
import Data.Word
import Data.Bits
data BinOp
= BinOpSet
| BinOpAdd
| BinOpAddC
| BinOpSub
| BinOpSubC
| BinOpMul
| BinOpDiv
| BinOpMod
| BinOpBitwiseAnd
| BinOpBitwiseOr
| BinOpBitwiseXor
deriving (Show, Eq)
data UnOp
= UnOpMinus
| UnOpBitwiseNot
| UnOpIndirect
deriving (Show, Eq)
data Type
= TypeU8
| TypeU16
| TypeI8
| TypeI16
| TypePtr Type
| TypeInteger
deriving (Show, Eq)
data Sym
= SymLet (Expr ())
| SymReg Int Type
| SymVar Int Type
deriving (Show, Eq)
data Lit
= LitInteger Integer
| LitBool Bool
deriving (Show, Eq)
data Expr edata
= ExprBin edata BinOp (Expr edata) (Expr edata)
| ExprUn edata UnOp (Expr edata)
| ExprLit edata Lit Type
| ExprId edata String
| ExprSym edata Sym
deriving (Show, Eq)
data Stmt
= StmtLet String (Expr ())
| StmtVar String Int Type
| StmtExpr (Expr ())
| StmtBlock [Stmt]
deriving (Show, Eq)
class Platform p where
emitLoadInstr :: p -> Expr Type -> Expr Type -> Either String [Word8]
emitUnInstr :: p -> Expr Type -> UnOp -> Expr Type -> Either String [Word8]
emitBinInstr :: p -> Expr Type -> BinOp -> Expr Type -> Expr Type -> Either String [Word8]
builtins :: p -> [(String, Sym)]
eitherConcatSequence :: [Either String [a]] -> Either String [a]
eitherConcatSequence x = either Left (Right . concat) $ sequence x
collectSymbols :: Stmt -> Either String [(String, Sym)]
collectSymbols stmt = case stmt of
StmtLet name expr -> Right [(name, SymLet expr)]
StmtVar name addr t ->
if isLegalVarType t
then Right [(name, SymVar addr t)]
else Left $ "cannot declare variable of type " ++ (typeToString t)
StmtExpr _ -> Right []
StmtBlock subStmts -> eitherConcatSequence $ map collectSymbols subStmts
typeToString :: Type -> String
typeToString t = case t of
TypeU8 -> "u8"
TypeU16 -> "u16"
TypeI8 -> "i8"
TypeI16 -> "i16"
TypePtr u -> "*" ++ (typeToString u)
TypeInteger -> "integer"
litDesc :: Lit -> String
litDesc v = case v of
LitInteger _ -> "integer literal"
LitBool _ -> "boolean literal"
removePtrType :: Type -> Either String Type
removePtrType t = case t of
TypePtr u -> Right u
_ -> Left $ "cannot indirect non-pointer type " ++ (typeToString t)
isSignedIntegralType :: Type -> Bool
isSignedIntegralType t = case t of
TypeI8 -> True
TypeI16 -> True
TypeInteger -> True
_ -> False
isIntegralType :: Type -> Bool
isIntegralType t = case t of
TypeU8 -> True
TypeU16 -> True
TypeI8 -> True
TypeI16 -> True
TypeInteger -> True
TypePtr _ -> False
isLegalVarType :: Type -> Bool
isLegalVarType t = case t of
TypeU8 -> True
TypeU16 -> True
TypeI8 -> True
TypeI16 -> True
TypePtr _ -> True
_ -> False
isUnsignedIntegralType :: Type -> Bool
isUnsignedIntegralType t = (isIntegralType t) && not (isSignedIntegralType t)
integralTypeRange :: Type -> Maybe (Integer, Integer)
integralTypeRange t = case t of
TypeU8 -> Just (0, 255)
TypeU16 -> Just (0, 65535)
TypeI8 -> Just (-128, 127)
TypeI16 -> Just (-32768, 32767)
_ -> Nothing
exprData :: Expr edata -> edata
exprData e = case e of
ExprBin d _ _ _ -> d
ExprUn d _ _ -> d
ExprLit d _ _ -> d
ExprId d _ -> d
ExprSym d _ -> d
unOpDesc :: UnOp -> String
unOpDesc op = case op of
UnOpMinus -> "signed negation `-`"
UnOpBitwiseNot -> "bitwise not `~`"
UnOpIndirect -> "indirection `*`"
binOpDesc :: BinOp -> String
binOpDesc op = case op of
BinOpSet -> "assignment `=`"
BinOpAdd -> "addition `+`"
BinOpAddC -> "addition-with-carry `+#`"
BinOpSub -> "subtraction `-`"
BinOpSubC -> "subtraction-with-carry `+#`"
BinOpMul -> "multiplication `*`"
BinOpDiv -> "division `/`"
BinOpMod -> "modulo `%`"
BinOpBitwiseAnd -> "bitwise and `&`"
BinOpBitwiseOr -> "bitwise or `|`"
BinOpBitwiseXor -> "bitwise xor `^`"
integerInRange :: Integer -> (Integer, Integer) -> Bool
integerInRange i (a, b) = a <= i && i <= b
checkTypedInteger :: Integer -> Type -> Either String Integer
checkTypedInteger i t =
if isIntegralType t
then case integralTypeRange t of
Just (a, b)
-> if integerInRange i (a, b)
then Right $ i
else Left $ "value " ++ (show i) ++ " is outside the range " ++ (show a) ++ " .. " ++ (show b)
Nothing -> Right i
else Left $ "type " ++ (typeToString t) ++ " is not integral so it cannot hold integers"
applyCheckedLitIntUnFn :: (Integer -> Either String Integer) -> Type -> Lit -> Either String Lit
applyCheckedLitIntUnFn f t v = case v of
LitInteger i | isIntegralType t
-> case f i of
Right r -> either Left (Right . LitInteger) (checkTypedInteger r t)
Left err -> Left err
_ -> Left "attempt to use unary integer function on non-integral value"
simplifyExprByLitUnFn :: (Lit -> Either String Lit) -> Type -> UnOp -> Expr Type -> Either String (Expr Type)
simplifyExprByLitUnFn f resultType op e = case e of
ExprLit _ v _ -> either Left (\x -> Right $ ExprLit resultType x resultType) (f v)
_ -> Right $ ExprUn resultType op e
rightWrapUnFn :: (a -> b) -> (a -> Either String b)
rightWrapUnFn f = Right . f
failedUn :: UnOp -> Type -> Either String (Expr Type)
failedUn op t = Left $ "cannot apply " ++ (unOpDesc op) ++ " to type " ++ (typeToString t)
reducedUn :: UnOp -> Expr Type -> Either String (Expr Type)
reducedUn op e =
let t = exprData e
in case op of
UnOpMinus | isSignedIntegralType t -> simplifyExprByLitUnFn (applyCheckedLitIntUnFn (rightWrapUnFn negate) t) t op e
UnOpBitwiseNot | isUnsignedIntegralType t
-> case t of
TypeU8 -> simplifyExprByLitUnFn (applyCheckedLitIntUnFn (rightWrapUnFn (xor 0xFF)) t) t op e
TypeU16 -> simplifyExprByLitUnFn (applyCheckedLitIntUnFn (rightWrapUnFn (xor 0xFFFF)) t) t op e
_ -> failedUn op t
UnOpIndirect
-> case removePtrType t of
Right u -> Right $ ExprUn u op e
Left err -> Left err
_ -> failedUn op t
applyCheckedLitBinIntFn :: (Integer -> Integer -> Either String Integer) -> Type -> Lit -> Lit -> Either String Lit
applyCheckedLitBinIntFn f t v1 v2 = case (v1, v2) of
(LitInteger i1, LitInteger i2) | isIntegralType t
-> case f i1 i2 of
Right r -> either Left (Right . LitInteger) (checkTypedInteger r t)
Left err -> Left err
_ -> Left "attempt to use binary integer function on non-integral value"
simplifyExprByLitBinFn :: (Lit -> Lit -> Either String Lit) -> Type -> BinOp -> Expr Type -> Expr Type -> Either String (Expr Type)
simplifyExprByLitBinFn f resultType op e1 e2 = case (e1, e2) of
(ExprLit _ v1 _, ExprLit _ v2 _) -> either Left (\x -> Right $ ExprLit resultType x resultType) (f v1 v2)
_ -> Right $ ExprBin resultType op e1 e2
makeCompatibleExprs :: Expr Type -> Expr Type -> Maybe (Expr Type, Expr Type)
makeCompatibleExprs e1 e2 =
let t1 = exprData e1
t2 = exprData e2
in case (e1, e2) of
_ | exprData e1 == exprData e2
-> Just (e1, e2)
(_, ExprLit TypeInteger (LitInteger v2) _) | isIntegralType t1
-> case integralTypeRange t1 of
Just (a, b) | integerInRange v2 (a, b)
-> Just (e1, ExprLit t1 (LitInteger v2) t1)
_ -> Nothing
(ExprLit TypeInteger (LitInteger v1) _, _) | isIntegralType t2
-> case integralTypeRange t2 of
Just (a, b) | integerInRange v1 (a, b)
-> Just (ExprLit t2 (LitInteger v1) t2, e2)
_ -> Nothing
_ -> Nothing
failedBin :: BinOp -> Expr Type -> Expr Type -> Either String (Expr Type)
failedBin op e1 e2 = Left $ "cannot apply " ++ (binOpDesc op) ++ " between types " ++ (typeToString (exprData e1)) ++ " and " ++ (typeToString (exprData e2))
rightWrapBinFn :: (a -> b -> c) -> (a -> b -> Either String c)
rightWrapBinFn f = (\x y -> Right $ f x y)
checkedDiv :: Integer -> Integer -> Either String Integer
checkedDiv x y = case y of
0 -> Left "division by zero encountered"
_ -> Right $ div x y
checkedMod :: Integer -> Integer -> Either String Integer
checkedMod x y = case y of
0 -> Left "modulo by zero encountered"
_ -> Right $ mod x y
reducedArithBin :: BinOp -> Expr Type -> Expr Type -> (Integer -> Integer -> Either String Integer) -> Either String (Expr Type)
reducedArithBin op e1 e2 f = case makeCompatibleExprs e1 e2 of
Just (e1_, e2_) ->
let t2 = exprData e2_
in simplifyExprByLitBinFn (applyCheckedLitBinIntFn f t2) t2 op e1_ e2_
Nothing -> failedBin op e1 e2
reducedRuntimeBin :: BinOp -> Expr Type -> Expr Type -> Either String (Expr Type)
reducedRuntimeBin op e1 e2 = case makeCompatibleExprs e1 e2 of
Just (e1_, e2_) -> Right $ ExprBin (exprData e2_) op e1_ e2_
Nothing -> failedBin op e1 e2
reducedBin :: BinOp -> Expr Type -> Expr Type -> Either String (Expr Type)
reducedBin op e1 e2 = case op of
BinOpSet -> reducedRuntimeBin op e1 e2
BinOpAdd -> reducedArithBin op e1 e2 (rightWrapBinFn (+))
BinOpAddC -> reducedRuntimeBin op e1 e2
BinOpSub -> reducedArithBin op e1 e2 (rightWrapBinFn (-))
BinOpSubC -> reducedRuntimeBin op e1 e2
BinOpMul -> reducedArithBin op e1 e2 (rightWrapBinFn (*))
BinOpDiv -> reducedArithBin op e1 e2 (checkedDiv)
BinOpMod -> reducedArithBin op e1 e2 (checkedMod)
BinOpBitwiseAnd -> reducedArithBin op e1 e2 (rightWrapBinFn (.&.))
BinOpBitwiseOr -> reducedArithBin op e1 e2 (rightWrapBinFn (.|.))
BinOpBitwiseXor -> reducedArithBin op e1 e2 (rightWrapBinFn xor)
reducedSym :: [(String, Sym)] -> Sym -> Either String (Expr Type)
reducedSym syms sym = case sym of
SymLet expr -> reducedExpr syms expr
SymReg _ t -> Right $ ExprSym t sym
SymVar _ t -> Right $ ExprSym t sym
reducedExpr :: [(String, Sym)] -> Expr edata -> Either String (Expr Type)
reducedExpr syms e = case e of
ExprBin _ op left right
-> case (reducedExpr syms left, reducedExpr syms right) of
(Right typedLeft, Right typedRight) -> reducedBin op typedLeft typedRight
(Left err, _) -> Left err
(_, Left err) -> Left err
ExprUn _ op term
-> case reducedExpr syms term of
Right typedTerm -> reducedUn op typedTerm
Left err -> Left err
ExprLit _ v t -> case v of
LitInteger i -> case checkTypedInteger i t of
Right _ -> Right $ ExprLit t (LitInteger i) t
Left err -> Left err
_ -> Left $ "could not create " ++ (litDesc v) ++ " of type " ++ (typeToString t)
ExprId _ name
-> case lookup name syms of
Just sym -> reducedSym syms sym
Nothing -> Left $ "could not resolve symbol " ++ name
ExprSym _ sym -> reducedSym syms sym
isLeafExpr :: Expr edata -> Bool
isLeafExpr e = case e of
ExprBin _ _ _ _ -> False
ExprUn _ _ _ -> False
ExprLit _ _ _ -> True
ExprId _ _ -> True
ExprSym _ _ -> True
failedRightSideRequiresTemp :: BinOp -> Either String a
failedRightSideRequiresTemp op = Left $ "right side of " ++ (binOpDesc op) ++ " requires a temporary"
emitAssignmentExpr :: (Platform a) => a -> Expr Type -> Expr Type -> Either String [Word8]
emitAssignmentExpr p dest src = case src of
ExprBin _ BinOpSet left right
-> eitherConcatSequence
[ emitAssignmentExpr p left right
, emitLoadInstr p dest left ]
ExprBin _ op left right | left /= dest && right == dest -> failedRightSideRequiresTemp op
ExprBin _ op left right
| isLeafExpr left && isLeafExpr right
-> case emitBinInstr p dest op left right of
Left _ -> eitherConcatSequence
[ emitLoadInstr p dest left
, emitBinInstr p dest op dest right ]
Right code -> Right code
ExprBin _ op left right
| not (isLeafExpr left) && isLeafExpr right
-> emitBinInstr p dest op dest right
ExprBin _ op _ _ -> failedRightSideRequiresTemp op
ExprUn _ op term
-> case emitUnInstr p dest op term of
Left _ -> eitherConcatSequence
[ emitLoadInstr p dest term
, emitUnInstr p dest op dest]
Right code -> Right code
ExprLit _ _ _ -> emitLoadInstr p dest src
ExprId _ _ -> Left "internal error: identifier should have been translated into symbol"
ExprSym _ _ -> emitLoadInstr p dest src
emitExprStmt :: (Platform a) => a -> Either String (Expr Type) -> Either String [Word8]
emitExprStmt p expr = case expr of
Right (ExprBin _ BinOpSet left right) -> emitAssignmentExpr p left right
Left err -> Left err
_ -> Left "expression cannot be used as a statement"
emitStmt :: (Platform a) => a -> [(String, Sym)] -> Stmt -> Either String [Word8]
emitStmt p syms stmt = case stmt of
StmtLet _ _ -> Right []
StmtVar _ _ _ -> Right []
StmtExpr e -> emitExprStmt p $ reducedExpr syms e
StmtBlock subStmts -> eitherConcatSequence $ map (emitStmt p syms) subStmts
compileStmt :: (Platform a) => a -> Stmt -> Either String [Word8]
compileStmt p stmt = case collectSymbols stmt of
Right syms -> emitStmt p (syms ++ (builtins p)) stmt
Left err -> Left err
data Platform6502 = Platform6502
data Reg6502
= Reg6502_A
| Reg6502_X
| Reg6502_Y
| Reg6502_S
deriving (Show, Eq, Enum)
data Arg6502
= Arg6502_Reg Reg6502
| Arg6502_ImmediateU8 Word8
| Arg6502_ZeroPage Word8
| Arg6502_ZeroPageIndexedByX Word8
| Arg6502_ZeroPageIndexedByY Word8
| Arg6502_Direct Word16
| Arg6502_DirectX Word16
| Arg6502_DirectY Word16
| Arg6502_Indirect Word16
| Arg6502_ZeroPageIndexedByXIndirect Word8
| Arg6502_ZeroPageIndirectIndexedByY Word8
| Arg6502_Error
instance Platform Platform6502 where
emitLoadInstr _ dest src = case (toArg6502 dest, toArg6502 src) of
(Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n) -> Right [0xA9, n]
(Arg6502_Reg Reg6502_X, Arg6502_ImmediateU8 n) -> Right [0xA2, n]
(Arg6502_Reg Reg6502_Y, Arg6502_ImmediateU8 n) -> Right [0xA0, n]
(Arg6502_Reg Reg6502_A, Arg6502_Reg Reg6502_X) -> Right [0x8A]
(Arg6502_Reg Reg6502_A, Arg6502_Reg Reg6502_Y) -> Right [0x98]
(Arg6502_Reg Reg6502_X, Arg6502_Reg Reg6502_A) -> Right [0xAA]
(Arg6502_Reg Reg6502_Y, Arg6502_Reg Reg6502_A) -> Right [0xA8]
(Arg6502_Reg Reg6502_X, Arg6502_Reg Reg6502_S) -> Right [0xBA]
(Arg6502_Reg Reg6502_S, Arg6502_Reg Reg6502_X) -> Right [0x9A]
-- TODO: more instructions
_ -> Left "could not find matching load instruction"
emitUnInstr _ dest op term = case (toArg6502 dest, op, toArg6502 term) of
(Arg6502_Reg Reg6502_A, UnOpMinus, Arg6502_Reg Reg6502_A)
-> Right [0x49, 0xFF, 0x18, 0x69, 0x01]
(Arg6502_Reg Reg6502_A, UnOpBitwiseNot, Arg6502_Reg Reg6502_A)
-> Right [0x49, 0xFF]
-- TODO: more instructions
_ -> Left $ "could not find matching unary instruction for " ++ (unOpDesc op)
emitBinInstr _ dest op left right = case (toArg6502 dest, op, toArg6502 left, toArg6502 right) of
(Arg6502_Reg Reg6502_A, BinOpAdd, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
-> Right [0x18, 0x69, n]
(Arg6502_Reg Reg6502_A, BinOpAddC, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
-> Right [0x69, n]
(Arg6502_Reg Reg6502_A, BinOpSub, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
-> Right [0x38, 0xE9, n]
(Arg6502_Reg Reg6502_A, BinOpSubC, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
-> Right [0x38, 0xE9, n]
(Arg6502_Reg Reg6502_A, BinOpBitwiseAnd, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
-> Right [0x29, n]
(Arg6502_Reg Reg6502_A, BinOpBitwiseOr, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
-> Right [0x09, n]
(Arg6502_Reg Reg6502_A, BinOpBitwiseXor, Arg6502_Reg Reg6502_A, Arg6502_ImmediateU8 n)
-> Right [0x49, n]
-- TODO: more instructions
_ -> Left $ "could not find matching binary instruction for " ++ (binOpDesc op)
builtins _ = map (\(name, reg, t) -> (name, SymReg (fromEnum reg) t))
[ ("a", Reg6502_A, TypeU8)
, ("x", Reg6502_X, TypeU8)
, ("y", Reg6502_Y, TypeU8)]
toArg6502 :: Expr Type -> Arg6502
toArg6502 e = case e of
ExprSym TypeU8 (SymReg reg _) -> Arg6502_Reg (toEnum reg :: Reg6502)
ExprLit TypeU8 (LitInteger n) _ -> Arg6502_ImmediateU8 $ fromIntegral n
_ -> Arg6502_Error
data PlatformGBZ80 = PlatformGBZ80
data RegGBZ80
= RegGBZ80_A
| RegGBZ80_B
| RegGBZ80_C
| RegGBZ80_D
| RegGBZ80_E
| RegGBZ80_H
| RegGBZ80_L
| RegGBZ80_AF
| RegGBZ80_BC
| RegGBZ80_DE
| RegGBZ80_HL
| RegGBZ80_SP
deriving (Show, Eq, Enum)
data ArgGBZ80
= ArgGBZ80_Reg RegGBZ80
| ArgGBZ80_ImmediateU8 Word8
| ArgGBZ80_ImmediateU16 Word16
| ArgGBZ80_Direct Word16
| ArgGBZ80_IndirectBC
| ArgGBZ80_IndirectDE
| ArgGBZ80_IndirectHL
| ArgGBZ80_HighPage Word8
| ArgGBZ80_HighPageIndexedByC Word8
| ArgGBZ80_Error
instance Platform PlatformGBZ80 where
emitLoadInstr _ dest src = case (toArgGBZ80 dest, toArgGBZ80 src) of
(ArgGBZ80_Reg RegGBZ80_B, ArgGBZ80_ImmediateU8 n) -> Right [0x06, n]
(ArgGBZ80_Reg RegGBZ80_C, ArgGBZ80_ImmediateU8 n) -> Right [0x0E, n]
(ArgGBZ80_Reg RegGBZ80_D, ArgGBZ80_ImmediateU8 n) -> Right [0x16, n]
(ArgGBZ80_Reg RegGBZ80_E, ArgGBZ80_ImmediateU8 n) -> Right [0x1E, n]
(ArgGBZ80_Reg RegGBZ80_H, ArgGBZ80_ImmediateU8 n) -> Right [0x26, n]
(ArgGBZ80_Reg RegGBZ80_L, ArgGBZ80_ImmediateU8 n) -> Right [0x2E, n]
(ArgGBZ80_IndirectHL, ArgGBZ80_ImmediateU8 n) -> Right [0x36, n]
(ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_ImmediateU8 n) -> Right [0x3E, n]
-- TODO: more instructions
_ -> Left "could not find matching load instruction"
emitUnInstr _ dest op term = case (toArgGBZ80 dest, op, toArgGBZ80 term) of
-- TODO: more instructions
_ -> Left $ "could not find matching unary instruction for " ++ (unOpDesc op)
emitBinInstr _ dest op left right = case (toArgGBZ80 dest, op, toArgGBZ80 left, toArgGBZ80 right) of
(ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_ImmediateU8 n)
-> Right [0xC6, n]
(ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_B)
-> Right [0x80]
(ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_C)
-> Right [0x81]
(ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_D)
-> Right [0x82]
(ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_E)
-> Right [0x83]
(ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_H)
-> Right [0x84]
(ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_L)
-> Right [0x85]
(ArgGBZ80_Reg RegGBZ80_A, BinOpAdd, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_Reg RegGBZ80_A)
-> Right [0x87]
(ArgGBZ80_Reg RegGBZ80_A, BinOpAddC, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_ImmediateU8 n)
-> Right [0xCE, n]
(ArgGBZ80_Reg RegGBZ80_A, BinOpSub, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_ImmediateU8 n)
-> Right [0xD6, n]
(ArgGBZ80_Reg RegGBZ80_A, BinOpSubC, ArgGBZ80_Reg RegGBZ80_A, ArgGBZ80_ImmediateU8 n)
-> Right [0xDE, n]
-- TODO: more instructions
_ -> Left $ "could not find matching binary instruction for " ++ (binOpDesc op)
builtins _ = map (\(name, reg, t) -> (name, SymReg (fromEnum reg) t))
[ ("a", RegGBZ80_A, TypeU8)
, ("b", RegGBZ80_B, TypeU8)
, ("c", RegGBZ80_C, TypeU8)
, ("d", RegGBZ80_D, TypeU8)
, ("e", RegGBZ80_E, TypeU8)
, ("h", RegGBZ80_H, TypeU8)
, ("l", RegGBZ80_L, TypeU8)
, ("af", RegGBZ80_AF, TypeU16)
, ("bc", RegGBZ80_BC, TypeU16)
, ("de", RegGBZ80_DE, TypeU16)
, ("hl", RegGBZ80_HL, TypeU16)
, ("sp", RegGBZ80_SP, TypeU16)]
toArgGBZ80 :: Expr Type -> ArgGBZ80
toArgGBZ80 e = case e of
ExprSym TypeU8 (SymReg reg _) -> ArgGBZ80_Reg (toEnum reg :: RegGBZ80)
ExprLit TypeU8 (LitInteger n) _ -> ArgGBZ80_ImmediateU8 $ fromIntegral n
_ -> ArgGBZ80_Error
main :: IO ()
main = do
-- TODO: real unit tests / assertions
-- reduced expression tree is a single literal
print $ reducedExpr
[("whoa", SymLet (ExprLit () (LitInteger 4) TypeInteger))]
(ExprBin () BinOpMul
(ExprId () "whoa")
(ExprLit () (LitInteger 3) TypeInteger))
-- runtime variables cannot be reduced further (maybe link-time)
print $ reducedExpr
[("ok", SymVar 123 TypeInteger)]
(ExprId () "ok")
-- let expression is reduced when referenced later
print $ reducedExpr
[("cats", SymLet (ExprBin () BinOpAdd
(ExprLit () (LitInteger 12) TypeInteger)
(ExprLit () (LitInteger 1) TypeInteger)))]
(ExprId () "cats")
-- test reducing constant subtrees of a runtime expression
print $ reducedExpr
[ ("a", SymReg 1 TypeU8)
, ("cats", SymLet (ExprBin () BinOpAdd
(ExprLit () (LitInteger 12) TypeInteger)
(ExprLit () (LitInteger 1) TypeInteger)))]
(ExprBin () BinOpSet
(ExprId () "a")
(ExprBin () BinOpAdd
(ExprLit () (LitInteger 5) TypeU8)
(ExprId () "cats")))
-- test reducing constant subtree of runtime subtree of runtime expression
print $ reducedExpr
[ ("a", SymReg 1 TypeU8)
, ("egg", SymLet (ExprLit () (LitInteger 57) TypeInteger))]
(ExprBin () BinOpSet
(ExprId () "a")
(ExprBin () BinOpAddC
(ExprId () "a")
(ExprBin () BinOpMul
(ExprId () "egg")
(ExprLit () (LitInteger 2) TypeInteger))))
-- unary operation on runtime term cannot be reduced
print $ reducedExpr
[ ("a", SymReg 1 TypeU8)
, ("x", SymReg 2 TypeU8)]
(ExprBin () BinOpSet
(ExprId () "a")
(ExprUn () UnOpBitwiseNot
(ExprId () "x")))
-- quick check leaf expr function works as described
print $ isLeafExpr $ ExprSym () (SymReg 1 TypeU8)
-- `a = 5 + cats; a = a +# egg * 2; a = ~x;`
-- load constant, addc constant, load x, xor $FF``
let testBlock = StmtBlock
[ StmtLet "cats" (ExprBin () BinOpAdd
(ExprLit () (LitInteger 12) TypeInteger)
(ExprLit () (LitInteger 1) TypeInteger))
, StmtLet "egg" (ExprLit () (LitInteger 57) TypeU8)
, StmtExpr $ ExprBin () BinOpSet
(ExprId () "a")
(ExprBin () BinOpAdd
(ExprLit () (LitInteger 5) TypeU8)
(ExprId () "cats"))
, StmtExpr $ ExprBin () BinOpSet
(ExprId () "a")
(ExprBin () BinOpAddC
(ExprId () "a")
(ExprBin () BinOpMul
(ExprId () "egg")
(ExprLit () (LitInteger 2) TypeInteger)))
, StmtExpr $ ExprBin () BinOpSet
(ExprId () "a")
(ExprUn () UnOpBitwiseNot
(ExprId () "x"))]
print $ collectSymbols $ testBlock
print $ compileStmt Platform6502 $ testBlock
-- `a + 5` is not a valid statement
print $ compileStmt Platform6502 $
StmtExpr (ExprBin () BinOpAdd
(ExprId () "a")
(ExprLit () (LitInteger 5) TypeU8))
-- `a = 5 + a` - not possible without temporary
print $ compileStmt PlatformGBZ80 $
StmtExpr (ExprBin () BinOpSet
(ExprId () "a")
(ExprBin () BinOpAdd
(ExprLit () (LitInteger 5) TypeU8)
(ExprId () "a")))
-- `a = a + a` - single add instruction
print $ compileStmt PlatformGBZ80 $
StmtExpr (ExprBin () BinOpSet
(ExprId () "a")
(ExprBin () BinOpAdd
(ExprId () "a")
(ExprId () "a")))
-- `a = 123; a = a + b` load instr and add instr
print $ compileStmt PlatformGBZ80 $
StmtBlock
[ StmtExpr $ ExprBin () BinOpSet
(ExprId () "a")
(ExprLit () (LitInteger 123) TypeInteger)
, StmtExpr $ ExprBin () BinOpSet
(ExprId () "a")
(ExprBin () BinOpAdd
(ExprId () "a")
(ExprId () "b"))]
-- Check that constrainted integers are bounds-checked.
print $ reducedExpr [] $ ExprLit () (LitInteger 1000) TypeU8
print $ reducedExpr [] $ ExprLit () (LitInteger 1000) TypeU16
print $ reducedExpr [] $ ExprLit () (LitInteger 70000) TypeU16
print $ reducedExpr [] $ ExprLit () (LitInteger $ -128) TypeU8
print $ reducedExpr [] $ ExprLit () (LitInteger $ -128) TypeI8
print $ reducedExpr [] $ ExprLit () (LitInteger $ -129) TypeI8
print $ reducedExpr [] $ ExprLit () (LitInteger $ -129) TypeI16
print $ reducedExpr [] $ ExprLit () (LitInteger 70000) TypeInteger
-- Output:
--
-- Right (ExprLit TypeInteger (LitInteger 12) TypeInteger)
-- Right (ExprSym TypeInteger (SymVar 123 TypeInteger))
-- Right (ExprLit TypeInteger (LitInteger 13) TypeInteger)
-- Right (ExprBin TypeU8 BinOpSet (ExprSym TypeU8 (SymReg 1 TypeU8)) (ExprLit TypeU8 (LitInteger 18) TypeU8))
-- Right (ExprBin TypeU8 BinOpSet (ExprSym TypeU8 (SymReg 1 TypeU8)) (ExprBin TypeU8 BinOpAddC (ExprSym TypeU8 (SymReg 1 TypeU8)) (ExprLit TypeU8 (LitInteger 114) TypeU8)))
-- Right (ExprBin TypeU8 BinOpSet (ExprSym TypeU8 (SymReg 1 TypeU8)) (ExprUn TypeU8 UnOpBitwiseNot (ExprSym TypeU8 (SymReg 2 TypeU8))))
-- True
-- Right [("cats",SymLet (ExprBin () BinOpAdd (ExprLit () (LitInteger 12) TypeInteger) (ExprLit () (LitInteger 1) TypeInteger))),("egg",SymLet (ExprLit () (LitInteger 57) TypeU8))]
-- Right [169,18,105,114,138,73,255]
-- Left "expression cannot be used as a statement"
-- Left "right side of addition `+` requires a temporary"
-- Right [135]
-- Right [62,123,128]
-- Left "value 1000 is outside the range 0 .. 255"
-- Right (ExprLit TypeU16 (LitInteger 1000) TypeU16)
-- Left "value 70000 is outside the range 0 .. 65535"
-- Left "value -128 is outside the range 0 .. 255"
-- Right (ExprLit TypeI8 (LitInteger (-128)) TypeI8)
-- Left "value -129 is outside the range -128 .. 127"
-- Right (ExprLit TypeI16 (LitInteger (-129)) TypeI16)
-- Right (ExprLit TypeInteger (LitInteger 70000) TypeInteger)
--
--
-- TODO: I wonder if there should be a way to qualify operators as forced runtime operators.
-- (eg. for addition, to force carry to be generated) `a = a !+ b` or something
--
-- TODO: label statements (eg. for goto, etc)
-- TODO: link-time expressions, such as expressions involving addresses of code section labels.
-- still constant (so should be folded into a single term) but aren't knowable until after first instruction selection pass.
-- Type and constness information should be enough to determine the instructions generated without knowing actual value.
-- Assume it's a constant address that is not in zero page / high page, since labels of variables are known before instruction selection even starts
-- Keep link-time expression in tree form, but know its reduced operand type - resolve at last possible moment
--
-- TODO: pointer arithmetic
-- TODO: pointer views of registers (so we can indirect them and read a byte value)
-- TODO: signed views of registers (so we can do signed comparsion, multiplication, etc)
--
-- TODO: type-checked version of expressions like `lda (ptr, x)` (indexed-by-x indirect) in 6502 instruction set.
-- This is complicated! ptr is a 16-bit address, but x is a byte offset from ptr, so unaligned accesses are possible.
--
-- C prevents unaligned reads on a T* by multiplying index and/or pointer arithmetic terms by sizeof(T), but we can't do that without temporary / hidden calculations
--
-- Wiz is against most hidden computations because it is as much as possible directly targetting machine instructions, so we need some way to
-- recognize unaligned pointer arithmetic and generate a single instruction
--
-- An unaligned access would look something like this I think?
-- a = *((ptr as u16 + x as u16) as *u8)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment