Compile simple expressions

4 files changed, 109 insertions, 27 deletions

diff --git a/Makefile b/Makefile
index 499a974..cb0067e 100644
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,11 @@
 GHC = ghc
-GHCFLAGS = -Wall -Wno-type-defaults -O3
+GHCFLAGS = -Wall -Wno-type-defaults
+ifneq ($(DEBUG),)
+	GHCFLAGS += -prof -fprof-auto -fprof-cafs
+endif
+ifneq ($(OPT),)
+	GHCFLAGS += -O3
+endif
 
 TARGET = main
 
diff --git a/codegen.hs b/codegen.hs
index bf47a62..95068be 100644
--- a/codegen.hs
+++ b/codegen.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TupleSections #-}
 module Codegen(codegen) where
 
 import Control.Monad.State.Strict
@@ -15,6 +15,7 @@ import qualified LLVM.General.AST as A
 import Debug.Trace
 
 import AST
+import PShow
 
 
 type Error a = Either String a
@@ -27,7 +28,8 @@ data GenState
                ,allBlocks :: Map.Map LLName A.BasicBlock
                ,nextId :: Integer
                ,definitions :: [A.Definition]
-               ,variables :: Map.Map LLName LLName}
+               ,variables :: Map.Map Name LLName
+               ,variableTypes :: Map.Map Name Type}
     deriving (Show)
 
 initialGenState :: GenState
@@ -36,7 +38,8 @@ initialGenState
                ,allBlocks = Map.empty
                ,nextId = 1
                ,definitions = []
-               ,variables = Map.empty}
+               ,variables = Map.empty
+               ,variableTypes = Map.empty}
 
 newtype CGMonad a = CGMonad {unMon :: ExceptT String (State GenState) a}
     deriving (Functor, Applicative, Monad, MonadState GenState, MonadError String)
@@ -79,25 +82,31 @@ addNamedInstr instr@(A.Name name A.:= _) = do
     state $ \s -> (name, s {allBlocks = Map.adjust append (fromJust (currentBlock s)) (allBlocks s)})
 addNamedInstr _ = undefined
 
-addNamedInstrList :: [A.Named A.Instruction] -> CGMonad LLName
-addNamedInstrList l = mapM addNamedInstr l >>= return . last
+-- addNamedInstrList :: [A.Named A.Instruction] -> CGMonad LLName
+-- addNamedInstrList l = mapM addNamedInstr l >>= return . last
 
 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})
+setVar :: Name -> LLName -> Type -> CGMonad ()
+setVar name label t = do
+    state $ \s -> ((), s {
+            variables = Map.insert name label $ variables s,
+            variableTypes = Map.insert name t $ variableTypes s
+        })
 
-lookupVar :: LLName -> CGMonad LLName
+lookupVar :: Name -> CGMonad LLName
 lookupVar name = liftM (fromJust . Map.lookup name . variables) get
 
+lookupVarType :: Name -> CGMonad Type
+lookupVarType name = liftM (fromJust . Map.lookup name . variableTypes) get
+
 
-namedName :: A.Named a -> LLName
-namedName (A.Name name A.:= _) = name
-namedName _ = undefined
+-- namedName :: A.Named a -> LLName
+-- namedName (A.Name name A.:= _) = name
+-- namedName _ = undefined
 
 
 codegen :: Program  -- Program to compile
@@ -170,8 +179,11 @@ genBlock (Block [stmt]) following = do
     firstbb <- genSingle stmt following
     return firstbb
 genBlock (Block (stmt:rest)) following = do
+    interbb <- newBlock
+    firstbb <- genSingle stmt interbb
     restbb <- genBlock (Block rest) following
-    firstbb <- genSingle stmt restbb
+    changeBlock interbb
+    setTerminator $ A.Br (A.Name restbb) []
     return firstbb
 
 genSingle :: Statement
@@ -181,23 +193,87 @@ genSingle StEmpty following = newBlockJump following
 genSingle (StBlock block) following = genBlock block following
 genSingle (StExpr expr) following = do
     bb <- newBlockJump following
-    void $ genExpression expr >>= addNamedInstrList
+    void $ genExpression expr
     return bb
 genSingle (StVarDeclaration t n Nothing) following = do
     bb <- newBlockJump following
     label <- addInstr $ A.Alloca (toLLVMType t) Nothing 0 []
-    setVarLabel n label
+    setVar n label t
     return bb
 genSingle (StVarDeclaration _ _ (Just _)) _ = undefined
+genSingle (StAssignment name expr) following = do
+    bb <- newBlockJump following
+    label <- genExpression expr
+    let oper = A.LocalReference (toLLVMType (fromJust (exTypeOf expr))) (A.Name label)
+    dstlabel <- lookupVar name
+    dsttype <- lookupVarType name
+    oper' <- castOperand oper dsttype
+    void $ addInstr $ A.Store False (A.LocalReference (toLLVMType dsttype) (A.Name dstlabel))
+                                    oper' Nothing 0 []
+    return bb
+genSingle _ _ = undefined
 
-genExpression :: Expression -> CGMonad [A.Named A.Instruction]
+genExpression :: Expression -> CGMonad LLName
 genExpression (ExLit (LitInt i) (Just t@(TypeInt sz))) = do
     aname <- getNewName "t"
