diff options
| -rw-r--r-- | codegen.hs | 44 | ||||
| -rw-r--r-- | main.hs | 39 | ||||
| -rw-r--r-- | nl/string_test.nl | 11 |
3 files changed, 71 insertions, 23 deletions
@@ -84,15 +84,28 @@ newBlockJump next = do changeBlock :: LLName -> CGMonad () changeBlock name = state $ \s -> ((), s {currentBlock = Just name}) +instrReturnsVoid :: A.Instruction -> Bool +instrReturnsVoid (A.Store {}) = True +instrReturnsVoid (A.Call _ _ _ (Right oper) _ _ _) = case oper of + (A.LocalReference (A.FunctionType A.VoidType _ _) _) -> True + (A.ConstantOperand (A.C.GlobalReference (A.FunctionType A.VoidType _ _) _)) -> True + _ -> False +instrReturnsVoid _ = False + addInstr :: A.Instruction -> CGMonad LLName -addInstr instr = do - name <- getNewName "t" - addNamedInstr $ A.Name name A.:= instr +addInstr instr + | instrReturnsVoid instr = addNamedInstr $ A.Do instr + | otherwise = do + name <- getNewName "t" + addNamedInstr $ A.Name name A.:= instr addNamedInstr :: A.Named A.Instruction -> CGMonad LLName addNamedInstr instr@(A.Name name A.:= _) = do let append (A.BasicBlock n il t) = A.BasicBlock n (il ++ [instr]) t state $ \s -> (name, s {allBlocks = Map.adjust append (fromJust (currentBlock s)) (allBlocks s)}) +addNamedInstr instr@(A.Do _) = do + let append (A.BasicBlock n il t) = A.BasicBlock n (il ++ [instr]) t + state $ \s -> ("", s {allBlocks = Map.adjust append (fromJust (currentBlock s)) (allBlocks s)}) addNamedInstr _ = undefined -- addNamedInstrList :: [A.Named A.Instruction] -> CGMonad LLName @@ -135,10 +148,11 @@ lookupGlobalVar name = liftM (fromJust . Map.lookup name . globalVariables) get lookupGlobalFunction :: Name -> CGMonad (Type, LLName) lookupGlobalFunction name = liftM (fromJust . Map.lookup name . globalFunctions) get -addStringLiteral :: String -> CGMonad LLName +addStringLiteral :: String -> CGMonad (A.Type, LLName) addStringLiteral str = do name <- getNewName "str" - state $ \s -> (name, s {stringLiterals = (name, str) : stringLiterals s}) + state $ \s -> ((A.ptr $ A.ArrayType (fromIntegral (length str + 1)) A.i8, name), + s {stringLiterals = (name, str) : stringLiterals s}) variableStoreOperand :: Name -> CGMonad A.Operand variableStoreOperand name = get >>= (maybe getGlobal getLocal . Map.lookup name . variables) @@ -241,7 +255,7 @@ genStringLiterals = liftM stringLiterals get >>= return . map gen A.G.name = A.Name name, A.G.linkage = A.L.Private, A.G.isConstant = True, - A.G.type' = A.ptr (A.i8), + A.G.type' = A.ArrayType (fromIntegral (length str + 1)) A.i8, A.G.initializer = Just $ A.C.Array A.i8 $ [A.C.Int 8 (fromIntegral (ord c)) | c <- str] ++ [A.C.Int 8 0] } @@ -256,7 +270,7 @@ genFunctions (Program decs) = liftM (mapMaybe id) $ mapM gen decs variables = Map.empty }) firstbb <- genFunctionBlock body (rettype, name) args - cleanupTrampolines + cleanupTrampolines firstbb blockmap <- liftM allBlocks get let bbs' = map snd $ filter (\x -> fst x /= firstbb) $ Map.toList blockmap bbs = fromJust (Map.lookup firstbb blockmap) : bbs' @@ -531,8 +545,12 @@ literalToOperand (LitVar n) t = do oper' <- castOperand oper t return oper' literalToOperand (LitString s) (TypePtr (TypeInt 8)) = do - name <- addStringLiteral s - return $ A.ConstantOperand $ A.C.GlobalReference (A.ptr A.i8) (A.Name name) + (ty, name) <- addStringLiteral s + label <- addInstr $ A.GetElementPtr True (A.ConstantOperand $ A.C.GlobalReference ty (A.Name name)) + [A.ConstantOperand $ A.C.Int 64 0, + A.ConstantOperand $ A.C.Int 32 0] + [] + return $ A.LocalReference (A.ptr A.i8) (A.Name label) literalToOperand (LitString _) _ = undefined literalToOperand (LitCall n args) _ = do ((TypeFunc rt ats), lname) <- lookupGlobalFunction n @@ -627,8 +645,8 @@ commonTypeM t1 t2 = maybe err return $ commonType t1 t2 where err = throwError $ "Cannot implicitly find common type of '" ++ pshow t1 ++ "' and '" ++ pshow t2 ++ "'" -cleanupTrampolines :: CGMonad () -cleanupTrampolines = do +cleanupTrampolines :: LLName -> CGMonad () +cleanupTrampolines toskip = do state $ \s -> ((), s {allBlocks = go (allBlocks s)}) where go :: Map.Map LLName A.BasicBlock -> Map.Map LLName A.BasicBlock @@ -638,8 +656,8 @@ cleanupTrampolines = do folder whole [] = whole folder whole ((name, (A.BasicBlock (A.Name name2) [] (A.Do (A.Br (A.Name dst) [])))) : _) | name /= name2 = error "INTERNAL ERROR: name /= name2" - | otherwise = let res = eliminate name dst $ Map.delete name whole - in folder res (Map.toList res) + | name /= toskip = let res = eliminate name dst $ Map.delete name whole + in folder res (Map.toList res) folder whole (_:rest) = folder whole rest eliminate :: LLName -> LLName -> Map.Map LLName A.BasicBlock -> Map.Map LLName A.BasicBlock @@ -7,7 +7,9 @@ import System.Environment import System.Exit import qualified Data.ByteString as BS import qualified LLVM.General as General +import qualified LLVM.General.Analysis as General import qualified LLVM.General.Context as General +import qualified LLVM.General.PassManager as General import qualified LLVM.General.Target as General import Check @@ -58,14 +60,31 @@ main = do General.withContext $ \context -> do putStrLn "Calling withModuleFromAST:" assert $ General.withModuleFromAST context llvmMod $ \genmod -> do - putStrLn "Calling moduleLLVMAssembly:" - llvmasm <- General.moduleLLVMAssembly genmod - putStr llvmasm - putStrLn "" - assert $ General.withHostTargetMachine $ \machine -> do - General.getTargetMachineTriple machine >>= putStrLn + putStrLn "Calling withPassManager:" + General.withPassManager (General.defaultCuratedPassSetSpec {General.optLevel = Just 1}) $ \pm -> do + putStrLn "Calling moduleLLVMAssembly:" + llvmasm1 <- General.moduleLLVMAssembly genmod + putStr llvmasm1 putStrLn "" - assert (General.moduleTargetAssembly machine genmod) - >>= putStr - bs <- assert $ General.moduleObject machine genmod - BS.writeFile "output_gen.o" bs + + putStrLn "Calling verify:" + res <- runExceptT (General.verify genmod) + either die return res + + putStrLn "Calling runPassManager:" + modified <- General.runPassManager pm genmod + if modified + then putStrLn "Pass manager modified the module" + else putStrLn "Pass manager had no effect on the module" + + putStrLn "Calling moduleLLVMAssembly:" + llvmasm <- General.moduleLLVMAssembly genmod + putStr llvmasm + putStrLn "" + assert $ General.withHostTargetMachine $ \machine -> do + General.getTargetMachineTriple machine >>= putStrLn + putStrLn "" + assert (General.moduleTargetAssembly machine genmod) + >>= putStr + bs <- assert $ General.moduleObject machine genmod + BS.writeFile "output_gen.o" bs diff --git a/nl/string_test.nl b/nl/string_test.nl new file mode 100644 index 0000000..9261a6f --- /dev/null +++ b/nl/string_test.nl @@ -0,0 +1,11 @@ +extern func void(i8) putchar; +extern func i32(ptr(i8)) puts; + +i8 g_char; + +i32 main(){ + puts("kaas"); + g_char = 111; + putchar(g_char); + return 0; +} |