Separate out pointer arithmetic logic

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)})