diff options
| -rw-r--r-- | check.hs | 380 | ||||
| -rw-r--r-- | codegen.hs | 415 | ||||
| -rw-r--r-- | main.hs | 10 | ||||
| -rw-r--r-- | simple.nl | 9 |
4 files changed, 438 insertions, 376 deletions
diff --git a/check.hs b/check.hs new file mode 100644 index 0000000..5f7dd12 --- /dev/null +++ b/check.hs @@ -0,0 +1,380 @@ +module Check(checkProgram) where + +import Control.Monad +import Data.Maybe +import qualified Data.Map.Strict as Map +--import Debug.Trace + +import AST +import PShow + + +type Error a = Either String a + + +checkProgram :: Program -> Error Program +checkProgram prog = do + let processed = replaceTypes prog + checkUndefinedTypes processed + typeCheck processed >>= bundleVarDecls + + +replaceTypes :: Program -> Program +replaceTypes prog@(Program decls) = mapProgram' filtered mapper + where + filtered = Program $ filter notTypedef decls + mapper = defaultPM' {typeHandler' = typeReplacer (findTypeRenames prog)} + + notTypedef :: Declaration -> Bool + notTypedef (DecTypedef _ _) = False + notTypedef _ = True + + typeReplacer :: Map.Map Name Type -> Type -> Type + typeReplacer m t@(TypeName n) = maybe t id $ Map.lookup n m + typeReplacer _ t = t + + findTypeRenames :: Program -> Map.Map Name Type + findTypeRenames (Program d) = foldl go Map.empty d + where + go :: Map.Map Name Type -> Declaration -> Map.Map Name Type + go m (DecTypedef t n) = Map.insert n t m + go m _ = m + + +checkUndefinedTypes :: Program -> Error () +checkUndefinedTypes prog = fmap (const ()) $ mapProgram prog $ defaultPM {typeHandler = check} + where + check :: MapperHandler Type + check (TypeName n) = Left $ "Undefined type name '" ++ n ++ "'" + check t = Right t + + +typeCheck :: Program -> Error Program +typeCheck (Program decls) = Program <$> mapM (goD topLevelNames) decls + where + topLevelNames :: Map.Map Name Type + topLevelNames = foldr (uncurry Map.insert) Map.empty pairs + where pairs = map ((,) <$> nameOf <*> typeOf) $ filter isVarDecl decls + + functionTypes :: Map.Map Name (Type,[Type]) + functionTypes = foldr (uncurry Map.insert) Map.empty pairs + where pairs = map ((,) <$> nameOf <*> getTypes) $ filter isFunctionDecl decls + getTypes (DecFunction rt _ args _) = (rt, map fst args) + getTypes _ = undefined + + isVarDecl (DecVariable {}) = True + isVarDecl _ = False + + isFunctionDecl (DecFunction {}) = True + isFunctionDecl _ = False + + goD :: Map.Map Name Type -> Declaration -> Error Declaration + goD names (DecFunction frt name args body) = do + newbody <- goB frt (foldr (\(t,n) m -> Map.insert n t m) names args) body + return $ DecFunction frt name args newbody + goD _ dec = return dec + + goB :: Type -- function return type + -> Map.Map Name Type -> Block -> Error Block + goB frt names (Block stmts) = Block . snd <$> foldl foldfunc (return (names, [])) stmts + where + foldfunc :: Error (Map.Map Name Type, [Statement]) -> Statement -> Error (Map.Map Name Type, [Statement]) + foldfunc ep st = do + (names', lst) <- ep + (newnames', newst) <- goS frt names' st + return (newnames', lst ++ [newst]) -- TODO: fix slow tail-append + + goS :: Type -- function return type + -> Map.Map Name Type -> Statement -> Error (Map.Map Name Type, Statement) + goS _ names st@(StVarDeclaration t n Nothing) = return (Map.insert n t names, st) + goS frt names (StVarDeclaration t n (Just e)) = do + (newnames, _) <- goS frt names (StVarDeclaration t n Nothing) + (_, StAssignment _ newe) <- goS frt newnames (StAssignment n e) + return (newnames, StVarDeclaration t n (Just newe)) + goS _ names (StAssignment n e) = maybe (Left $ "Undefined variable '" ++ n ++ "'") go (Map.lookup n names) + where go dsttype = do + re <- goE names e + let (Just extype) = exTypeOf re + if canConvert extype dsttype + then return (names, StAssignment n re) + else Left $ "Cannot convert type '" ++ pshow extype ++ "' to '" + ++ pshow dsttype ++ "' in assignment to variable '" ++ n ++ "'" + goS _ names st@StEmpty = return (names, st) + goS frt names (StBlock bl) = do + newbl <- goB frt names bl + return (names, StBlock newbl) + goS _ names (StExpr e) = do + re <- goE names e + return (names, StExpr re) + goS frt names (StIf e s1 s2) = do + re <- goE names e + (_, rs1) <- goS frt names s1 + (_, rs2) <- goS frt names s2 + return (names, StIf re rs1 rs2) + goS frt names (StWhile e s) = do + re <- goE names e + (_, rs) <- goS frt names s + return (names, StWhile re rs) + goS frt names (StReturn e) = do + re <- goE names e + let (Just extype) = exTypeOf re + if canConvert extype frt + then return (names, StReturn re) + else Left $ "Cannot convert type '" ++ pshow extype ++ "' to '" + ++ pshow frt ++ "' in return statement" + + -- 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@(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) + goE names (ExLit l@(LitCall n args) _) = do + ft <- maybe (Left $ "Unknown function '" ++ n ++ "'") return $ Map.lookup n functionTypes + rargs <- mapM (goE names) args + when (length rargs /= length (snd ft)) + $ Left ("Expected " ++ show (length (snd ft)) ++ "arguments to " + ++ "function '" ++ n ++ "', but got " ++ show (length rargs)) + >> return () + flip mapM_ rargs $ + \a -> let argtype = fromJust (exTypeOf a) + in if canConvert argtype (fst ft) + then return a + else Left $ "Cannot convert type '" ++ pshow argtype ++ "' to '" ++ pshow (fst ft) + ++ "' in call of function '" ++ pshow n ++ "'" + return $ ExLit l (Just (fst ft)) + goE names (ExBinOp bo e1 e2 _) = do + re1 <- goE names e1 + re2 <- goE names e2 + maybe (Left $ "Cannot use operator '" ++ pshow bo ++ "' with argument types '" + ++ pshow (fromJust $ exTypeOf re1) ++ "' and '" ++ pshow (fromJust $ exTypeOf re2) ++ "'") + (return . ExBinOp bo re1 re2 . Just) + $ typeCompatibleBO bo (fromJust $ exTypeOf re1) (fromJust $ exTypeOf re2) + goE names (ExUnOp uo e _) = do + re <- goE names e + maybe (Left $ "Cannot use operator '" ++ pshow uo ++ "' with argument type '" ++ pshow (fromJust $ exTypeOf re)) + (return . ExUnOp uo re . Just) + $ typeCompatibleUO uo (fromJust $ exTypeOf re) + + +bundleVarDecls :: Program -> Error Program +bundleVarDecls prog = mapProgram prog $ defaultPM {blockHandler = goBlock} + where + goBlock :: MapperHandler Block + goBlock (Block stmts) = + let isVarDecl (StVarDeclaration {}) = True + isVarDecl _ = False + + removeDecls [] = [] + removeDecls ((StVarDeclaration _ n (Just ex)):rest) = StAssignment n ex : removeDecls rest + removeDecls ((StVarDeclaration _ _ Nothing):rest) = removeDecls rest + removeDecls (st:rest) = st : removeDecls rest + + onlyDecl (StVarDeclaration t n _) = StVarDeclaration t n Nothing + onlyDecl _ = undefined + + vdecls = map onlyDecl $ filter isVarDecl stmts + in return $ Block $ vdecls ++ removeDecls stmts + + +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 TypeFloat TypeDouble = True +canConvert _ _ = False + +arithBO, compareBO, logicBO, complogBO :: [BinaryOperator] +arithBO = [Plus, Minus, Times, Divide, Modulo] +compareBO = [Equal, Unequal, Greater, Less, GEqual, LEqual] +logicBO = [BoolAnd, BoolOr] +complogBO = compareBO ++ logicBO + +typeCompatibleBO :: BinaryOperator -> Type -> Type -> Maybe Type +typeCompatibleBO Minus (TypePtr t1) (TypePtr t2) | t1 == t2 = Just $ TypeInt 1 +typeCompatibleBO bo (TypePtr t1) (TypePtr t2) | t1 == t2 && bo `elem` complogBO = Just $ TypeInt 1 +typeCompatibleBO _ (TypePtr _) _ = Nothing +typeCompatibleBO _ _ (TypePtr _) = Nothing + +typeCompatibleBO bo (TypeInt s1) (TypeInt s2) | bo `elem` arithBO = Just $ TypeInt (max s1 s2) +typeCompatibleBO bo (TypeInt _) (TypeInt _) | bo `elem` complogBO = Just $ TypeInt 1 + +typeCompatibleBO bo (TypeUInt s1) (TypeUInt s2) | bo `elem` arithBO = Just $ TypeUInt (max s1 s2) +typeCompatibleBO bo (TypeUInt _) (TypeUInt _) | bo `elem` complogBO = Just $ TypeInt 1 + +typeCompatibleBO bo t1 t2 | bo `elem` complogBO && t1 == t2 = Just $ TypeInt 1 + +typeCompatibleBO bo TypeFloat (TypeInt s) | s <= 24 = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1 +typeCompatibleBO bo (TypeInt s) TypeFloat | s <= 24 = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1 +typeCompatibleBO bo TypeDouble (TypeInt s) | s <= 53 = Just $ if bo `elem` arithBO then TypeDouble else TypeInt 1 +typeCompatibleBO bo (TypeInt s) TypeDouble | s <= 53 = Just $ if bo `elem` arithBO then TypeDouble else TypeInt 1 +typeCompatibleBO bo TypeFloat TypeDouble = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1 +typeCompatibleBO bo TypeDouble TypeFloat = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1 + +typeCompatibleBO _ _ _ = Nothing + +typeCompatibleUO :: UnaryOperator -> Type -> Maybe Type +typeCompatibleUO Not _ = Just $ TypeInt 1 +typeCompatibleUO Address t = Just $ TypePtr t +typeCompatibleUO uo t@(TypeInt _) | uo `elem` [Negate, Invert] = Just t +typeCompatibleUO uo t@(TypeUInt _) | uo `elem` [Negate, Invert] = Just t +typeCompatibleUO Negate TypeFloat = Just TypeFloat +typeCompatibleUO Negate TypeDouble = Just TypeDouble +typeCompatibleUO Dereference t@(TypePtr _) = Just t +typeCompatibleUO _ _ = Nothing + +smallestIntType :: Integer -> Type +smallestIntType i + | i >= -2^7 && i < 2^7 = TypeInt 8 + | i >= -2^15 && i < 2^15 = TypeInt 16 + | i >= -2^31 && i < 2^31 = TypeInt 32 + | otherwise = TypeInt 64 + +-- smallestUIntType :: Integer -> Type +-- smallestUIntType i +-- | i >= 0 && i < 2^8 = TypeUInt 8 +-- | i >= 0 && i < 2^16 = TypeUInt 16 +-- | i >= 0 && i < 2^32 = TypeUInt 32 +-- | otherwise = TypeUInt 64 + + +type MapperHandler a = a -> Error a + +data ProgramMapper = ProgramMapper + {declarationHandler :: MapperHandler Declaration + ,blockHandler :: MapperHandler Block + ,typeHandler :: MapperHandler Type + ,literalHandler :: MapperHandler Literal + ,binOpHandler :: MapperHandler BinaryOperator + ,unOpHandler :: MapperHandler UnaryOperator + ,expressionHandler :: MapperHandler Expression + ,statementHandler :: MapperHandler Statement + ,nameHandler :: MapperHandler Name} + +type MapperHandler' a = a -> a + +data ProgramMapper' = ProgramMapper' + {declarationHandler' :: MapperHandler' Declaration + ,blockHandler' :: MapperHandler' Block + ,typeHandler' :: MapperHandler' Type + ,literalHandler' :: MapperHandler' Literal + ,binOpHandler' :: MapperHandler' BinaryOperator + ,unOpHandler' :: MapperHandler' UnaryOperator + ,expressionHandler' :: MapperHandler' Expression + ,statementHandler' :: MapperHandler' Statement + ,nameHandler' :: MapperHandler' Name} + +defaultPM :: ProgramMapper +defaultPM = ProgramMapper return return return return return return return return return + +defaultPM' :: ProgramMapper' +defaultPM' = ProgramMapper' id id id id id id id id id + +mapProgram' :: Program -> ProgramMapper' -> Program +mapProgram' prog mapper = (\(Right r) -> r) $ mapProgram prog $ ProgramMapper + {declarationHandler = return . declarationHandler' mapper + ,blockHandler = return . blockHandler' mapper + ,typeHandler = return . typeHandler' mapper + ,literalHandler = return . literalHandler' mapper + ,binOpHandler = return . binOpHandler' mapper + ,unOpHandler = return . unOpHandler' mapper + ,expressionHandler = return . expressionHandler' mapper + ,statementHandler = return . statementHandler' mapper + ,nameHandler = return . nameHandler' mapper} + +mapProgram :: Program -> ProgramMapper -> Error Program +mapProgram prog mapper = goP prog + where + h_d = declarationHandler mapper + h_b = blockHandler mapper + h_t = typeHandler mapper + h_l = literalHandler mapper + h_bo = binOpHandler mapper + h_uo = unOpHandler mapper + h_e = expressionHandler mapper + h_s = statementHandler mapper + h_n = nameHandler mapper + + goP :: MapperHandler Program + goP (Program decls) = Program <$> sequence (map (\d -> goD d >>= h_d) decls) + + goD :: MapperHandler Declaration + goD (DecFunction t n a b) = do + rt <- goT t + rn <- goN n + ra <- sequence $ map (\(at,an) -> (,) <$> goT at <*> goN an) a + rb <- goB b + h_d $ DecFunction rt rn ra rb + goD (DecVariable t n mv) = do + rt <- goT t + rn <- goN n + rmv <- sequence $ fmap goE mv + h_d $ DecVariable rt rn rmv + goD (DecTypedef t n) = do + rt <- goT t + rn <- goN n + h_d $ DecTypedef rt rn + + goT :: MapperHandler Type + goT (TypePtr t) = goT t >>= (h_t . TypePtr) + goT (TypeName n) = goN n >>= (h_t . TypeName) + goT t = h_t t + + goN :: MapperHandler Name + goN = h_n + + goB :: MapperHandler Block + goB (Block sts) = (Block <$> sequence (map goS sts)) >>= h_b + + goE :: MapperHandler Expression + goE (ExLit l mt) = do + rl <- goL l + h_e $ ExLit rl mt + goE (ExBinOp bo e1 e2 mt) = do + rbo <- goBO bo + re1 <- goE e1 + re2 <- goE e2 + h_e $ ExBinOp rbo re1 re2 mt + goE (ExUnOp uo e mt) = do + ruo <- goUO uo + re <- goE e + h_e $ ExUnOp ruo re mt + + goS :: MapperHandler Statement + goS StEmpty = h_s StEmpty + goS (StBlock b) = goB b >>= (h_s . StBlock) + goS (StExpr e) = goE e >>= (h_s . StExpr) + goS (StVarDeclaration t n me) = do + rt <- goT t + rn <- goN n + rme <- sequence $ fmap goE me + h_s $ StVarDeclaration rt rn rme + goS (StAssignment n e) = do + rn <- goN n + re <- goE e + h_s $ StAssignment rn re + goS (StIf e s1 s2) = do + re <- goE e + rs1 <- goS s1 + rs2 <- goS s2 + h_s $ StIf re rs1 rs2 + goS (StWhile e s) = do + re <- goE e + rs <- goS s + h_s $ StWhile re rs + goS (StReturn e) = goE e >>= (h_s . StReturn) + + goL :: MapperHandler Literal + goL l@(LitString _) = h_l l + goL l@(LitInt _) = h_l l + goL (LitVar n) = goN n >>= (h_l . LitVar) + goL (LitCall n a) = do + rn <- goN n + ra <- sequence $ map goE a + h_l $ LitCall rn ra + + goBO :: MapperHandler BinaryOperator + goBO = h_bo + + goUO :: MapperHandler UnaryOperator + goUO = h_uo @@ -1,19 +1,18 @@ -module Codegen(codegen, A.Module) where - -import Control.Monad -import Data.Maybe -import qualified Data.Map.Strict as Map --- import qualified LLVM.General.AST.Type as A --- import qualified LLVM.General.AST.Global as A --- import qualified LLVM.General.AST.Constant as A.C +module Codegen(codegen) where + +-- import Control.Monad +-- import Data.Maybe +-- import qualified Data.Map.Strict as Map +import qualified LLVM.General.AST.Type as A +import qualified LLVM.General.AST.Global as A.G +import qualified LLVM.General.AST.Constant as A.C -- import qualified LLVM.General.AST.Operand as A -- import qualified LLVM.General.AST.Name as A -- import qualified LLVM.General.AST.Instruction as A import qualified LLVM.General.AST as A -import Debug.Trace +-- import Debug.Trace import AST -import PShow type Error a = Either String a @@ -24,378 +23,46 @@ codegen :: Program -- Program to compile -> String -- File name of source -> Error A.Module codegen prog name fname = do - defs <- generateDefs (preprocess prog) + defs <- generateDefs prog return $ A.defaultModule { A.moduleName = name, A.moduleSourceFileName = fname, A.moduleDefinitions = defs } -preprocess :: Program -> Program -preprocess prog@(Program decls) = mapProgram' filtered mapper - where - filtered = Program $ filter notTypedef decls - mapper = defaultPM' {typeHandler' = typeReplacer (findTypeRenames prog)} - - notTypedef :: Declaration -> Bool - notTypedef (DecTypedef _ _) = False - notTypedef _ = True - - typeReplacer :: Map.Map Name Type -> Type -> Type - typeReplacer m t@(TypeName n) = maybe t id $ Map.lookup n m - typeReplacer _ t = t - - findTypeRenames :: Program -> Map.Map Name Type - findTypeRenames (Program d) = foldl go Map.empty d - where - go :: Map.Map Name Type -> Declaration -> Map.Map Name Type - go m (DecTypedef t n) = Map.insert n t m - go m _ = m - generateDefs :: Program -> Error [A.Definition] generateDefs prog = do - checkUndefinedTypes prog - checked <- typeCheck prog - collected <- collectVarDecls checked - void $ trace "Collected:" $ return [] - void $ trace (pshow collected) $ return [] - void $ fail "TODO" - return [] - -checkUndefinedTypes :: Program -> Error () -checkUndefinedTypes prog = fmap (const ()) $ mapProgram prog $ defaultPM {typeHandler = check} - where - check :: MapperHandler Type - check (TypeName n) = Left $ "Undefined type name '" ++ n ++ "'" - check t = Right t - - -typeCheck :: Program -> Error Program -typeCheck (Program decls) = Program <$> mapM (goD topLevelNames) decls - where - topLevelNames :: Map.Map Name Type - topLevelNames = foldr (uncurry Map.insert) Map.empty pairs - where pairs = map ((,) <$> nameOf <*> typeOf) $ filter isVarDecl decls - - functionTypes :: Map.Map Name (Type,[Type]) - functionTypes = foldr (uncurry Map.insert) Map.empty pairs - where pairs = map ((,) <$> nameOf <*> getTypes) $ filter isFunctionDecl decls - getTypes (DecFunction rt _ args _) = (rt, map fst args) - getTypes _ = undefined - - isVarDecl (DecVariable {}) = True - isVarDecl _ = False - - isFunctionDecl (DecFunction {}) = True - isFunctionDecl _ = False + vardecls <- genGlobalVars prog + return vardecls - goD :: Map.Map Name Type -> Declaration -> Error Declaration - goD names (DecFunction frt name args body) = do - newbody <- goB frt (foldr (\(t,n) m -> Map.insert n t m) names args) body - return $ DecFunction frt name args newbody - goD _ dec = return dec - - goB :: Type -- function return type - -> Map.Map Name Type -> Block -> Error Block - goB frt names (Block stmts) = Block . snd <$> foldl foldfunc (return (names, [])) stmts - where - foldfunc :: Error (Map.Map Name Type, [Statement]) -> Statement -> Error (Map.Map Name Type, [Statement]) - foldfunc ep st = do - (names', lst) <- ep - (newnames', newst) <- goS frt names' st - return (newnames', lst ++ [newst]) -- TODO: fix slow tail-append - - goS :: Type -- function return type - -> Map.Map Name Type -> Statement -> Error (Map.Map Name Type, Statement) - goS _ names st@(StVarDeclaration t n Nothing) = return (Map.insert n t names, st) - goS frt names (StVarDeclaration t n (Just e)) = do - (newnames, _) <- goS frt names (StVarDeclaration t n Nothing) - goS frt newnames (StAssignment n e) - goS _ names (StAssignment n e) = maybe (Left $ "Undefined variable '" ++ n ++ "'") go (Map.lookup n names) - where go dsttype = do - re <- goE names e - let (Just extype) = exTypeOf re - if canConvert extype dsttype - then return (names, StAssignment n re) - else Left $ "Cannot convert type '" ++ pshow extype ++ "' to '" - ++ pshow dsttype ++ "' in assignment to variable '" ++ n ++ "'" - goS _ names st@StEmpty = return (names, st) - goS frt names (StBlock bl) = do - newbl <- goB frt names bl - return (names, StBlock newbl) - goS _ names (StExpr e) = do - re <- goE names e - return (names, StExpr re) - goS frt names (StIf e s1 s2) = do - re <- goE names e - (_, rs1) <- goS frt names s1 - (_, rs2) <- goS frt names s2 - return (names, StIf re rs1 rs2) - goS frt names (StWhile e s) = do - re <- goE names e - (_, rs) <- goS frt names s - return (names, StWhile re rs) - goS frt names (StReturn e) = do - re <- goE names e - let (Just extype) = exTypeOf re - if canConvert extype frt - then return (names, StReturn re) - else Left $ "Cannot convert type '" ++ pshow extype ++ "' to '" - ++ pshow frt ++ "' in return statement" - - -- 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@(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) - goE names (ExLit l@(LitCall n args) _) = do - ft <- maybe (Left $ "Unknown function '" ++ n ++ "'") return $ Map.lookup n functionTypes - rargs <- mapM (goE names) args - when (length rargs /= length (snd ft)) - $ Left ("Expected " ++ show (length (snd ft)) ++ "arguments to " - ++ "function '" ++ n ++ "', but got " ++ show (length rargs)) - >> return () - flip mapM_ rargs $ - \a -> let argtype = fromJust (exTypeOf a) - in if canConvert argtype (fst ft) - then return a - else Left $ "Cannot convert type '" ++ pshow argtype ++ "' to '" ++ pshow (fst ft) - ++ "' in call of function '" ++ pshow n ++ "'" - return $ ExLit l (Just (fst ft)) - goE names (ExBinOp bo e1 e2 _) = do - re1 <- goE names e1 - re2 <- goE names e2 - maybe (Left $ "Cannot use operator '" ++ pshow bo ++ "' with argument types '" - ++ pshow (fromJust $ exTypeOf re1) ++ "' and '" ++ pshow (fromJust $ exTypeOf re2) ++ "'") - (return . ExBinOp bo re1 re2 . Just) - $ typeCompatibleBO bo (fromJust $ exTypeOf re1) (fromJust $ exTypeOf re2) - goE names (ExUnOp uo e _) = do - re <- goE names e - maybe (Left $ "Cannot use operator '" ++ pshow uo ++ "' with argument type '" ++ pshow (fromJust $ exTypeOf re)) - (return . ExUnOp uo re . Just) - $ typeCompatibleUO uo (fromJust $ exTypeOf re) - - -collectVarDecls :: Program -> Error Program -collectVarDecls prog = mapProgram prog $ defaultPM {blockHandler = goBlock} +genGlobalVars :: Program -> Error [A.Definition] +genGlobalVars (Program decs) = mapM gen $ filter isDecVariable decs where - goBlock :: MapperHandler Block - goBlock (Block stmts) = - let isVarDecl (StVarDeclaration {}) = True - isVarDecl _ = False - - removeDecls [] = [] - removeDecls ((StVarDeclaration _ n (Just ex)):rest) = StAssignment n ex : removeDecls rest - removeDecls ((StVarDeclaration _ _ Nothing):rest) = removeDecls rest - removeDecls (st:rest) = st : removeDecls rest - - onlyDecl (StVarDeclaration t n _) = StVarDeclaration t n Nothing - onlyDecl _ = undefined - - vdecls = map onlyDecl $ filter isVarDecl stmts - in return $ Block $ vdecls ++ removeDecls stmts - - -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 TypeFloat TypeDouble = True -canConvert _ _ = False - -arithBO, compareBO, logicBO, complogBO :: [BinaryOperator] -arithBO = [Plus, Minus, Times, Divide, Modulo] -compareBO = [Equal, Unequal, Greater, Less, GEqual, LEqual] -logicBO = [BoolAnd, BoolOr] -complogBO = compareBO ++ logicBO - -typeCompatibleBO :: BinaryOperator -> Type -> Type -> Maybe Type -typeCompatibleBO Minus (TypePtr t1) (TypePtr t2) | t1 == t2 = Just $ TypeInt 1 -typeCompatibleBO bo (TypePtr t1) (TypePtr t2) | t1 == t2 && bo `elem` complogBO = Just $ TypeInt 1 -typeCompatibleBO _ (TypePtr _) _ = Nothing -typeCompatibleBO _ _ (TypePtr _) = Nothing - -typeCompatibleBO bo (TypeInt s1) (TypeInt s2) | bo `elem` arithBO = Just $ TypeInt (max s1 s2) -typeCompatibleBO bo (TypeInt _) (TypeInt _) | bo `elem` complogBO = Just $ TypeInt 1 - -typeCompatibleBO bo (TypeUInt s1) (TypeUInt s2) | bo `elem` arithBO = Just $ TypeUInt (max s1 s2) -typeCompatibleBO bo (TypeUInt _) (TypeUInt _) | bo `elem` complogBO = Just $ TypeInt 1 - -typeCompatibleBO bo t1 t2 | bo `elem` complogBO && t1 == t2 = Just $ TypeInt 1 - -typeCompatibleBO bo TypeFloat (TypeInt s) | s <= 24 = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1 -typeCompatibleBO bo (TypeInt s) TypeFloat | s <= 24 = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1 -typeCompatibleBO bo TypeDouble (TypeInt s) | s <= 53 = Just $ if bo `elem` arithBO then TypeDouble else TypeInt 1 -typeCompatibleBO bo (TypeInt s) TypeDouble | s <= 53 = Just $ if bo `elem` arithBO then TypeDouble else TypeInt 1 -typeCompatibleBO bo TypeFloat TypeDouble = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1 -typeCompatibleBO bo TypeDouble TypeFloat = Just $ if bo `elem` arithBO then TypeFloat else TypeInt 1 - -typeCompatibleBO _ _ _ = Nothing - -typeCompatibleUO :: UnaryOperator -> Type -> Maybe Type -typeCompatibleUO Not _ = Just $ TypeInt 1 -typeCompatibleUO Address t = Just $ TypePtr t -typeCompatibleUO uo t@(TypeInt _) | uo `elem` [Negate, Invert] = Just t -typeCompatibleUO uo t@(TypeUInt _) | uo `elem` [Negate, Invert] = Just t -typeCompatibleUO Negate TypeFloat = Just TypeFloat -typeCompatibleUO Negate TypeDouble = Just TypeDouble -typeCompatibleUO Dereference t@(TypePtr _) = Just t -typeCompatibleUO _ _ = Nothing - -smallestIntType :: Integer -> Type -smallestIntType i - | i >= -2^7 && i < 2^7 = TypeInt 8 - | i >= -2^15 && i < 2^15 = TypeInt 16 - | i >= -2^31 && i < 2^31 = TypeInt 32 - | otherwise = TypeInt 64 - --- smallestUIntType :: Integer -> Type --- smallestUIntType i --- | i >= 0 && i < 2^8 = TypeUInt 8 --- | i >= 0 && i < 2^16 = TypeUInt 16 --- | i >= 0 && i < 2^32 = TypeUInt 32 --- | otherwise = TypeUInt 64 - - -type MapperHandler a = a -> Error a - -data ProgramMapper = ProgramMapper - {declarationHandler :: MapperHandler Declaration - ,blockHandler :: MapperHandler Block - ,typeHandler :: MapperHandler Type - ,literalHandler :: MapperHandler Literal - ,binOpHandler :: MapperHandler BinaryOperator - ,unOpHandler :: MapperHandler UnaryOperator - ,expressionHandler :: MapperHandler Expression - ,statementHandler :: MapperHandler Statement - ,nameHandler :: MapperHandler Name} - -type MapperHandler' a = a -> a - -data ProgramMapper' = ProgramMapper' - {declarationHandler' :: MapperHandler' Declaration - ,blockHandler' :: MapperHandler' Block - ,typeHandler' :: MapperHandler' Type - ,literalHandler' :: MapperHandler' Literal - ,binOpHandler' :: MapperHandler' BinaryOperator - ,unOpHandler' :: MapperHandler' UnaryOperator - ,expressionHandler' :: MapperHandler' Expression - ,statementHandler' :: MapperHandler' Statement - ,nameHandler' :: MapperHandler' Name} - -defaultPM :: ProgramMapper -defaultPM = ProgramMapper return return return return return return return return return - -defaultPM' :: ProgramMapper' -defaultPM' = ProgramMapper' id id id id id id id id id - -mapProgram' :: Program -> ProgramMapper' -> Program -mapProgram' prog mapper = (\(Right r) -> r) $ mapProgram prog $ ProgramMapper - {declarationHandler = return . declarationHandler' mapper - ,blockHandler = return . blockHandler' mapper - ,typeHandler = return . typeHandler' mapper - ,literalHandler = return . literalHandler' mapper - ,binOpHandler = return . binOpHandler' mapper - ,unOpHandler = return . unOpHandler' mapper - ,expressionHandler = return . expressionHandler' mapper - ,statementHandler = return . statementHandler' mapper - ,nameHandler = return . nameHandler' mapper} - -mapProgram :: Program -> ProgramMapper -> Error Program -mapProgram prog mapper = goP prog - where - h_d = declarationHandler mapper - h_b = blockHandler mapper - h_t = typeHandler mapper - h_l = literalHandler mapper - h_bo = binOpHandler mapper - h_uo = unOpHandler mapper - h_e = expressionHandler mapper - h_s = statementHandler mapper - h_n = nameHandler mapper - - goP :: MapperHandler Program - goP (Program decls) = Program <$> sequence (map (\d -> goD d >>= h_d) decls) - - goD :: MapperHandler Declaration - goD (DecFunction t n a b) = do - rt <- goT t - rn <- goN n - ra <- sequence $ map (\(at,an) -> (,) <$> goT at <*> goN an) a - rb <- goB b - h_d $ DecFunction rt rn ra rb - goD (DecVariable t n mv) = do - rt <- goT t - rn <- goN n - rmv <- sequence $ fmap goE mv - h_d $ DecVariable rt rn rmv - goD (DecTypedef t n) = do - rt <- goT t - rn <- goN n - h_d $ DecTypedef rt rn - - goT :: MapperHandler Type - goT (TypePtr t) = goT t >>= (h_t . TypePtr) - goT (TypeName n) = goN n >>= (h_t . TypeName) - goT t = h_t t - - goN :: MapperHandler Name - goN = h_n - - goB :: MapperHandler Block - goB (Block sts) = (Block <$> sequence (map goS sts)) >>= h_b - - goE :: MapperHandler Expression - goE (ExLit l mt) = do - rl <- goL l - h_e $ ExLit rl mt - goE (ExBinOp bo e1 e2 mt) = do - rbo <- goBO bo - re1 <- goE e1 - re2 <- goE e2 - h_e $ ExBinOp rbo re1 re2 mt - goE (ExUnOp uo e mt) = do - ruo <- goUO uo - re <- goE e - h_e $ ExUnOp ruo re mt - - goS :: MapperHandler Statement - goS StEmpty = h_s StEmpty - goS (StBlock b) = goB b >>= (h_s . StBlock) - goS (StExpr e) = goE e >>= (h_s . StExpr) - goS (StVarDeclaration t n me) = do - rt <- goT t - rn <- goN n - rme <- sequence $ fmap goE me - h_s $ StVarDeclaration rt rn rme - goS (StAssignment n e) = do - rn <- goN n - re <- goE e - h_s $ StAssignment rn re - goS (StIf e s1 s2) = do - re <- goE e - rs1 <- goS s1 - rs2 <- goS s2 - h_s $ StIf re rs1 rs2 - goS (StWhile e s) = do - re <- goE e - rs <- goS s - h_s $ StWhile re rs - goS (StReturn e) = goE e >>= (h_s . StReturn) - - goL :: MapperHandler Literal - goL l@(LitString _) = h_l l - goL l@(LitInt _) = h_l l - goL (LitVar n) = goN n >>= (h_l . LitVar) - goL (LitCall n a) = do - rn <- goN n - ra <- sequence $ map goE a - h_l $ LitCall rn ra - - goBO :: MapperHandler BinaryOperator - goBO = h_bo - - goUO :: MapperHandler UnaryOperator - goUO = h_uo + gen (DecVariable t n Nothing) = return $ A.GlobalDefinition $ + A.globalVariableDefaults { + A.G.name = A.Name n, + A.G.type' = toLLVMType t, + A.G.initializer = Just $ initializerFor t + } + gen (DecVariable _ _ (Just _)) = Left $ "Initialised global variables not supported yet" + gen _ = undefined + + +toLLVMType :: Type -> A.Type +toLLVMType (TypeInt s) = A.IntegerType $ fromIntegral s +toLLVMType (TypeUInt s) = A.IntegerType $ fromIntegral s +toLLVMType TypeFloat = A.float +toLLVMType TypeDouble = A.double +toLLVMType (TypePtr t) = A.ptr $ toLLVMType t +toLLVMType (TypeName _) = undefined + +initializerFor :: Type -> A.C.Constant +initializerFor (TypeInt s) = A.C.Int (fromIntegral s) 0 +initializerFor (TypeUInt s) = A.C.Int (fromIntegral s) 0 +initializerFor _ = undefined + + +isDecVariable :: Declaration -> Bool +isDecVariable (DecVariable {}) = True +isDecVariable _ = False @@ -5,6 +5,7 @@ import Data.Either import System.Environment import System.Exit +import Check import Codegen import Parser import PShow @@ -33,7 +34,12 @@ main = do when (isLeft parseResult) $ dieShow $ fromLeft parseResult let ast = fromRight parseResult - -- print ast putStrLn $ pshow ast - either die print $ codegen ast "Module" fname + checked <- either die return $ checkProgram ast + putStrLn "After checking:" + putStrLn $ pshow checked + + llvmMod <- either die return $ codegen checked "Module" fname + putStrLn "Module:" + print llvmMod diff --git a/simple.nl b/simple.nl new file mode 100644 index 0000000..c45e2ca --- /dev/null +++ b/simple.nl @@ -0,0 +1,9 @@ +type int = i32; +type char = i8; + +int g_var; + +int main(i32 argc, ptr(ptr(i8)) argv) { + int i = g_var; + int a = i + 2; +} |