From f9f666c7088ad2acde6dad3bd57ebf8438ba9ea1 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Tue, 24 Jan 2017 21:16:42 +0100 Subject: Can codegen a simple variable declaration --- codegen.hs | 149 ++++++++++++++++++++++++++++++++++++++++++++++++++++---- namegen/test.hs | 47 ------------------ simple.nl | 5 +- 3 files changed, 143 insertions(+), 58 deletions(-) delete mode 100644 namegen/test.hs 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; } -- cgit v1.2.3-54-g00ecf