Actually run the LLVM verifier; fix all problems

3 files changed, 71 insertions, 23 deletions

diff --git a/codegen.hs b/codegen.hs
index 37c7154..4c3bca9 100644
--- a/codegen.hs
+++ b/codegen.hs
@@ -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
diff --git a/main.hs b/main.hs
index ad9627b..ca953a8 100644
--- a/main.hs
+++ b/main.hs
@@ -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;
+}