summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--codegen.hs43
-rw-r--r--test_string.nl7
2 files changed, 43 insertions, 7 deletions
diff --git a/codegen.hs b/codegen.hs
index 5fd32d2..0deb959 100644
--- a/codegen.hs
+++ b/codegen.hs
@@ -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";
+}