summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--codegen.hs44
-rw-r--r--main.hs39
-rw-r--r--nl/string_test.nl11
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;
+}