diff options
| -rw-r--r-- | Makefile | 8 | ||||
| -rw-r--r-- | codegen.hs | 118 | ||||
| -rw-r--r-- | main.hs | 6 | ||||
| -rw-r--r-- | simple.nl | 4 |
4 files changed, 109 insertions, 27 deletions
@@ -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 @@ -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 @@ -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 @@ -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; } |