1 {-# LANGUAGE OverloadedStrings #-}
3 import AST as K -- K for Kaleidoscope
5 import Control.Monad.Trans.Class
6 import Control.Monad.Trans.Reader
7 import Control.Monad.IO.Class
9 import qualified Data.Map as Map
10 import qualified Data.Text.Lazy.IO as Text
11 import LLVM.AST.AddrSpace
12 import LLVM.AST.Constant
14 import LLVM.AST.FloatingPointPredicate hiding (False, True)
15 import LLVM.AST.Operand
16 import LLVM.AST.Type as Type
20 import LLVM.PassManager
24 import System.IO.Error
25 import Text.Read (readMaybe)
29 withContext $ \ctx -> withHostTargetMachine $ \tm -> do
30 ast <- runReaderT (buildModuleT "main" repl) ctx
33 repl :: ModuleBuilderT (ReaderT Context IO) ()
35 liftIO $ hPutStr stderr "ready> "
36 mline <- liftIO $ catchIOError (Just <$> getLine) eofHandler
41 Nothing -> liftIO $ hPutStrLn stderr "Couldn't parse"
44 mostRecentDef >>= liftIO . Text.hPutStrLn stderr . ppll
46 ast <- moduleSoFar "main"
48 liftIO $ withModuleFromAST ctx ast $ \mdl -> do
49 let spec = defaultCuratedPassSetSpec { optLevel = Just 3 }
50 -- this returns true if the module was modified
51 withPassManager spec $ flip runPassManager mdl
52 Text.hPutStrLn stderr . ("\n" <>) . ppllvm =<< moduleAST mdl
56 | isEOFError e = return Nothing
57 | otherwise = ioError e
59 type Binds = Map.Map String Operand
61 buildAST :: AST -> ModuleBuilder Operand
62 buildAST (Function (Prototype nameStr paramStrs) body) = do
63 let n = fromString nameStr
64 function n params Type.double $ \ops -> do
65 let binds = Map.fromList (zip paramStrs ops)
66 flip runReaderT binds $ buildExpr body >>= ret
67 where params = zip (repeat Type.double) (map fromString paramStrs)
69 buildAST (Extern (Prototype nameStr params)) =
70 extern (fromString nameStr) (replicate (length params) Type.double) Type.double
72 buildAST (TopLevelExpr x) = function "__anon_expr" [] Type.double $
73 const $ flip runReaderT mempty $ buildExpr x >>= ret
75 buildExpr :: Expr -> ReaderT Binds (IRBuilderT ModuleBuilder) Operand
76 buildExpr (Num x) = pure $ ConstantOperand (Float (Double x))
77 buildExpr (Var n) = do
79 case binds Map.!? n of
81 Nothing -> error $ "'" <> n <> "' doesn't exist in scope"
83 buildExpr (BinOp op a b) = do
88 then uitofp tmp Type.double
101 buildExpr (Call callee params) = do
102 paramOps <- mapM buildExpr params
103 let nam = fromString callee
104 -- get a pointer to the function
105 typ = FunctionType Type.double (replicate (length params) Type.double) False
106 ptrTyp = Type.PointerType typ (AddrSpace 0)
107 ref = GlobalReference ptrTyp nam
108 call (ConstantOperand ref) (zip paramOps (repeat []))