diff options
Diffstat (limited to 'codegen.hs')
| -rw-r--r-- | codegen.hs | 104 |
1 files changed, 84 insertions, 20 deletions
@@ -392,19 +392,52 @@ 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 -> 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 -> 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) Minus -> do e1op <- genExprArgument e1 >>= flip castOperand t e2op <- genExprArgument e2 >>= flip castOperand t @@ -471,6 +504,20 @@ genExpression (ExBinOp bo e1 e2 (Just t)) = do (TypeName _) -> undefined TypeVoid -> undefined return $ A.LocalReference (A.IntegerType 1) (A.Name label) + Unequal -> do + sharedType <- commonTypeM (fromJust (exTypeOf e1)) (fromJust (exTypeOf e2)) + e1op <- genExprArgument e1 >>= flip castOperand sharedType + e2op <- genExprArgument e2 >>= flip castOperand sharedType + label <- case sharedType of + (TypeInt _) -> addInstr $ A.ICmp A.IP.NE e1op e2op [] + (TypeUInt _) -> addInstr $ A.ICmp A.IP.NE e1op e2op [] + TypeFloat -> addInstr $ A.FCmp A.FPP.ONE e1op e2op [] + TypeDouble -> addInstr $ A.FCmp A.FPP.ONE e1op e2op [] + (TypePtr _) -> addInstr $ A.ICmp A.IP.NE e1op e2op [] + (TypeFunc _ _) -> addInstr $ A.ICmp A.IP.NE e1op e2op [] + (TypeName _) -> undefined + TypeVoid -> undefined + return $ A.LocalReference (A.IntegerType 1) (A.Name label) Greater -> do sharedType <- commonTypeM (fromJust (exTypeOf e1)) (fromJust (exTypeOf e2)) e1op <- genExprArgument e1 >>= flip castOperand sharedType @@ -548,11 +595,27 @@ genExpression (ExBinOp bo e1 e2 (Just t)) = do reslabel <- addInstr $ A.Phi A.i1 [(A.ConstantOperand (A.C.Int 1 0), A.Name firstbb), (A.LocalReference A.i1 (A.Name label2), A.Name bb2)] [] return $ A.LocalReference A.i1 (A.Name reslabel) - -- BoolOr -> do - -- e1op' <- castToBool e1op - -- e2op' <- castToBool e2op - -- label <- addInstr $ A.Or e1op' e2op' [] - -- return $ A.LocalReference (A.IntegerType 1) (A.Name label) + BoolOr -> do + firstbb <- liftM (fromJust . currentBlock) get + (A.LocalReference (A.IntegerType 1) (A.Name label1)) <- genExprArgument e1 >>= castToBool + (A.Do origterm) <- getTerminator + + bb2 <- newBlock + (A.LocalReference (A.IntegerType 1) (A.Name label2)) <- genExprArgument e2 >>= castToBool + + bb3 <- newBlock + + changeBlock firstbb + setTerminator $ A.CondBr (A.LocalReference A.i1 (A.Name label1)) (A.Name bb3) (A.Name bb2) [] + + changeBlock bb2 + setTerminator $ A.Br (A.Name bb3) [] + + changeBlock bb3 + setTerminator origterm + 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 @@ -580,8 +643,9 @@ genExpression (ExUnOp uo e1 (Just t)) = do TypeVoid -> undefined return $ A.LocalReference (toLLVMType t) (A.Name label) Dereference -> do - label <- case t of - (TypePtr _) -> addInstr $ A.Load False e1op Nothing 0 [] + let (A.LocalReference optype _) = e1op + label <- case optype of + (A.PointerType _ _) -> addInstr $ A.Load False e1op Nothing 0 [] _ -> throwError $ "Dereference '*' operator only defined on pointers" return $ A.LocalReference (toLLVMType t) (A.Name label) _ -> throwError $ "Unary operator " ++ pshow uo ++ " not implemented" |