From 9579a6f7e4693262341271afee01a70f23e95824 Mon Sep 17 00:00:00 2001
From: tomsmeding <tom.smeding@gmail.com>
Date: Sat, 28 Jan 2017 23:31:55 +0100
Subject: Compile string literals

---
 codegen.hs     | 43 ++++++++++++++++++++++++++++++++++++-------
 test_string.nl |  7 +++++++
 2 files changed, 43 insertions(+), 7 deletions(-)
 create mode 100644 test_string.nl

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";
+}
-- 
cgit v1.2.3-54-g00ecf