summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--codegen.hs90
1 files changed, 43 insertions, 47 deletions
diff --git a/codegen.hs b/codegen.hs
index 507feb6..afa600c 100644
--- a/codegen.hs
+++ b/codegen.hs
@@ -392,52 +392,38 @@ genExpression :: Expression -> CGMonad A.Operand
genExpression (ExLit lit (Just t)) = literalToOperand lit t
genExpression (ExBinOp bo e1 e2 (Just t)) = do
case bo of
- Plus -> case (fromJust (exTypeOf e1), fromJust (exTypeOf e2)) of
- (ptrtype@(TypePtr _), TypeInt _) -> do
- ptrop <- genExprArgument e1
- intop <- genExprArgument e2 >>= flip castOperand (TypeInt 64)
- ptrlabel <- addInstr $ A.PtrToInt ptrop (toLLVMType (TypeUInt 64)) []
- add <- addInstr $ A.Add False False (A.LocalReference (toLLVMType ptrtype) (A.Name ptrlabel)) intop []
- res <- addInstr $ A.IntToPtr (A.LocalReference (toLLVMType (TypeUInt 64)) (A.Name add))
- (toLLVMType t) []
- return $ A.LocalReference (toLLVMType ptrtype) (A.Name res)
- (ptrtype@(TypePtr _), TypeUInt _) -> do
- ptrop <- genExprArgument e1
- intop <- genExprArgument e2 >>= flip castOperand (TypeUInt 64)
- ptrlabel <- addInstr $ A.PtrToInt ptrop (toLLVMType (TypeUInt 64)) []
- add <- addInstr $ A.Add False False (A.LocalReference (toLLVMType ptrtype) (A.Name ptrlabel)) intop []
- res <- addInstr $ A.IntToPtr (A.LocalReference (toLLVMType (TypeUInt 64)) (A.Name add))
- (toLLVMType t) []
- return $ A.LocalReference (toLLVMType ptrtype) (A.Name res)
- (TypeInt _, ptrtype@(TypePtr _)) -> do
- ptrop <- genExprArgument e2
- intop <- genExprArgument e1 >>= flip castOperand (TypeInt 64)
- ptrlabel <- addInstr $ A.PtrToInt ptrop (toLLVMType (TypeUInt 64)) []
- add <- addInstr $ A.Add False False (A.LocalReference (toLLVMType ptrtype) (A.Name ptrlabel)) intop []
- res <- addInstr $ A.IntToPtr (A.LocalReference (toLLVMType (TypeUInt 64)) (A.Name add))
- (toLLVMType t) []
- return $ A.LocalReference (toLLVMType ptrtype) (A.Name res)
- (TypeUInt _, ptrtype@(TypePtr _)) -> do
- ptrop <- genExprArgument e2
- intop <- genExprArgument e1 >>= flip castOperand (TypeUInt 64)
- ptrlabel <- addInstr $ A.PtrToInt ptrop (toLLVMType (TypeUInt 64)) []
- add <- addInstr $ A.Add False False (A.LocalReference (toLLVMType ptrtype) (A.Name ptrlabel)) intop []
- res <- addInstr $ A.IntToPtr (A.LocalReference (toLLVMType (TypeUInt 64)) (A.Name add))
- (toLLVMType t) []
- return $ A.LocalReference (toLLVMType t) (A.Name res)
- _ -> do
- e1op <- genExprArgument e1 >>= flip castOperand t
- e2op <- genExprArgument e2 >>= flip castOperand t
- label <- case t of
- (TypeInt _) -> addInstr $ A.Add False False e1op e2op []
- (TypeUInt _) -> addInstr $ A.Add False False e1op e2op []
- TypeFloat -> addInstr $ A.FAdd A.NoFastMathFlags e1op e2op []
- TypeDouble -> addInstr $ A.FAdd A.NoFastMathFlags e1op e2op []
- (TypePtr _) -> throwError $ "Plus '+' operator not defined on pointers"
- (TypeFunc _ _) -> throwError $ "Plus '+' operator not defined on function pointers"
- (TypeName _) -> undefined
- TypeVoid -> undefined
- return $ A.LocalReference (toLLVMType t) (A.Name label)
+ Plus ->
+ let pointerArith eptr eint inttypeconstr = do
+ let inttype = inttypeconstr 64
+ ptrtype@(TypePtr subt) = fromJust (exTypeOf eptr)
+ ptrop <- genExprArgument eptr
+ intop <- genExprArgument eint >>= flip castOperand inttype
+ ptrlabel <- addInstr $ A.PtrToInt ptrop (toLLVMType (TypeUInt 64)) []
+ intlabel <- addInstr $ A.Mul False False intop
+ (A.ConstantOperand (A.C.Int 64 (fromIntegral (sizeOf subt)))) []
+ add <- addInstr $ A.Add False False (A.LocalReference (toLLVMType ptrtype) (A.Name ptrlabel))
+ (A.LocalReference (toLLVMType inttype) (A.Name intlabel)) []
+ res <- addInstr $ A.IntToPtr (A.LocalReference (toLLVMType (TypeUInt 64)) (A.Name add))
+ (toLLVMType ptrtype) []
+ return $ A.LocalReference (toLLVMType ptrtype) (A.Name res)
+ in case (fromJust (exTypeOf e1), fromJust (exTypeOf e2)) of
+ (TypePtr _, TypeInt _) -> pointerArith e1 e2 TypeInt
+ (TypePtr _, TypeUInt _) -> pointerArith e1 e2 TypeUInt
+ (TypeInt _, TypePtr _) -> pointerArith e2 e1 TypeInt
+ (TypeUInt _, TypePtr _) -> pointerArith e2 e1 TypeUInt
+ _ -> do
+ e1op <- genExprArgument e1 >>= flip castOperand t
+ e2op <- genExprArgument e2 >>= flip castOperand t
+ label <- case t of
+ (TypeInt _) -> addInstr $ A.Add False False e1op e2op []
+ (TypeUInt _) -> addInstr $ A.Add False False e1op e2op []
+ TypeFloat -> addInstr $ A.FAdd A.NoFastMathFlags e1op e2op []
+ TypeDouble -> addInstr $ A.FAdd A.NoFastMathFlags e1op e2op []
+ (TypePtr _) -> throwError $ "Plus '+' operator not defined on pointers"
+ (TypeFunc _ _) -> throwError $ "Plus '+' operator not defined on function pointers"
+ (TypeName _) -> undefined
+ TypeVoid -> undefined
+ return $ A.LocalReference (toLLVMType t) (A.Name label)
Minus -> do
e1op <- genExprArgument e1 >>= flip castOperand t
e2op <- genExprArgument e2 >>= flip castOperand t
@@ -616,7 +602,6 @@ genExpression (ExBinOp bo e1 e2 (Just t)) = do
reslabel <- addInstr $ A.Phi A.i1 [(A.ConstantOperand (A.C.Int 1 1), A.Name firstbb),
(A.LocalReference A.i1 (A.Name label2), A.Name bb2)] []
return $ A.LocalReference A.i1 (A.Name reslabel)
- _ -> throwError $ "Binary operator " ++ pshow bo ++ " not implemented"
genExpression (ExUnOp uo e1 (Just t)) = do
e1op <- genExprArgument e1
case uo of
@@ -800,6 +785,17 @@ commonTypeM t1 t2 = maybe err return $ commonType t1 t2
where err = throwError $ "Cannot implicitly find common type of '" ++ pshow t1 ++ "' and '" ++ pshow t2 ++ "'"
+sizeOf :: Type -> Int
+sizeOf (TypeInt s) = (s+7) `div` 8
+sizeOf (TypeUInt s) = (s+7) `div` 8
+sizeOf TypeFloat = 4
+sizeOf TypeDouble = 8
+sizeOf (TypePtr _) = 8
+sizeOf (TypeFunc _ _) = 8
+sizeOf (TypeName _) = undefined
+sizeOf TypeVoid = undefined
+
+
cleanupTrampolines :: LLName -> CGMonad ()
cleanupTrampolines toskip = do
state $ \s -> ((), s {allBlocks = go (allBlocks s)})