diff options
| -rw-r--r-- | ast.hs | 2 | ||||
| -rw-r--r-- | check.hs | 40 | ||||
| -rw-r--r-- | codegen.hs | 255 | ||||
| -rw-r--r-- | nl/mandel.nl | 69 | ||||
| -rw-r--r-- | parser.hs | 30 | ||||
| -rw-r--r-- | pshow.hs | 2 |
6 files changed, 298 insertions, 100 deletions
@@ -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), ")"] @@ -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 @@ -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; +} @@ -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")) @@ -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 ++ ")" |