diff options
| -rw-r--r-- | codegen.hs | 90 |
1 files changed, 43 insertions, 47 deletions
@@ -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)}) |