-    rname <- getNewName "t"
-    return [A.Name aname A.:= A.Alloca (toLLVMType t) Nothing 0 []
-           ,A.Name rname A.:= A.Store False (A.LocalReference (toLLVMType t) (A.Name aname))
-                                      (A.ConstantOperand (A.C.Int (fromIntegral sz) i)) Nothing 0 []]
-
+    void $ addNamedInstr $ A.Name aname A.:= A.Alloca (toLLVMType t) Nothing 0 []
+    void $ addInstr $ A.Store False (A.LocalReference (toLLVMType t) (A.Name aname))
+                              (A.ConstantOperand (A.C.Int (fromIntegral sz) i)) Nothing 0 []
+    return aname
+genExpression (ExBinOp bo e1 e2 (Just t)) = do
+    e1op <- genExprArgument e1
+    e2op <- genExprArgument e2
+    case bo of
+        Plus -> do
+            e1op' <- castOperand e1op t
+            e2op' <- castOperand e2op t
+            case t of
+                (TypeInt _) -> addInstr $ A.Add False False e1op' e2op' []
+                (TypeUInt _) -> addInstr $ A.Add False False e1op' e2op' []
+                TypeFloat -> addInstr $ A.FAdd A.NoFastMathFlags e1op' e2op' []
+                TypeDouble -> addInstr $ A.FAdd A.NoFastMathFlags e1op' e2op' []
+                (TypePtr _) -> addInstr $ A.Add False False e1op' e2op' []
+                (TypeName _) -> undefined
+        Minus -> do
+            e1op' <- castOperand e1op t
+            e2op' <- castOperand e2op t
+            case t of
+                (TypeInt _) -> addInstr $ A.Sub False False e1op' e2op' []
+                (TypeUInt _) -> addInstr $ A.Sub False False e1op' e2op' []
+                TypeFloat -> addInstr $ A.FSub A.NoFastMathFlags e1op' e2op' []
+                TypeDouble -> addInstr $ A.FSub A.NoFastMathFlags e1op' e2op' []
+                (TypePtr _) -> addInstr $ A.Sub False False e1op' e2op' []
+                (TypeName _) -> undefined
+        _ -> undefined
+genExpression _ = undefined
+
+genExprArgument :: Expression -> CGMonad A.Operand
+genExprArgument expr = case expr of
+        (ExLit lit (Just t)) -> literalToOperand lit t
+        _ -> do
+                name <- genExpression expr
+                return $ A.LocalReference (toLLVMType (fromJust (exTypeOf expr))) (A.Name name)
+
+literalToOperand :: Literal -> Type -> CGMonad A.Operand
+literalToOperand (LitInt i) (TypeInt sz) = return $ A.ConstantOperand (A.C.Int (fromIntegral sz) i)
+literalToOperand (LitVar n) t = do
+    label <- lookupVar n
+    return $ A.LocalReference (toLLVMType t) (A.Name label)
+literalToOperand _ _ = undefined
+
+castOperand :: A.Operand -> Type -> CGMonad A.Operand
+castOperand orig@(A.LocalReference (A.IntegerType s1) _) t2@(TypeInt s2)
+    | fromIntegral s1 == s2 = return orig
+    | fromIntegral s1 < s2 = do
+        label <- addInstr $ A.SExt orig (toLLVMType t2) []
+        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.ConstantOperand (A.C.Int s1 val)) t2@(TypeInt s2)
+    | fromIntegral s1 == s2 = return orig
+    | fromIntegral s1 < s2 = return $ A.ConstantOperand (A.C.Int (fromIntegral s2) val)
+    | fromIntegral s1 > s2 = throwError $ "Integer " ++ show val ++ " too large for tyoe '" ++ pshow t2 ++ "'"
+castOperand _ _ = undefined
 
 
 toLLVMType :: Type -> A.Type
diff --git a/main.hs b/main.hs
index b4a66d0..ec5b050 100644
--- a/main.hs
+++ b/main.hs
@@ -7,7 +7,7 @@ import System.Environment
 import System.Exit
 import qualified LLVM.General as General
 import qualified LLVM.General.Context as General
-import qualified LLVM.General.Target as General
+-- import qualified LLVM.General.Target as General
 
 import Check
 import Codegen
@@ -50,8 +50,8 @@ main = do
     putStrLn $ pshow checked
 
     llvmMod <- either die return $ codegen checked "Module" fname
-    putStrLn "Module:"
-    print llvmMod
+    -- putStrLn "Module:"
+    -- print llvmMod
 
     General.withContext $ \context -> do
         assert $ General.withModuleFromAST context llvmMod $ \genmod -> do
diff --git a/simple.nl b/simple.nl
index fd6c5c7..ff3ddff 100644
--- a/simple.nl
+++ b/simple.nl
@@ -5,7 +5,7 @@ int g_var;
 
 int main(i32 argc, ptr(ptr(i8)) argv) {
 	//int i = g_var;
-	//int a = i + 2;
 	int i;
-	1;
+	i = 1 + 2 + 3;
+	int a = i + 2;
 }