diff options
Diffstat (limited to 'codegen.hs')
| -rw-r--r-- | codegen.hs | 100 |
1 files changed, 55 insertions, 45 deletions
@@ -388,55 +388,65 @@ genSingle (StWhile cexpr st) following = do setTerminator $ A.CondBr coper' (A.Name stbb) (A.Name following) [] return cbb +pointerArith :: Expression -- Expression that produces the pointer + -> Expression -- Expression that produces the integer to add + -> (Int -> Type) -- TypeInt or TypeUInt, the type of the integer + -> CGMonad A.Operand -- The resulting pointer +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) + 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 -> - 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 - label <- case t of - (TypeInt _) -> addInstr $ A.Sub False False e1op e2op [] - (TypeUInt _) -> addInstr $ A.Sub False False e1op e2op [] - TypeFloat -> addInstr $ A.FSub A.NoFastMathFlags e1op e2op [] - TypeDouble -> addInstr $ A.FSub A.NoFastMathFlags e1op e2op [] - (TypePtr _) -> throwError $ "Minus '-' operator not defined on pointers" - (TypeFunc _ _) -> throwError $ "Minus '-' operator not defined on function pointers" - (TypeName _) -> undefined - TypeVoid -> undefined - return $ A.LocalReference (toLLVMType t) (A.Name label) + Plus -> 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 _) -> undefined -- Handled above + (TypeFunc _ _) -> throwError $ "Plus '+' operator not defined on function pointers" + (TypeName _) -> undefined + TypeVoid -> undefined + return $ A.LocalReference (toLLVMType t) (A.Name label) + Minus -> let exneg e ty = ExUnOp Negate e (Just ty) + in case (fromJust (exTypeOf e1), fromJust (exTypeOf e2)) of + (TypePtr _, it@(TypeInt _)) -> pointerArith e1 (exneg e2 it) TypeInt + (TypePtr _, it@(TypeUInt _)) -> pointerArith e1 (exneg e2 it) TypeUInt + (it@(TypeInt _), TypePtr _) -> pointerArith (exneg e2 it) e1 TypeInt + (it@(TypeUInt _), TypePtr _) -> pointerArith (exneg e2 it) e1 TypeUInt + _ -> do + e1op <- genExprArgument e1 >>= flip castOperand t + e2op <- genExprArgument e2 >>= flip castOperand t + label <- case t of + (TypeInt _) -> addInstr $ A.Sub False False e1op e2op [] + (TypeUInt _) -> addInstr $ A.Sub False False e1op e2op [] + TypeFloat -> addInstr $ A.FSub A.NoFastMathFlags e1op e2op [] + TypeDouble -> addInstr $ A.FSub A.NoFastMathFlags e1op e2op [] + (TypePtr _) -> undefined -- Handled above + (TypeFunc _ _) -> throwError $ "Minus '-' operator not defined on function pointers" + (TypeName _) -> undefined + TypeVoid -> undefined + return $ A.LocalReference (toLLVMType t) (A.Name label) Times -> do e1op <- genExprArgument e1 >>= flip castOperand t e2op <- genExprArgument e2 >>= flip castOperand t |