Can codegen a simple variable declaration

3 files changed, 143 insertions, 58 deletions

diff --git a/codegen.hs b/codegen.hs
index 1a7a907..6a51dff 100644
--- a/codegen.hs
+++ b/codegen.hs
@@ -1,8 +1,10 @@
+{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-}
 module Codegen(codegen) where
 
--- import Control.Monad
--- import Data.Maybe
--- import qualified Data.Map.Strict as Map
+import Control.Monad.State.Strict
+import Control.Monad.Except
+import Data.Maybe
+import qualified Data.Map.Strict as Map
 import qualified LLVM.General.AST.Type as A
 import qualified LLVM.General.AST.Global as A.G
 import qualified LLVM.General.AST.Constant as A.C
@@ -10,20 +12,92 @@ import qualified LLVM.General.AST.Constant as A.C
 -- import qualified LLVM.General.AST.Name as A
 -- import qualified LLVM.General.AST.Instruction as A
 import qualified LLVM.General.AST as A
--- import Debug.Trace
+import Debug.Trace
 
 import AST
 
 
 type Error a = Either String a
 
+type LLName = String
+
+
+data GenState
+    = GenState {currentBlock :: Maybe LLName
+               ,allBlocks :: Map.Map LLName A.BasicBlock
+               ,nextId :: Integer
+               ,definitions :: [A.Definition]
+               ,variables :: Map.Map LLName LLName}
+    deriving (Show)
+
+initialGenState :: GenState
+initialGenState
+    = GenState {currentBlock = Nothing
+               ,allBlocks = Map.empty
+               ,nextId = 1
+               ,definitions = []
+               ,variables = Map.empty}
+
+newtype CGMonad a = CGMonad {unMon :: ExceptT String (State GenState) a}
+    deriving (Functor, Applicative, Monad, MonadState GenState, MonadError String)
+
+runCGMonad :: CGMonad a -> Error (a, GenState)
+runCGMonad m = let (e, s) = runState (runExceptT (unMon m)) initialGenState
+               in either Left (\x -> Right (x, s)) e
+
+getUniqueId :: CGMonad Integer
+getUniqueId = state $ \s -> (nextId s, s {nextId = nextId s + 1})
+
+getNewName :: String -> CGMonad String
+getNewName base = fmap ((base++) . show) getUniqueId
+
+newBlock :: CGMonad LLName
+newBlock = do
+    name <- getNewName "bb"
+    state $ \s -> (name, s {
+            currentBlock = Just name,
+            allBlocks = Map.insert name (A.BasicBlock (A.Name name) [] undefined) $ allBlocks s
+        })
+
+newBlockJump :: LLName -> CGMonad LLName
+newBlockJump next = do
+    bb <- newBlock
+    setTerminator $ A.Br (A.Name next) []
+    return bb
+
+changeBlock :: LLName -> CGMonad ()
+changeBlock name = state $ \s -> ((), s {currentBlock = Just name})
+
+addInstr :: A.Instruction -> CGMonad LLName
+addInstr instr = do
+    name <- getNewName "t"
+    let append (A.BasicBlock n il t) = A.BasicBlock n (il ++ [A.Name name A.:= instr]) t
+    state $ \s -> (name, s {allBlocks = Map.adjust append (fromJust (currentBlock s)) (allBlocks s)})
+
+setTerminator :: A.Terminator -> CGMonad ()
+setTerminator term = do
+    let replace (A.BasicBlock n il _) = A.BasicBlock n il (A.Do term)
+    state $ \s -> ((), s {allBlocks = Map.adjust replace (fromJust (currentBlock s)) (allBlocks s)})
+
+setVarLabel :: LLName -> LLName -> CGMonad ()
+setVarLabel name label = do
+    state $ \s -> ((), s {variables = Map.insert name label $ variables s})
+
+lookupVar :: LLName -> CGMonad LLName
+lookupVar name = liftM (fromJust . Map.lookup name . variables) get
+
 
 codegen :: Program  -- Program to compile
         -> String   -- Module name
         -> String   -- File name of source
         -> Error A.Module
 codegen prog name fname = do
-    defs <- generateDefs prog
+    (defs, st) <- runCGMonad $ do
+                    defs <- generateDefs prog
+                    return defs
+
+    traceShow st $ return ()
+
     return $ A.defaultModule {
             A.moduleName = name,
             A.moduleSourceFileName = fname,
@@ -31,24 +105,77 @@ codegen prog name fname = do
         }
 
 
-generateDefs :: Program -> Error [A.Definition]
+generateDefs :: Program -> CGMonad [A.Definition]
 generateDefs prog = do
     vardecls <- genGlobalVars prog
-    return vardecls
+    fundecls <- genFunctions prog
+    return $ vardecls ++ fundecls
 
-genGlobalVars :: Program -> Error [A.Definition]
+genGlobalVars :: Program -> CGMonad [A.Definition]
 genGlobalVars (Program decs) = mapM gen $ filter isDecVariable decs
   where
