diff options
Diffstat (limited to 'codegen.hs')
| -rw-r--r-- | codegen.hs | 149 |
1 files changed, 140 insertions, 9 deletions
@@ -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 |