summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ast.hs2
-rw-r--r--check.hs40
-rw-r--r--codegen.hs255
-rw-r--r--nl/mandel.nl69
-rw-r--r--parser.hs30
-rw-r--r--pshow.hs2
6 files changed, 298 insertions, 100 deletions
diff --git a/ast.hs b/ast.hs
index 8cecab6..b1b31b7 100644
--- a/ast.hs
+++ b/ast.hs
@@ -38,6 +38,7 @@ data Type = TypeInt Int
deriving (Show, Eq)
data Literal = LitInt Integer
+ | LitFloat Double
| LitString String
| LitVar Name
| LitCall Name [Expression]
@@ -127,6 +128,7 @@ instance PShow Type where
instance PShow Literal where
pshow (LitInt i) = pshow i
+ pshow (LitFloat x) = pshow x
pshow (LitString s) = pshow s
pshow (LitVar n) = n
pshow (LitCall n a) = concat [n, "(", intercalate ", " (map pshow a), ")"]
diff --git a/check.hs b/check.hs
index 9b8ffc6..22d8196 100644
--- a/check.hs
+++ b/check.hs
@@ -141,6 +141,7 @@ typeCheck (Program decls) = Program <$> mapM (goD topLevelNames) decls
-- Postcondition: the expression (if any) has a type annotation.
goE :: Map.Map Name Type -> Expression -> Error Expression
goE _ (ExLit l@(LitInt i) _) = return $ ExLit l $ Just (smallestIntType i)
+ goE _ (ExLit l@(LitFloat f) _) = return $ ExLit l $ Just (smallestFloatType f)
goE _ (ExLit l@(LitString _) _) = return $ ExLit l $ Just (TypePtr (TypeInt 8))
goE names (ExLit l@(LitVar n) _) = maybe (Left $ "Undefined variable '" ++ n ++ "'") (return . ExLit l . Just)
(Map.lookup n names)
@@ -156,7 +157,7 @@ typeCheck (Program decls) = Program <$> mapM (goD topLevelNames) decls
in if canConvert argtype (snd ft !! i)
then return a
else Left $ "Cannot convert type '" ++ pshow argtype ++ "' to '" ++ pshow (snd ft !! i)
- ++ "' in call of function '" ++ pshow n ++ "'"
+ ++ "' in call of function '" ++ n ++ "'"
return $ ExLit (LitCall n rargs) (Just (fst ft))
goE names (ExBinOp bo e1 e2 _) = do
re1 <- goE names e1
@@ -196,7 +197,12 @@ canConvert :: Type -> Type -> Bool
canConvert x y | x == y = True
canConvert (TypeInt f) (TypeInt t) = f <= t
canConvert (TypeUInt f) (TypeUInt t) = f <= t
+canConvert (TypeUInt 1) (TypeInt _) = True
canConvert TypeFloat TypeDouble = True
+canConvert (TypeInt _) TypeFloat = True
+canConvert (TypeInt _) TypeDouble = True
+canConvert (TypeUInt _) TypeFloat = True
+canConvert (TypeUInt _) TypeDouble = True
canConvert _ _ = False
arithBO, compareBO, logicBO, complogBO :: [BinaryOperator]
@@ -206,30 +212,32 @@ logicBO = [BoolAnd, BoolOr]
complogBO = compareBO ++ logicBO
resultTypeBO :: BinaryOperator -> Type -> Type -> Maybe Type
-resultTypeBO Minus (TypePtr t1) (TypePtr t2) | t1 == t2 = Just $ TypeInt 1
-resultTypeBO bo (TypePtr t1) (TypePtr t2) | t1 == t2 && bo `elem` complogBO = Just $ TypeInt 1
+resultTypeBO Minus (TypePtr t1) (TypePtr t2) | t1 == t2 = Just $ TypeUInt 1
+resultTypeBO bo (TypePtr t1) (TypePtr t2) | t1 == t2 && bo `elem` complogBO = Just $ TypeUInt 1
resultTypeBO _ (TypePtr _) _ = Nothing
resultTypeBO _ _ (TypePtr _) = Nothing
resultTypeBO bo (TypeInt s1) (TypeInt s2) | bo `elem` arithBO = Just $ TypeInt (max s1 s2)
-resultTypeBO bo (TypeInt _) (TypeInt _) | bo `elem` complogBO = Just $ TypeInt 1
+resultTypeBO bo (TypeInt _) (TypeInt _) | bo `elem` complogBO = Just $ TypeUInt 1
resultTypeBO bo (TypeUInt s1) (TypeUInt s2) | bo `elem` arithBO = Just $ TypeUInt (max s1 s2)
-resultTypeBO bo (TypeUInt _) (TypeUInt _) | bo `elem` complogBO = Just $ TypeInt 1
+resultTypeBO bo (TypeUInt _) (TypeUInt _) | bo `elem` complogBO = Just $ TypeUInt 1
-resultTypeBO bo t1 t2 | bo `elem` complogBO && t1 == t2 = Just $ TypeInt 1
+resultTypeBO bo t1 t2 | bo `elem` complogBO && t1 == t2 = Just $ TypeUInt 1
-resultTypeBO bo TypeFloat (TypeInt s) | s <= 24 = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1
-resultTypeBO bo (TypeInt s) TypeFloat | s <= 24 = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1
-resultTypeBO bo TypeDouble (TypeInt s) | s <= 53 = Just $ if bo `elem` arithBO then TypeDouble else TypeInt 1
-resultTypeBO bo (TypeInt s) TypeDouble | s <= 53 = Just $ if bo `elem` arithBO then TypeDouble else TypeInt 1
-resultTypeBO bo TypeFloat TypeDouble = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1
-resultTypeBO bo TypeDouble TypeFloat = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1
+resultTypeBO bo TypeFloat (TypeInt s) | s <= 24 = Just $ if bo `elem` arithBO then TypeFloat else TypeUInt 1
+resultTypeBO bo (TypeInt s) TypeFloat | s <= 24 = Just $ if bo `elem` arithBO then TypeFloat else TypeUInt 1
+resultTypeBO bo TypeDouble (TypeInt s) | s <= 53 = Just $ if bo `elem` arithBO then TypeDouble else TypeUInt 1
+resultTypeBO bo (TypeInt s) TypeDouble | s <= 53 = Just $ if bo `elem` arithBO then TypeDouble else TypeUInt 1
+resultTypeBO bo TypeFloat TypeFloat = Just $ if bo `elem` arithBO then TypeFloat else TypeUInt 1
+resultTypeBO bo TypeDouble TypeDouble = Just $ if bo `elem` arithBO then TypeDouble else TypeUInt 1
+resultTypeBO bo TypeFloat TypeDouble = Just $ if bo `elem` arithBO then TypeDouble else TypeUInt 1
+resultTypeBO bo TypeDouble TypeFloat = Just $ if bo `elem` arithBO then TypeDouble else TypeUInt 1
resultTypeBO _ _ _ = Nothing
resultTypeUO :: UnaryOperator -> Type -> Maybe Type
-resultTypeUO Not _ = Just $ TypeInt 1
+resultTypeUO Not _ = Just $ TypeUInt 1
resultTypeUO Address t = Just $ TypePtr t
resultTypeUO uo t@(TypeInt _) | uo `elem` [Negate, Invert] = Just t
resultTypeUO uo t@(TypeUInt _) | uo `elem` [Negate, Invert] = Just t
@@ -238,6 +246,11 @@ resultTypeUO Negate TypeDouble = Just TypeDouble
resultTypeUO Dereference t@(TypePtr _) = Just t
resultTypeUO _ _ = Nothing
+smallestFloatType :: Double -> Type
+smallestFloatType d =
+ let truncfloat = realToFrac (realToFrac d :: Float) :: Double
+ in if d == truncfloat then TypeFloat else TypeDouble
+
smallestIntType :: Integer -> Type
smallestIntType i
| i >= -2^7 && i < 2^7 = TypeInt 8
@@ -391,6 +404,7 @@ mapProgram prog mapper = goP prog
goL :: MapperHandler Literal
goL l@(LitString _) = h_l l
goL l@(LitInt _) = h_l l
+ goL l@(LitFloat _) = h_l l
goL (LitVar n) = goN n >>= (h_l . LitVar)
goL (LitCall n a) = do
rn <- goN n
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
diff --git a/nl/mandel.nl b/nl/mandel.nl
new file mode 100644
index 0000000..cef9eb2
--- /dev/null
+++ b/nl/mandel.nl
@@ -0,0 +1,69 @@
+type int = i32;
+type char = i8;
+type string = ptr(char);
+
+extern func void(int) putchar;
+
+void printnum(int n) {
+ if (n < 0) {
+ putchar('-');
+ n = -n;
+ }
+ if (n == 0) {
+ putchar('0');
+ return;
+ }
+ while (n > 0) {
+ putchar('0' + n % 10);
+ n = n / 10;
+ }
+}
+
+int maxiter;
+double lbound;
+double rbound;
+double tbound;
+double bbound;
+double hincr;
+double vincr;
+
+int mandeliter(double x, double y) {
+ double a = x;
+ double b = y;
+ double a2 = a * a;
+ double b2 = b * b;
+ int n = 0;
+ while (n < maxiter && a2 + b2 < 4) {
+ b = 2 * a * b + y;
+ a = a2 - b2 + x;
+ a2 = a * a;
+ b2 = b * b;
+ n = n + 1;
+ }
+ return n;
+}
+
+int main() {
+ maxiter = 32;
+ lbound = -2.0;
+ rbound = 1.0;
+ tbound = 1.5;
+ bbound = -1.5;
+ // hincr = 0.03125;
+ hincr = 0.0625;
+ vincr = 0.0625;
+
+ double y = tbound;
+ while (y >= bbound) {
+ double x = lbound;
+ while (x <= rbound) {
+ int niter = mandeliter(x, y);
+ printnum(niter);
+ putchar(' ');
+ x = x + hincr;
+ }
+ putchar('\n');
+ y = y - vincr;
+ }
+ return 0;
+}
diff --git a/parser.hs b/parser.hs
index 1b103d4..3ba5e18 100644
--- a/parser.hs
+++ b/parser.hs
@@ -112,8 +112,8 @@ pParenExpr = do
return e
pLiteral :: Parser Literal
-pLiteral = (LitInt <$> pInteger) <|> (LitInt <$> pCharStr) <|> (LitString <$> pString)
- <|> try pLitCall <|> (LitVar <$> pName)
+pLiteral = (LitFloat <$> pFloat) <|> (LitInt <$> pInteger) <|> (LitInt <$> pCharStr)
+ <|> (LitString <$> pString) <|> try pLitCall <|> (LitVar <$> pName)
pLitCall :: Parser Literal
pLitCall = do
@@ -183,8 +183,8 @@ pStReturn = do
primitiveTypes :: Map.Map String Type
primitiveTypes = Map.fromList
- [("i1", TypeInt 1), ("i8", TypeInt 8), ("i16", TypeInt 16), ("i32", TypeInt 32), ("i64", TypeInt 64),
- ("u8", TypeUInt 8), ("u16", TypeUInt 16), ("u32", TypeUInt 32), ("u64", TypeUInt 64),
+ [("i8", TypeInt 8), ("i16", TypeInt 16), ("i32", TypeInt 32), ("i64", TypeInt 64),
+ ("u1", TypeUInt 1), ("u8", TypeUInt 8), ("u16", TypeUInt 16), ("u32", TypeUInt 32), ("u64", TypeUInt 64),
("float", TypeFloat), ("double", TypeDouble)]
findPrimType :: String -> Type
@@ -231,7 +231,25 @@ pName = ((:) <$> pFirstChar <*> many pOtherChar) << pWhiteComment
pOtherChar = satisfy (isAlpha .||. isDigit .||. (=='_'))
pInteger :: Parser Integer
-pInteger = (read <$> many1 (satisfy isDigit)) << pWhiteComment
+pInteger = (read <$> many1 digit) << pWhiteComment
+
+pFloat :: Parser Double
+pFloat = try $ do
+ pre <- many1 digit
+ post <- choice [pExponent,
+ (do
+ void $ char '.'
+ s <- many1 digit
+ ex <- option "" pExponent
+ return $ '.' : s ++ ex)]
+ pWhiteComment
+ return $ read $ pre ++ post
+ where
+ pExponent = do
+ c <- choice [char 'e', char 'E']
+ pm <- option "" $ choice [string "+", string "-"]
+ val <- many1 digit
+ return $ c : pm ++ val
pString :: Parser String
pString = do
@@ -264,7 +282,7 @@ pEscapeHex = do
return $ chr $ 16 * c1 + c2
where
pHexChar :: Parser Int
- pHexChar = (liftM (\c -> ord c - ord '0') (satisfy isDigit))
+ pHexChar = (liftM (\c -> ord c - ord '0') digit)
<|> (liftM (\c -> ord c - ord 'a' + 10) (oneOf "abcdef"))
<|> (liftM (\c -> ord c - ord 'A' + 10) (oneOf "ABCDEF"))
diff --git a/pshow.hs b/pshow.hs
index 64fbab1..6fba9ff 100644
--- a/pshow.hs
+++ b/pshow.hs
@@ -13,6 +13,8 @@ pprint = putStrLn . pshow
instance PShow String where {pshow = show}
instance PShow Int where {pshow = show}
instance PShow Integer where {pshow = show}
+instance PShow Float where {pshow = show}
+instance PShow Double where {pshow = show}
instance (PShow a, PShow b) => PShow (a, b) where
pshow (a, b) = "(" ++ pshow a ++ "," ++ pshow b ++ ")"