diff options
| -rw-r--r-- | ast.hs | 4 | ||||
| -rw-r--r-- | check.hs | 13 | ||||
| -rw-r--r-- | codegen.hs | 53 | ||||
| -rw-r--r-- | parser.hs | 41 | ||||
| -rw-r--r-- | test_string.nl | 9 |
5 files changed, 93 insertions, 27 deletions
@@ -20,6 +20,8 @@ data Declaration ,valueOf :: Maybe Expression} | DecTypedef {typeOf :: Type ,nameOf :: Name} + | DecExtern {typeOf :: Type + ,nameOf :: Name} deriving (Show) data Block = Block [Statement] @@ -102,6 +104,8 @@ instance PShow Declaration where concat [pshow t, " ", n, " = ", pshow e, ";"] pshow (DecTypedef t n) = concat ["type ", n, " = ", pshow t, ";"] + pshow (DecExtern t n) = + concat ["extern ", pshow t, " ", n, ";"] instance PShow Block where pshow (Block []) = "{}" @@ -64,13 +64,16 @@ typeCheck (Program decls) = Program <$> mapM (goD topLevelNames) 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 (DecExtern (TypeFunc rt ats) _) = (rt, ats) getTypes _ = undefined isVarDecl (DecVariable {}) = True isVarDecl _ = False isFunctionDecl (DecFunction {}) = True + isFunctionDecl (DecExtern (TypeFunc {}) _) = True isFunctionDecl _ = False goD :: Map.Map Name Type -> Declaration -> Error Declaration @@ -150,7 +153,7 @@ typeCheck (Program decls) = Program <$> mapM (goD topLevelNames) decls \(a,i) -> let argtype = fromJust (exTypeOf a) in if canConvert argtype (snd ft !! i) then return a - else Left $ "Cannot convert type '" ++ pshow argtype ++ "' to '" ++ pshow (fst ft) + else Left $ "Cannot convert type '" ++ pshow argtype ++ "' to '" ++ pshow (snd ft !! i) ++ "' in call of function '" ++ pshow n ++ "'" return $ ExLit (LitCall n rargs) (Just (fst ft)) goE names (ExBinOp bo e1 e2 _) = do @@ -324,10 +327,18 @@ mapProgram prog mapper = goP prog rt <- goT t rn <- goN n h_d $ DecTypedef rt rn + goD (DecExtern t n) = do + rt <- goT t + rn <- goN n + h_d $ DecExtern rt rn goT :: MapperHandler Type goT (TypePtr t) = goT t >>= (h_t . TypePtr) goT (TypeName n) = goN n >>= (h_t . TypeName) + goT (TypeFunc t as) = do + rt <- goT t + ras <- mapM goT as + h_t $ TypeFunc rt ras goT t = h_t t goN :: MapperHandler Name @@ -210,7 +210,25 @@ genGlobalVars (Program decs) = liftM (mapMaybe id) $ mapM gen decs gen (DecFunction rt n a _) = do setGlobalFunction n n (TypeFunc rt (map fst a)) return Nothing - gen _ = return Nothing + gen (DecExtern t@(TypeFunc rt ats) n) = do + setGlobalFunction n n t + argnames <- sequence $ replicate (length ats) (getNewName "arg") + return $ Just $ A.GlobalDefinition $ + A.functionDefaults { + A.G.returnType = toLLVMType rt, + A.G.name = A.Name n, + A.G.parameters = ([A.Parameter (toLLVMType at) (A.Name an) [] | (at,an) <- zip ats argnames], False), + A.G.basicBlocks = [] + } + gen (DecExtern t n) = do + setGlobalVar n n t + return $ Just $ A.GlobalDefinition $ + A.globalVariableDefaults { + A.G.name = A.Name n, + A.G.type' = toLLVMType t, + A.G.initializer = Nothing + } + gen (DecTypedef _ _) = return Nothing genStringLiterals :: CGMonad [A.Definition] genStringLiterals = liftM stringLiterals get >>= return . map gen @@ -229,27 +247,44 @@ genFunctions (Program decs) = liftM (mapMaybe id) $ mapM gen decs gen :: Declaration -> CGMonad (Maybe A.Definition) gen dec@(DecFunction rettype name args body) = do setCurrentFunction dec - firstbb <- genBlock' body + state $ \s -> ((), s { + allBlocks = Map.empty, + variables = Map.empty + }) + firstbb <- genFunctionBlock body args cleanupTrampolines blockmap <- liftM allBlocks get let bbs' = map snd $ filter (\x -> fst x /= firstbb) $ Map.toList blockmap bbs = fromJust (Map.lookup firstbb blockmap) : bbs' - state $ \s -> ((), s {allBlocks = Map.empty}) return $ Just $ A.GlobalDefinition $ A.functionDefaults { A.G.returnType = toLLVMType rettype, A.G.name = A.Name name, - A.G.parameters = ([A.Parameter (toLLVMType t) (A.Name n) [] | (t,n) <- args], False), + A.G.parameters = ([A.Parameter (toLLVMType t) (A.Name ("farg_"++n)) [] | (t,n) <- args], False), A.G.basicBlocks = bbs } gen _ = return Nothing -genBlock' :: Block -> CGMonad LLName -genBlock' bl = do +genFunctionBlock :: Block -> [(Type,Name)] -> CGMonad LLName +genFunctionBlock bl args = do + firstbb <- newBlock + let prepArg :: (Type,Name) -> CGMonad () + prepArg (t,n) = do + label <- addInstr $ A.Alloca (toLLVMType t) Nothing 0 [] + void $ addInstr $ A.Store False (A.LocalReference (A.ptr (toLLVMType t)) (A.Name label)) + (A.LocalReference (toLLVMType t) (A.Name ("farg_"++n))) + Nothing 0 [] + setVar n label t + sequence_ $ map prepArg args + termbb <- newBlock setTerminator $ A.Unreachable [] - genBlock bl termbb + + bodybb <- genBlock bl termbb + changeBlock firstbb + setTerminator $ A.Br (A.Name bodybb) [] + return firstbb genBlock :: Block -> LLName -- name of BasicBlock following this Block @@ -378,8 +413,8 @@ 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)) - trace ("Shared type for Equal of " ++ pshow e1 ++ " and " ++ pshow e2 ++ " is: " ++ pshow sharedType) - $ return () + -- trace ("Shared type for Equal of " ++ pshow e1 ++ " and " ++ pshow e2 ++ " is: " ++ pshow sharedType) + -- $ return () e1op' <- castOperand e1op sharedType e2op' <- castOperand e2op sharedType label <- case sharedType of @@ -28,7 +28,7 @@ pProgram :: Parser Program pProgram = pWhiteComment >> (Program <$> many1 pDeclaration) pDeclaration :: Parser Declaration -pDeclaration = pDecTypedef <|> do +pDeclaration = pDecTypedef <|> pDecExtern <|> do t <- pTypeVoid <|> pType n <- pName if t == TypeVoid @@ -44,6 +44,14 @@ pDecTypedef = do symbol ";" return $ DecTypedef t n +pDecExtern :: Parser Declaration +pDecExtern = do + symbol "extern" + t <- pType + n <- pName + symbol ";" + return $ DecExtern t n + pDecFunction' :: Type -> Name -> Parser Declaration pDecFunction' t n = do symbol "(" @@ -97,7 +105,7 @@ pExLit :: Parser Expression pExLit = exLit_ <$> pLiteral pLiteral :: Parser Literal -pLiteral = (LitInt <$> pInteger) <|> (LitString <$> pString) +pLiteral = (LitInt <$> pInteger) <|> (LitInt <$> pCharStr) <|> (LitString <$> pString) <|> try pLitCall <|> (LitVar <$> pName) pLitCall :: Parser Literal @@ -224,23 +232,30 @@ pString = do s <- many (pEscape <|> satisfy (/='"')) symbol "\"" return s - where - pEscape :: Parser Char - pEscape = char '\\' >> (pEscapeQuote <|> pEscapeN <|> pEscapeR <|> pEscapeT <|> pEscapeHex) +pCharStr :: Parser Integer +pCharStr = do + void $ char '\'' + c <- pEscape <|> satisfy (/='\'') + symbol "'" + return $ fromIntegral (ord c) + +pEscape :: Parser Char +pEscape = char '\\' >> (pEscapeQuote <|> pEscapeN <|> pEscapeR <|> pEscapeT <|> pEscapeHex) + where pEscapeQuote, pEscapeN, pEscapeR, pEscapeT :: Parser Char - pEscapeQuote = '"' <$ char '"' + pEscapeQuote = ('"' <$ char '"') <|> ('\'' <$ char '\'') pEscapeN = '\n' <$ char 'n' pEscapeR = '\r' <$ char 'r' pEscapeT = '\t' <$ char 't' - pEscapeHex :: Parser Char - pEscapeHex = do - void $ char 'x' - c1 <- pHexChar - c2 <- pHexChar - return $ chr $ 16 * c1 + c2 - +pEscapeHex :: Parser Char +pEscapeHex = do + void $ char 'x' + c1 <- pHexChar + c2 <- pHexChar + return $ chr $ 16 * c1 + c2 + where pHexChar :: Parser Int pHexChar = (liftM (\c -> ord c - ord '0') (satisfy isDigit)) <|> (liftM (\c -> ord c - ord 'a' + 10) (oneOf "abcdef")) diff --git a/test_string.nl b/test_string.nl index 37841a7..ccba9a1 100644 --- a/test_string.nl +++ b/test_string.nl @@ -2,15 +2,16 @@ type int = i32; type char = i8; type string = ptr(char); -void func(string s) { - int i = 1; +extern func void(int) putchar; + +void f(char c) { + putchar(c); return; } int main(int argc, ptr(string) argv) { string s = "kaas"; ptr(i8) s2 = "kaas2"; - //func void(string) the_func = func; - func(s); + f('x'); return 0; } |