summaryrefslogtreecommitdiff
path: root/codegen.hs
diff options
context:
space:
mode:
Diffstat (limited to 'codegen.hs')
-rw-r--r--codegen.hs255
1 files changed, 174 insertions, 81 deletions
diff --git a/codegen.hs b/codegen.hs
index f1c4305..e56caa4 100644
--- a/codegen.hs
+++ b/codegen.hs
@@ -72,7 +72,7 @@ newBlock = do
name <- getNewName ".bb"
state $ \s -> (name, s {
currentBlock = Just name,
- allBlocks = Map.insert name (A.BasicBlock (A.Name name) [] undefined) $ allBlocks s
+ allBlocks = Map.insert name (A.BasicBlock (A.Name name) [] (A.Do $ A.Unreachable [])) $ allBlocks s
})
newBlockJump :: LLName -> CGMonad LLName
@@ -116,6 +116,12 @@ setTerminator term = do
let replace (A.BasicBlock n il _) = A.BasicBlock n il (A.Do term)
state $ \s -> ((), s {allBlocks = Map.adjust replace (fromJust (currentBlock s)) (allBlocks s)})
+getTerminator :: CGMonad (A.Named A.Terminator)
+getTerminator = do
+ s <- get
+ let (A.BasicBlock _ _ t) = fromJust $ Map.lookup (fromJust $ currentBlock s) (allBlocks s)
+ return t
+
setCurrentFunction :: Declaration -> CGMonad ()
setCurrentFunction dec = do
state $ \s -> ((), s {currentFunction = dec})
@@ -385,56 +391,67 @@ genSingle (StWhile cexpr st) following = do
genExpression :: Expression -> CGMonad A.Operand
genExpression (ExLit lit (Just t)) = literalToOperand lit t
genExpression (ExBinOp bo e1 e2 (Just t)) = do
- e1op <- genExprArgument e1
- e2op <- genExprArgument e2
case bo of
Plus -> do
- e1op' <- castOperand e1op t
- e2op' <- castOperand e2op t
+ 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 _) -> addInstr $ A.Add False False e1op' e2op' []
+ (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' <- castOperand e1op t
- e2op' <- castOperand e2op t
+ 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 _) -> addInstr $ A.Sub False False e1op' e2op' []
+ (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)
+ Times -> do
+ e1op <- genExprArgument e1 >>= flip castOperand t
+ e2op <- genExprArgument e2 >>= flip castOperand t
+ label <- case t of
+ (TypeInt _) -> addInstr $ A.Mul False False e1op e2op []
+ (TypeUInt _) -> addInstr $ A.Mul False False e1op e2op []
+ TypeFloat -> addInstr $ A.FMul A.NoFastMathFlags e1op e2op []
+ TypeDouble -> addInstr $ A.FMul A.NoFastMathFlags e1op e2op []
+ (TypePtr _) -> throwError $ "Multiply '*' operator not defined on pointers"
+ (TypeFunc _ _) -> throwError $ "Multiply '*' operator not defined on function pointers"
+ (TypeName _) -> undefined
+ TypeVoid -> undefined
+ return $ A.LocalReference (toLLVMType t) (A.Name label)
Divide -> do
- e1op' <- castOperand e1op t
- e2op' <- castOperand e2op t
+ e1op <- genExprArgument e1 >>= flip castOperand t
+ e2op <- genExprArgument e2 >>= flip castOperand t
label <- case t of
- (TypeInt _) -> addInstr $ A.SDiv False e1op' e2op' []
- (TypeUInt _) -> addInstr $ A.UDiv False e1op' e2op' []
- TypeFloat -> addInstr $ A.FDiv A.NoFastMathFlags e1op' e2op' []
- TypeDouble -> addInstr $ A.FDiv A.NoFastMathFlags e1op' e2op' []
- (TypePtr _) -> throwError $ "Modulo '%' operator not defined on pointers"
+ (TypeInt _) -> addInstr $ A.SDiv False e1op e2op []
+ (TypeUInt _) -> addInstr $ A.UDiv False e1op e2op []
+ TypeFloat -> addInstr $ A.FDiv A.NoFastMathFlags e1op e2op []
+ TypeDouble -> addInstr $ A.FDiv A.NoFastMathFlags e1op e2op []
+ (TypePtr _) -> throwError $ "Divide '/' operator not defined on pointers"
(TypeFunc _ _) -> throwError $ "Divide '/' operator not defined on function pointers"
(TypeName _) -> undefined
TypeVoid -> undefined
return $ A.LocalReference (toLLVMType t) (A.Name label)
Modulo -> do
- e1op' <- castOperand e1op t
- e2op' <- castOperand e2op t
+ e1op <- genExprArgument e1 >>= flip castOperand t
+ e2op <- genExprArgument e2 >>= flip castOperand t
label <- case t of
- (TypeInt _) -> addInstr $ A.SRem e1op' e2op' []
- (TypeUInt _) -> addInstr $ A.URem e1op' e2op' []
- TypeFloat -> addInstr $ A.FRem A.NoFastMathFlags e1op' e2op' []
- TypeDouble -> addInstr $ A.FRem A.NoFastMathFlags e1op' e2op' []
+ (TypeInt _) -> addInstr $ A.SRem e1op e2op []
+ (TypeUInt _) -> addInstr $ A.URem e1op e2op []
+ TypeFloat -> addInstr $ A.FRem A.NoFastMathFlags e1op e2op []
+ TypeDouble -> addInstr $ A.FRem A.NoFastMathFlags e1op e2op []
(TypePtr _) -> throwError $ "Modulo '%' operator not defined on pointers"
(TypeFunc _ _) -> throwError $ "Modulo '%' operator not defined on function pointers"
(TypeName _) -> undefined
@@ -442,79 +459,100 @@ genExpression (ExBinOp bo e1 e2 (Just t)) = do
return $ A.LocalReference (toLLVMType t) (A.Name label)
Equal -> do
sharedType <- commonTypeM (fromJust (exTypeOf e1)) (fromJust (exTypeOf e2))
- e1op' <- castOperand e1op sharedType
- e2op' <- castOperand e2op sharedType
+ e1op <- genExprArgument e1 >>= flip castOperand sharedType
+ e2op <- genExprArgument e2 >>= flip castOperand sharedType
label <- case sharedType of
- (TypeInt _) -> addInstr $ A.ICmp A.IP.EQ e1op' e2op' []
- (TypeUInt _) -> addInstr $ A.ICmp A.IP.EQ e1op' e2op' []
- TypeFloat -> addInstr $ A.FCmp A.FPP.OEQ e1op' e2op' []
- TypeDouble -> addInstr $ A.FCmp A.FPP.OEQ e1op' e2op' []
- (TypePtr _) -> addInstr $ A.ICmp A.IP.EQ e1op' e2op' []
- (TypeFunc _ _) -> addInstr $ A.ICmp A.IP.EQ e1op' e2op' []
+ (TypeInt _) -> addInstr $ A.ICmp A.IP.EQ e1op e2op []
+ (TypeUInt _) -> addInstr $ A.ICmp A.IP.EQ e1op e2op []
+ TypeFloat -> addInstr $ A.FCmp A.FPP.OEQ e1op e2op []
+ TypeDouble -> addInstr $ A.FCmp A.FPP.OEQ e1op e2op []
+ (TypePtr _) -> addInstr $ A.ICmp A.IP.EQ e1op e2op []
+ (TypeFunc _ _) -> addInstr $ A.ICmp A.IP.EQ 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' <- castOperand e1op sharedType
- e2op' <- castOperand e2op sharedType
+ e1op <- genExprArgument e1 >>= flip castOperand sharedType
+ e2op <- genExprArgument e2 >>= flip castOperand sharedType
label <- case sharedType of
- (TypeInt _) -> addInstr $ A.ICmp A.IP.SGT e1op' e2op' []
- (TypeUInt _) -> addInstr $ A.ICmp A.IP.UGT e1op' e2op' []
- TypeFloat -> addInstr $ A.FCmp A.FPP.OGT e1op' e2op' []
- TypeDouble -> addInstr $ A.FCmp A.FPP.OGT e1op' e2op' []
- (TypePtr _) -> addInstr $ A.ICmp A.IP.UGT e1op' e2op' []
- (TypeFunc _ _) -> addInstr $ A.ICmp A.IP.UGT e1op' e2op' []
+ (TypeInt _) -> addInstr $ A.ICmp A.IP.SGT e1op e2op []
+ (TypeUInt _) -> addInstr $ A.ICmp A.IP.UGT e1op e2op []
+ TypeFloat -> addInstr $ A.FCmp A.FPP.OGT e1op e2op []
+ TypeDouble -> addInstr $ A.FCmp A.FPP.OGT e1op e2op []
+ (TypePtr _) -> addInstr $ A.ICmp A.IP.UGT e1op e2op []
+ (TypeFunc _ _) -> addInstr $ A.ICmp A.IP.UGT e1op e2op []
(TypeName _) -> undefined
TypeVoid -> undefined
return $ A.LocalReference (A.IntegerType 1) (A.Name label)
Less -> do
sharedType <- commonTypeM (fromJust (exTypeOf e1)) (fromJust (exTypeOf e2))
- e1op' <- castOperand e1op sharedType
- e2op' <- castOperand e2op sharedType
+ e1op <- genExprArgument e1 >>= flip castOperand sharedType
+ e2op <- genExprArgument e2 >>= flip castOperand sharedType
label <- case sharedType of
- (TypeInt _) -> addInstr $ A.ICmp A.IP.SLT e1op' e2op' []
- (TypeUInt _) -> addInstr $ A.ICmp A.IP.ULT e1op' e2op' []
- TypeFloat -> addInstr $ A.FCmp A.FPP.OLT e1op' e2op' []
- TypeDouble -> addInstr $ A.FCmp A.FPP.OLT e1op' e2op' []
- (TypePtr _) -> addInstr $ A.ICmp A.IP.ULT e1op' e2op' []
- (TypeFunc _ _) -> addInstr $ A.ICmp A.IP.ULT e1op' e2op' []
+ (TypeInt _) -> addInstr $ A.ICmp A.IP.SLT e1op e2op []
+ (TypeUInt _) -> addInstr $ A.ICmp A.IP.ULT e1op e2op []
+ TypeFloat -> addInstr $ A.FCmp A.FPP.OLT e1op e2op []
+ TypeDouble -> addInstr $ A.FCmp A.FPP.OLT e1op e2op []
+ (TypePtr _) -> addInstr $ A.ICmp A.IP.ULT e1op e2op []
+ (TypeFunc _ _) -> addInstr $ A.ICmp A.IP.ULT e1op e2op []
(TypeName _) -> undefined
TypeVoid -> undefined
return $ A.LocalReference (A.IntegerType 1) (A.Name label)
GEqual -> do
sharedType <- commonTypeM (fromJust (exTypeOf e1)) (fromJust (exTypeOf e2))
- e1op' <- castOperand e1op sharedType
- e2op' <- castOperand e2op sharedType
+ e1op <- genExprArgument e1 >>= flip castOperand sharedType
+ e2op <- genExprArgument e2 >>= flip castOperand sharedType
label <- case sharedType of
- (TypeInt _) -> addInstr $ A.ICmp A.IP.SGE e1op' e2op' []
- (TypeUInt _) -> addInstr $ A.ICmp A.IP.UGE e1op' e2op' []
- TypeFloat -> addInstr $ A.FCmp A.FPP.OGE e1op' e2op' []
- TypeDouble -> addInstr $ A.FCmp A.FPP.OGE e1op' e2op' []
- (TypePtr _) -> addInstr $ A.ICmp A.IP.UGE e1op' e2op' []
- (TypeFunc _ _) -> addInstr $ A.ICmp A.IP.UGE e1op' e2op' []
+ (TypeInt _) -> addInstr $ A.ICmp A.IP.SGE e1op e2op []
+ (TypeUInt _) -> addInstr $ A.ICmp A.IP.UGE e1op e2op []
+ TypeFloat -> addInstr $ A.FCmp A.FPP.OGE e1op e2op []
+ TypeDouble -> addInstr $ A.FCmp A.FPP.OGE e1op e2op []
+ (TypePtr _) -> addInstr $ A.ICmp A.IP.UGE e1op e2op []
+ (TypeFunc _ _) -> addInstr $ A.ICmp A.IP.UGE e1op e2op []
(TypeName _) -> undefined
TypeVoid -> undefined
return $ A.LocalReference (A.IntegerType 1) (A.Name label)
LEqual -> do
sharedType <- commonTypeM (fromJust (exTypeOf e1)) (fromJust (exTypeOf e2))
- e1op' <- castOperand e1op sharedType
- e2op' <- castOperand e2op sharedType
+ e1op <- genExprArgument e1 >>= flip castOperand sharedType
+ e2op <- genExprArgument e2 >>= flip castOperand sharedType
label <- case sharedType of
- (TypeInt _) -> addInstr $ A.ICmp A.IP.SLE e1op' e2op' []
- (TypeUInt _) -> addInstr $ A.ICmp A.IP.ULE e1op' e2op' []
- TypeFloat -> addInstr $ A.FCmp A.FPP.OLE e1op' e2op' []
- TypeDouble -> addInstr $ A.FCmp A.FPP.OLE e1op' e2op' []
- (TypePtr _) -> addInstr $ A.ICmp A.IP.ULE e1op' e2op' []
- (TypeFunc _ _) -> addInstr $ A.ICmp A.IP.ULE e1op' e2op' []
+ (TypeInt _) -> addInstr $ A.ICmp A.IP.SLE e1op e2op []
+ (TypeUInt _) -> addInstr $ A.ICmp A.IP.ULE e1op e2op []
+ TypeFloat -> addInstr $ A.FCmp A.FPP.OLE e1op e2op []
+ TypeDouble -> addInstr $ A.FCmp A.FPP.OLE e1op e2op []
+ (TypePtr _) -> addInstr $ A.ICmp A.IP.ULE e1op e2op []
+ (TypeFunc _ _) -> addInstr $ A.ICmp A.IP.ULE e1op e2op []
(TypeName _) -> undefined
TypeVoid -> undefined
return $ A.LocalReference (A.IntegerType 1) (A.Name label)
- BoolOr -> do
- e1op' <- castToBool e1op
- e2op' <- castToBool e2op
- label <- addInstr $ A.Or e1op' e2op' []
- return $ A.LocalReference (A.IntegerType 1) (A.Name label)
+ BoolAnd -> 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 bb2) (A.Name bb3) []
+
+ changeBlock bb2
+ setTerminator $ A.Br (A.Name bb3) []
+
+ changeBlock bb3
+ setTerminator origterm
+ 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)
_ -> throwError $ "Binary operator " ++ pshow bo ++ " not implemented"
genExpression (ExUnOp uo e1 (Just t)) = do
e1op <- genExprArgument e1
@@ -530,6 +568,22 @@ genExpression (ExUnOp uo e1 (Just t)) = do
(TypeFunc _ _) -> throwError $ "Negate '-' operator not defined on a function pointer"
TypeVoid -> undefined
return $ A.LocalReference (toLLVMType t) (A.Name label)
+ Not -> do
+ label <- case t of
+ (TypeInt s) -> addInstr $ A.ICmp A.IP.EQ (A.ConstantOperand (A.C.Int (fromIntegral s) 0)) e1op []
+ (TypeUInt s) -> addInstr $ A.ICmp A.IP.EQ (A.ConstantOperand (A.C.Int (fromIntegral s) 0)) e1op []
+ TypeFloat -> addInstr $ A.FCmp A.FPP.OEQ (A.ConstantOperand (A.C.Float (A.F.Single 0))) e1op []
+ TypeDouble -> addInstr $ A.FCmp A.FPP.OEQ (A.ConstantOperand (A.C.Float (A.F.Double 0))) e1op []
+ (TypePtr _) -> addInstr $ A.ICmp A.IP.EQ (A.ConstantOperand (A.C.Null (toLLVMType t))) e1op []
+ (TypeName _) -> undefined
+ (TypeFunc _ _) -> throwError $ "Not '!' operator not defined on a function pointer"
+ TypeVoid -> undefined
+ return $ A.LocalReference (toLLVMType t) (A.Name label)
+ Dereference -> do
+ label <- case t of
+ (TypePtr _) -> 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"
genExpression ex = throwError $ "Expression '" ++ pshow ex ++ "' not implemented"
@@ -540,6 +594,8 @@ genExprArgument expr = case expr of
literalToOperand :: Literal -> Type -> CGMonad A.Operand
literalToOperand (LitInt i) (TypeInt sz) = return $ A.ConstantOperand (A.C.Int (fromIntegral sz) i)
+literalToOperand (LitFloat f) TypeFloat = return $ A.ConstantOperand (A.C.Float (A.F.Single (realToFrac f)))
+literalToOperand (LitFloat f) TypeDouble = return $ A.ConstantOperand (A.C.Float (A.F.Double f))
literalToOperand (LitVar n) t = do
oper <- variableOperand n
oper' <- castOperand oper t
@@ -572,9 +628,21 @@ literalToOperand (LitCall n args) _ = do
literalToOperand lit _ = throwError $ "Literal '" ++ pshow lit ++ "' not implemented"
castOperand :: A.Operand -> Type -> CGMonad A.Operand
-castOperand orig@(A.LocalReference (A.IntegerType 1) _) t2@(TypeInt _) = do
- label <- addInstr $ A.ZExt orig (toLLVMType t2) []
- return $ A.LocalReference (toLLVMType t2) (A.Name label)
+castOperand orig@(A.ConstantOperand (A.C.Int s1 val)) t2@(TypeInt s2)
+ | fromIntegral s1 == s2 = return orig
+ | fromIntegral s1 < s2 = return $ A.ConstantOperand (A.C.Int (fromIntegral s2) val)
+ | fromIntegral s1 > s2 = throwError $ "Integer " ++ show val ++ " too large for type '" ++ pshow t2 ++ "'"
+castOperand (A.ConstantOperand (A.C.Int _ val)) TypeFloat = do
+ return $ A.ConstantOperand (A.C.Float (A.F.Single (fromIntegral val)))
+castOperand (A.ConstantOperand (A.C.Int _ val)) TypeDouble = do
+ return $ A.ConstantOperand (A.C.Float (A.F.Double (fromIntegral val)))
+castOperand orig@(A.ConstantOperand (A.C.Float (A.F.Single _))) TypeFloat = do
+ return orig
+castOperand orig@(A.ConstantOperand (A.C.Float (A.F.Double _))) TypeDouble = do
+ return orig
+castOperand (A.ConstantOperand (A.C.Float (A.F.Single f))) TypeDouble = do
+ return $ A.ConstantOperand (A.C.Float (A.F.Double (realToFrac f)))
+
castOperand orig@(A.LocalReference (A.IntegerType s1) _) t2@(TypeInt s2)
| fromIntegral s1 == s2 = return orig
| fromIntegral s1 < s2 = do
@@ -582,10 +650,13 @@ castOperand orig@(A.LocalReference (A.IntegerType s1) _) t2@(TypeInt s2)
return $ A.LocalReference (toLLVMType t2) (A.Name label)
| fromIntegral s1 > s2 = throwError $ "Cannot implicitly cast '" ++ pshow (TypeInt (fromIntegral s1))
++ "' to '" ++ pshow t2 ++ "'"
-castOperand orig@(A.ConstantOperand (A.C.Int s1 val)) t2@(TypeInt s2)
+castOperand orig@(A.LocalReference (A.IntegerType s1) _) t2@(TypeUInt s2)
| fromIntegral s1 == s2 = return orig
- | fromIntegral s1 < s2 = return $ A.ConstantOperand (A.C.Int (fromIntegral s2) val)
- | fromIntegral s1 > s2 = throwError $ "Integer " ++ show val ++ " too large for type '" ++ pshow t2 ++ "'"
+ | fromIntegral s1 < s2 = do
+ label <- addInstr $ A.ZExt orig (toLLVMType t2) []
+ return $ A.LocalReference (toLLVMType t2) (A.Name label)
+ | fromIntegral s1 > s2 = throwError $ "Cannot implicitly cast '" ++ pshow (TypeUInt (fromIntegral s1))
+ ++ "' to '" ++ pshow t2 ++ "'"
castOperand orig@(A.ConstantOperand (A.C.GlobalReference (A.IntegerType s1) _)) t2@(TypeInt s2)
| fromIntegral s1 == s2 = return orig
| fromIntegral s1 < s2 = do
@@ -593,6 +664,22 @@ castOperand orig@(A.ConstantOperand (A.C.GlobalReference (A.IntegerType s1) _))
return $ A.LocalReference (toLLVMType t2) (A.Name label)
| fromIntegral s1 > s2 = throwError $ "Cannot implicitly cast '" ++ pshow (TypeInt (fromIntegral s1))
++ "' to '" ++ pshow t2 ++ "'"
+castOperand orig@(A.ConstantOperand (A.C.GlobalReference (A.IntegerType s1) _)) t2@(TypeUInt s2)
+ | fromIntegral s1 == s2 = return orig
+ | fromIntegral s1 < s2 = do
+ label <- addInstr $ A.ZExt orig (toLLVMType t2) []
+ return $ A.LocalReference (toLLVMType t2) (A.Name label)
+ | fromIntegral s1 > s2 = throwError $ "Cannot implicitly cast '" ++ pshow (TypeUInt (fromIntegral s1))
+ ++ "' to '" ++ pshow t2 ++ "'"
+
+castOperand orig@(A.LocalReference t _) TypeFloat | t == toLLVMType TypeFloat = do
+ return orig
+castOperand orig@(A.LocalReference t _) TypeDouble | t == toLLVMType TypeDouble = do
+ return orig
+castOperand orig@(A.LocalReference t _) TypeDouble | t == toLLVMType TypeFloat = do
+ label <- addInstr $ A.FPExt orig (toLLVMType TypeDouble) []
+ return $ A.LocalReference (toLLVMType TypeDouble) (A.Name label)
+
castOperand orig@(A.LocalReference (A.PointerType t1 _) _) (TypePtr t2)
| toLLVMType t2 == t1 = return orig
| otherwise = throwError $ "Cannot implicitly cast between pointer to '" ++ show t1
@@ -605,8 +692,10 @@ castOperand orig@(A.LocalReference (A.PointerType (A.FunctionType rt1 at1 False)
| toLLVMType rt2 == rt1 && all (uncurry (==)) (zip at1 (map toLLVMType at2)) = return orig
| otherwise = throwError $ "Cannot implicitly cast between '" ++ show orig
++ "' and '" ++ pshow t2 ++ "'"
+
castOperand orig t2 = throwError $ "Cast from '" ++ show orig ++ "' to type '" ++ pshow t2 ++ "' not implemented"
+
castToBool :: A.Operand -> CGMonad A.Operand
castToBool orig@(A.LocalReference (A.IntegerType 1) _) =
return orig
@@ -631,6 +720,8 @@ commonType TypeFloat (TypeInt _) = Just TypeFloat
commonType (TypeInt _) TypeFloat = Just TypeFloat
commonType TypeDouble (TypeInt _) = Just TypeDouble
commonType (TypeInt _) TypeDouble = Just TypeDouble
+commonType TypeFloat TypeFloat = Just TypeFloat
+commonType TypeDouble TypeDouble = Just TypeDouble
commonType TypeFloat TypeDouble = Just TypeDouble
commonType TypeDouble TypeFloat = Just TypeDouble
@@ -716,4 +807,6 @@ toLLVMType TypeVoid = A.VoidType
initializerFor :: Type -> A.C.Constant
initializerFor (TypeInt s) = A.C.Int (fromIntegral s) 0
initializerFor (TypeUInt s) = A.C.Int (fromIntegral s) 0
+initializerFor TypeFloat = A.C.Float (A.F.Single 0)
+initializerFor TypeDouble = A.C.Float (A.F.Double 0)
initializerFor _ = undefined
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-06 21:40:11 +0200