+    gen :: Declaration -> CGMonad A.Definition
     gen (DecVariable t n Nothing) = return $ A.GlobalDefinition $
             A.globalVariableDefaults {
                 A.G.name = A.Name n,
                 A.G.type' = toLLVMType t,
                 A.G.initializer = Just $ initializerFor t
             }
-    gen (DecVariable _ _ (Just _)) = Left $ "Initialised global variables not supported yet"
+    gen (DecVariable _ _ (Just _)) = throwError $ "Initialised global variables not supported yet"
+    gen _ = undefined
+
+genFunctions :: Program -> CGMonad [A.Definition]
+genFunctions (Program decs) = mapM gen $ filter isDecFunction decs
+  where
+    gen :: Declaration -> CGMonad A.Definition
+    gen (DecFunction rettype name args body) = do
+        firstbb <- genBlock' body
+        blockmap <- liftM allBlocks get
+        let bbs' = map snd $ filter (\x -> fst x /= firstbb) $ Map.toList blockmap
+            bbs = fromJust (Map.lookup firstbb blockmap) : bbs'
+        return $ 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.basicBlocks = bbs
+            }
     gen _ = undefined
 
 
+
+genBlock' :: Block -> CGMonad LLName
+genBlock' bl = do
+    termbb <- newBlock
+    setTerminator $ A.Unreachable []
+    genBlock bl termbb
+
+genBlock :: Block
+         -> LLName  -- name of BasicBlock following this Block
+         -> CGMonad LLName  -- name of first BasicBlock
+genBlock (Block []) following = genBlock (Block [StEmpty]) following
+genBlock (Block [stmt]) following = do
+    firstbb <- genSingle stmt following
+    return firstbb
+genBlock (Block (stmt:rest)) following = do
+    restbb <- genBlock (Block rest) following
+    firstbb <- genSingle stmt restbb
+    return firstbb
+
+genSingle :: Statement
+          -> LLName  -- name of BasicBlock following this statement
+          -> CGMonad LLName  -- name of first BasicBlock
+genSingle StEmpty following = newBlockJump following
+genSingle (StBlock block) following = genBlock block following
+genSingle (StExpr expr) following = undefined
+genSingle (StVarDeclaration t n Nothing) following = do
+    bb <- newBlockJump following
+    label <- addInstr $ A.Alloca (toLLVMType t) Nothing 0 []
+    setVarLabel n label
+    return bb
+genSingle (StVarDeclaration _ _ (Just _)) _ = undefined
+
+
+
 toLLVMType :: Type -> A.Type
 toLLVMType (TypeInt s) = A.IntegerType $ fromIntegral s
 toLLVMType (TypeUInt s) = A.IntegerType $ fromIntegral s
@@ -66,3 +193,7 @@ initializerFor _ = undefined
 isDecVariable :: Declaration -> Bool
 isDecVariable (DecVariable {}) = True
 isDecVariable _ = False
+
+isDecFunction :: Declaration -> Bool
+isDecFunction (DecFunction {}) = True
+isDecFunction _ = False
diff --git a/namegen/test.hs b/namegen/test.hs
deleted file mode 100644
index caa7111..0000000
--- a/namegen/test.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-type Index = Integer
-
-data Namegen a = Namegen (Index -> (a, Index))
-
-runNameGen :: Index -> Namegen a -> a
-runNameGen i (Namegen f) = fst (f i)
-
-supply :: Namegen Integer
-supply = Namegen $ \i -> (i, i + 1)
-
-makeName :: String -> Namegen String
-makeName base = supply >>= \i -> return $ base ++ show i
-
-makeTempName :: Namegen String
-makeTempName = makeName "t"
-
-instance Functor Namegen where
-    fmap f (Namegen g) = Namegen $ \i -> let (x, i2) = g i in (f x, i2)
-
-instance Applicative Namegen where
-    pure x = Namegen $ \i -> (x, i)
-
-    (Namegen fg) <*> (Namegen xg) =
-        Namegen $ \i -> let (f, i2) = fg i
-                            (x, i3) = xg i2
-                        in (f x, i3)
-
-instance Monad Namegen where
-    (Namegen xg) >>= f =
-        Namegen $ \i -> let (x, i2) = xg i
-                            (Namegen resg) = f x
-                        in resg i2
-
-
-funString :: Int -> Namegen String
-funString i = do
-    n1 <- makeTempName
-    n2 <- makeTempName
-    return $ "Fun String " ++ show i ++ ", made with '" ++ n1 ++ "' and '" ++ n2 ++ "'"
-
-main :: IO ()
-main = do
-    putStrLn $ runNameGen 1 $ do
-        n1 <- makeName "xyz"
-        s <- funString 42
-        n2 <- makeName "abc"
-        return $ s ++ "\nGenerated names " ++ n1 ++ " and " ++ n2
diff --git a/simple.nl b/simple.nl
index c45e2ca..a09feb6 100644
--- a/simple.nl
+++ b/simple.nl
@@ -4,6 +4,7 @@ type char = i8;
 int g_var;
 
 int main(i32 argc, ptr(ptr(i8)) argv) {
-	int i = g_var;
-	int a = i + 2;
+	//int i = g_var;
+	//int a = i + 2;
+	int i;
 }