From 7e36aa5ccb1575ca141b865dc7b8abe39a6c0581 Mon Sep 17 00:00:00 2001
From: tomsmeding <tom.smeding@gmail.com>
Date: Tue, 31 Jan 2017 21:12:32 +0100
Subject: Handle non-returning void functions, and error on missing return

---
 codegen.hs        | 31 +++++++++++++++++++++++++++----
 nl/test_string.nl |  1 -
 2 files changed, 27 insertions(+), 5 deletions(-)

diff --git a/codegen.hs b/codegen.hs
index b9f822a..9a8bf1c 100644
--- a/codegen.hs
+++ b/codegen.hs
@@ -254,7 +254,7 @@ genFunctions (Program decs) = liftM (mapMaybe id) $ mapM gen decs
                 allBlocks = Map.empty,
                 variables = Map.empty
             })
-        firstbb <- genFunctionBlock body args
+        firstbb <- genFunctionBlock body (rettype, name) args
         cleanupTrampolines
         blockmap <- liftM allBlocks get
         let bbs' = map snd $ filter (\x -> fst x /= firstbb) $ Map.toList blockmap
@@ -269,8 +269,8 @@ genFunctions (Program decs) = liftM (mapMaybe id) $ mapM gen decs
 
 
 
-genFunctionBlock :: Block -> [(Type,Name)] -> CGMonad LLName
-genFunctionBlock bl args = do
+genFunctionBlock :: Block -> (Type, Name) -> [(Type, Name)] -> CGMonad LLName
+genFunctionBlock bl (rettype, fname) args = do
     firstbb <- newBlock
     let prepArg :: (Type,Name) -> CGMonad ()
         prepArg (t,n) = do
@@ -282,15 +282,24 @@ genFunctionBlock bl args = do
     sequence_ $ map prepArg args
 
     termbb <- newBlock
-    setTerminator $ A.Unreachable []
+    setTerminator $ if rettype == TypeVoid then A.Ret Nothing [] else A.Unreachable []
 
     bodybb <- genBlock bl termbb
     changeBlock firstbb
     setTerminator $ A.Br (A.Name bodybb) []
+
+    if rettype /= TypeVoid
+        then whenM (bbIsReferenced termbb) $ throwError $
+                 "Control reaches end of non-void function '" ++ fname ++ "'"
+        else return ()
+
     if length args > 0
         then return firstbb
         else return bodybb
 
+whenM :: (Monad m) => m Bool -> m a -> m ()
+whenM cond value = cond >>= \c -> if c then void value else return ()
+
 genBlock :: Block
          -> LLName  -- name of BasicBlock following this Block
          -> CGMonad LLName  -- name of first BasicBlock
@@ -628,6 +637,20 @@ cleanupTrampolines = do
         | otherwise = A.Name x
     changeName _ _ (A.UnName _) = undefined
 
+bbIsReferenced :: LLName -> CGMonad Bool
+bbIsReferenced bb = do
+    bbs <- liftM allBlocks get
+    return $ any checkBlock bbs
+  where
+    checkBlock :: A.BasicBlock -> Bool
+    checkBlock (A.BasicBlock name instrs (_ A.:= term)) = checkBlock (A.BasicBlock name instrs (A.Do term))
+    checkBlock (A.BasicBlock _ _ (A.Do term)) = case term of
+        (A.Ret _ _) -> False
+        (A.CondBr _ (A.Name d1) (A.Name d2) _) -> d1 == bb || d2 == bb
+        (A.Br (A.Name d) _) -> d == bb
+        (A.Unreachable _) -> False
+        _ -> undefined
+
 
 toLLVMType :: Type -> A.Type
 toLLVMType (TypeInt s) = A.IntegerType $ fromIntegral s
diff --git a/nl/test_string.nl b/nl/test_string.nl
index ccba9a1..d120b48 100644
--- a/nl/test_string.nl
+++ b/nl/test_string.nl
@@ -6,7 +6,6 @@ extern func void(int) putchar;
 
 void f(char c) {
 	putchar(c);
-	return;
 }
 
 int main(int argc, ptr(string) argv) {
-- 
cgit v1.2.3-70-g09d2