summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile8
-rw-r--r--codegen.hs118
-rw-r--r--main.hs6
-rw-r--r--simple.nl4
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;
}