diff options
| -rw-r--r-- | codegen.hs | 43 | ||||
| -rw-r--r-- | test_string.nl | 7 |
2 files changed, 43 insertions, 7 deletions
@@ -3,6 +3,7 @@ module Codegen(codegen) where import Control.Monad.State.Strict import Control.Monad.Except +import Data.Char import Data.Maybe import qualified Data.Map.Strict as Map import qualified LLVM.General.AST.Type as A @@ -32,7 +33,8 @@ data GenState ,nextId :: Integer ,definitions :: [A.Definition] ,variables :: Map.Map Name (Type, LLName) - ,globalVariables :: Map.Map Name (Type, LLName)} + ,globalVariables :: Map.Map Name (Type, LLName) + ,stringLiterals :: [(LLName, String)]} deriving (Show) initialGenState :: GenState @@ -43,7 +45,8 @@ initialGenState ,nextId = 1 ,definitions = [] ,variables = Map.empty - ,globalVariables = Map.empty} + ,globalVariables = Map.empty + ,stringLiterals = []} newtype CGMonad a = CGMonad {unMon :: ExceptT String (State GenState) a} deriving (Functor, Applicative, Monad, MonadState GenState, MonadError String) @@ -119,6 +122,11 @@ lookupVar name = do lookupGlobalVar :: Name -> CGMonad (Type, LLName) lookupGlobalVar name = liftM (fromJust . Map.lookup name . globalVariables) get +addStringLiteral :: String -> CGMonad LLName +addStringLiteral str = do + name <- getNewName "str" + state $ \s -> (name, s {stringLiterals = (name, str) : stringLiterals s}) + variableStoreOperand :: Name -> CGMonad A.Operand variableStoreOperand name = get >>= (maybe getGlobal getLocal . Map.lookup name . variables) where @@ -159,6 +167,8 @@ codegen :: Program -- Program to compile codegen prog name fname = do (defs, st) <- runCGMonad $ do defs <- generateDefs prog + traceShow defs $ return () + liftM stringLiterals get >>= flip traceShow (return ()) return defs traceShow st $ return () @@ -171,10 +181,8 @@ codegen prog name fname = do generateDefs :: Program -> CGMonad [A.Definition] -generateDefs prog = do - vardecls <- genGlobalVars prog - fundecls <- genFunctions prog - return $ vardecls ++ fundecls +generateDefs prog + = liftM concat $ sequence $ [genGlobalVars prog, genFunctions prog, genStringLiterals] genGlobalVars :: Program -> CGMonad [A.Definition] genGlobalVars (Program decs) = mapM gen $ filter isDecVariable decs @@ -191,6 +199,17 @@ genGlobalVars (Program decs) = mapM gen $ filter isDecVariable decs gen (DecVariable _ _ (Just _)) = throwError $ "Initialised global variables not supported yet" gen _ = undefined +genStringLiterals :: CGMonad [A.Definition] +genStringLiterals = liftM stringLiterals get >>= return . map gen + where + gen :: (LLName, String) -> A.Definition + gen (name, str) = A.GlobalDefinition $ A.globalVariableDefaults { + A.G.name = A.Name name, + A.G.isConstant = True, + A.G.type' = A.ptr (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] + } + genFunctions :: Program -> CGMonad [A.Definition] genFunctions (Program decs) = mapM gen $ filter isDecFunction decs where @@ -236,7 +255,7 @@ genBlock (Block (stmt:rest)) following = do genSingle :: Statement -> LLName -- name of BasicBlock following this statement -> CGMonad LLName -- name of first BasicBlock -genSingle StEmpty following = newBlockJump following +genSingle StEmpty following = return following genSingle (StBlock block) following = genBlock block following genSingle (StExpr expr) following = do bb <- newBlockJump following @@ -391,6 +410,12 @@ literalToOperand (LitVar n) t = do oper <- variableOperand n oper' <- castOperand oper t return oper' +literalToOperand (LitString s) (TypePtr (TypeInt 8)) = do + name <- addStringLiteral s + let loadoper = A.ConstantOperand $ A.C.GlobalReference (A.ptr A.i8) (A.Name name) + label <- addInstr $ A.Load False loadoper Nothing 0 [] + return $ A.LocalReference (A.ptr A.i8) (A.Name label) +literalToOperand (LitString _) _ = undefined literalToOperand lit _ = throwError $ "Literal '" ++ pshow lit ++ "' not implemented" castOperand :: A.Operand -> Type -> CGMonad A.Operand @@ -415,6 +440,10 @@ castOperand orig@(A.ConstantOperand (A.C.GlobalReference (A.IntegerType s1) _)) return $ A.LocalReference (toLLVMType t2) (A.Name label) | fromIntegral s1 > s2 = throwError $ "Cannot implicitly cast '" ++ pshow (TypeInt (fromIntegral s1)) ++ "' to '" ++ pshow t2 ++ "'" +castOperand orig@(A.LocalReference (A.PointerType t1 _) _) (TypePtr t2) + | toLLVMType t2 == t1 = return orig + | otherwise = throwError $ "Cannot implicitly cast between pointer to '" ++ show t1 + ++ "' and '" ++ pshow t2 ++ "'" castOperand orig t2 = throwError $ "Cast from '" ++ show orig ++ "' to type '" ++ pshow t2 ++ "' not implemented" castToBool :: A.Operand -> CGMonad A.Operand diff --git a/test_string.nl b/test_string.nl new file mode 100644 index 0000000..ec8cd02 --- /dev/null +++ b/test_string.nl @@ -0,0 +1,7 @@ +type int = i32; +type char = i8; +type string = ptr(char); + +int main(int argc, ptr(string) argv) { + string s = "kaas"; +} |