diff options
Diffstat (limited to 'codegen.hs')
| -rw-r--r-- | codegen.hs | 78 |
1 files changed, 58 insertions, 20 deletions
@@ -8,6 +8,7 @@ import Data.Maybe import qualified Data.Map.Strict as Map import qualified LLVM.General.AST.Type as A import qualified LLVM.General.AST.Global as A.G +import qualified LLVM.General.AST.CallingConvention as A.CC import qualified LLVM.General.AST.Constant as A.C import qualified LLVM.General.AST.Float as A.F -- import qualified LLVM.General.AST.Operand as A @@ -34,6 +35,7 @@ data GenState ,definitions :: [A.Definition] ,variables :: Map.Map Name (Type, LLName) ,globalVariables :: Map.Map Name (Type, LLName) + ,globalFunctions :: Map.Map Name (Type, LLName) ,stringLiterals :: [(LLName, String)]} deriving (Show) @@ -46,6 +48,7 @@ initialGenState ,definitions = [] ,variables = Map.empty ,globalVariables = Map.empty + ,globalFunctions = Map.empty ,stringLiterals = []} newtype CGMonad a = CGMonad {unMon :: ExceptT String (State GenState) a} @@ -109,6 +112,10 @@ setGlobalVar :: Name -> LLName -> Type -> CGMonad () setGlobalVar name label t = do state $ \s -> ((), s {globalVariables = Map.insert name (t, label) $ globalVariables s}) +setGlobalFunction :: Name -> LLName -> Type -> CGMonad () +setGlobalFunction name label t = do + state $ \s -> ((), s {globalFunctions = Map.insert name (t, label) $ globalFunctions s}) + lookupVar :: Name -> CGMonad (Type, LLName) lookupVar name | trace ("Looking up var " ++ name) False = undefined lookupVar name = do @@ -122,6 +129,9 @@ lookupVar name = do lookupGlobalVar :: Name -> CGMonad (Type, LLName) lookupGlobalVar name = liftM (fromJust . Map.lookup name . globalVariables) get +lookupGlobalFunction :: Name -> CGMonad (Type, LLName) +lookupGlobalFunction name = liftM (fromJust . Map.lookup name . globalFunctions) get + addStringLiteral :: String -> CGMonad LLName addStringLiteral str = do name <- getNewName "str" @@ -167,8 +177,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 ()) + -- traceShow defs $ return () + -- liftM stringLiterals get >>= flip traceShow (return ()) return defs traceShow st $ return () @@ -185,19 +195,22 @@ generateDefs prog = liftM concat $ sequence $ [genGlobalVars prog, genFunctions prog, genStringLiterals] genGlobalVars :: Program -> CGMonad [A.Definition] -genGlobalVars (Program decs) = mapM gen $ filter isDecVariable decs +genGlobalVars (Program decs) = liftM (mapMaybe id) $ mapM gen decs where - gen :: Declaration -> CGMonad A.Definition + gen :: Declaration -> CGMonad (Maybe A.Definition) gen (DecVariable t n Nothing) = do setGlobalVar n n t - return $ A.GlobalDefinition $ + return $ Just $ A.GlobalDefinition $ A.globalVariableDefaults { A.G.name = A.Name n, A.G.type' = toLLVMType t, A.G.initializer = Just $ initializerFor t } gen (DecVariable _ _ (Just _)) = throwError $ "Initialised global variables not supported yet" - gen _ = undefined + gen (DecFunction rt n a _) = do + setGlobalFunction n n (TypeFunc rt (map fst a)) + return Nothing + gen _ = return Nothing genStringLiterals :: CGMonad [A.Definition] genStringLiterals = liftM stringLiterals get >>= return . map gen @@ -211,9 +224,9 @@ genStringLiterals = liftM stringLiterals get >>= return . map gen } genFunctions :: Program -> CGMonad [A.Definition] -genFunctions (Program decs) = mapM gen $ filter isDecFunction decs +genFunctions (Program decs) = liftM (mapMaybe id) $ mapM gen decs where - gen :: Declaration -> CGMonad A.Definition + gen :: Declaration -> CGMonad (Maybe A.Definition) gen dec@(DecFunction rettype name args body) = do setCurrentFunction dec firstbb <- genBlock' body @@ -221,13 +234,14 @@ genFunctions (Program decs) = mapM gen $ filter isDecFunction decs blockmap <- liftM allBlocks get let bbs' = map snd $ filter (\x -> fst x /= firstbb) $ Map.toList blockmap bbs = fromJust (Map.lookup firstbb blockmap) : bbs' - return $ A.GlobalDefinition $ A.functionDefaults { + state $ \s -> ((), s {allBlocks = Map.empty}) + return $ Just $ A.GlobalDefinition $ A.functionDefaults { A.G.returnType = toLLVMType rettype, A.G.name = A.Name name, A.G.parameters = ([A.Parameter (toLLVMType t) (A.Name n) [] | (t,n) <- args], False), A.G.basicBlocks = bbs } - gen _ = undefined + gen _ = return Nothing @@ -275,7 +289,11 @@ genSingle (StAssignment name expr) following = do ref <- variableStoreOperand name void $ addInstr $ A.Store False ref oper' Nothing 0 [] return bb -genSingle (StReturn expr) _ = do +genSingle (StReturn Nothing) _ = do + bb <- newBlock + setTerminator $ A.Ret Nothing [] + return bb +genSingle (StReturn (Just expr)) _ = do bb <- newBlock oper <- genExpression expr rettype <- liftM (typeOf . currentFunction) get @@ -316,6 +334,8 @@ genExpression (ExBinOp bo e1 e2 (Just t)) = do TypeDouble -> addInstr $ A.FAdd A.NoFastMathFlags e1op' e2op' [] (TypePtr _) -> addInstr $ A.Add False False e1op' e2op' [] (TypeName _) -> undefined + (TypeFunc _ _) -> throwError $ "Plus '+' operator not defined on function pointers" + TypeVoid -> undefined return $ A.LocalReference (toLLVMType t) (A.Name label) Minus -> do e1op' <- castOperand e1op t @@ -327,6 +347,8 @@ genExpression (ExBinOp bo e1 e2 (Just t)) = do TypeDouble -> addInstr $ A.FSub A.NoFastMathFlags e1op' e2op' [] (TypePtr _) -> addInstr $ A.Sub False False e1op' e2op' [] (TypeName _) -> undefined + (TypeFunc _ _) -> throwError $ "Minus '-' operator not defined on function pointers" + TypeVoid -> undefined return $ A.LocalReference (toLLVMType t) (A.Name label) Divide -> do e1op' <- castOperand e1op t @@ -338,6 +360,8 @@ genExpression (ExBinOp bo e1 e2 (Just t)) = do TypeDouble -> addInstr $ A.FDiv A.NoFastMathFlags e1op' e2op' [] (TypePtr _) -> throwError $ "Modulo '%' operator not defined on pointers" (TypeName _) -> undefined + (TypeFunc _ _) -> throwError $ "Divide '/' operator not defined on function pointers" + TypeVoid -> undefined return $ A.LocalReference (toLLVMType t) (A.Name label) Modulo -> do e1op' <- castOperand e1op t @@ -349,6 +373,8 @@ genExpression (ExBinOp bo e1 e2 (Just t)) = do TypeDouble -> addInstr $ A.FRem A.NoFastMathFlags e1op' e2op' [] (TypePtr _) -> throwError $ "Modulo '%' operator not defined on pointers" (TypeName _) -> undefined + (TypeFunc _ _) -> throwError $ "Modulo '%' operator not defined on function pointers" + TypeVoid -> undefined return $ A.LocalReference (toLLVMType t) (A.Name label) Equal -> do sharedType <- commonTypeM (fromJust (exTypeOf e1)) (fromJust (exTypeOf e2)) @@ -395,6 +421,8 @@ genExpression (ExUnOp uo e1 (Just t)) = do TypeDouble -> addInstr $ A.FSub A.NoFastMathFlags (A.ConstantOperand (A.C.Float (A.F.Double 0))) e1op [] (TypePtr _) -> throwError $ "Negate '-' operator not defined on a pointer" (TypeName _) -> undefined + (TypeFunc _ _) -> throwError $ "Negate '-' operator not defined on a function pointer" + TypeVoid -> undefined return $ A.LocalReference (toLLVMType t) (A.Name label) _ -> throwError $ "Unary operator " ++ pshow uo ++ " not implemented" genExpression ex = throwError $ "Expression '" ++ pshow ex ++ "' not implemented" @@ -416,6 +444,23 @@ literalToOperand (LitString s) (TypePtr (TypeInt 8)) = do label <- addInstr $ A.Load False loadoper Nothing 0 [] return $ A.LocalReference (A.ptr A.i8) (A.Name label) literalToOperand (LitString _) _ = undefined +literalToOperand (LitCall n args) _ = do + ((TypeFunc rt ats), lname) <- lookupGlobalFunction n + let processArgs :: [Expression] -> [Type] -> CGMonad [A.Operand] + processArgs [] [] = return [] + processArgs [] _ = undefined + processArgs _ [] = undefined + processArgs (ex:exs) (t:ts) = do + first <- genExpression ex >>= flip castOperand t + rest <- processArgs exs ts + return $ first : rest + rargs <- processArgs args ats + let argpairs = map (\a -> (a,[])) rargs + foper = A.ConstantOperand $ + A.C.GlobalReference (A.FunctionType (toLLVMType rt) (map toLLVMType ats) False) + (A.Name lname) + label <- addInstr $ A.Call Nothing A.CC.C [] (Right foper) argpairs [] [] + return $ A.LocalReference (toLLVMType rt) (A.Name label) literalToOperand lit _ = throwError $ "Literal '" ++ pshow lit ++ "' not implemented" castOperand :: A.Operand -> Type -> CGMonad A.Operand @@ -533,17 +578,10 @@ toLLVMType TypeFloat = A.float toLLVMType TypeDouble = A.double toLLVMType (TypePtr t) = A.ptr $ toLLVMType t toLLVMType (TypeName _) = undefined +toLLVMType (TypeFunc r a) = A.FunctionType (toLLVMType r) (map toLLVMType a) False +toLLVMType TypeVoid = A.VoidType initializerFor :: Type -> A.C.Constant initializerFor (TypeInt s) = A.C.Int (fromIntegral s) 0 initializerFor (TypeUInt s) = A.C.Int (fromIntegral s) 0 initializerFor _ = undefined - - -isDecVariable :: Declaration -> Bool -isDecVariable (DecVariable {}) = True -isDecVariable _ = False - -isDecFunction :: Declaration -> Bool -isDecFunction (DecFunction {}) = True -isDecFunction _ = False |