1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RecursiveDo #-}
8 import Control.Monad.Trans.Class
9 import qualified Data.Map as Map
10 import qualified Data.Text.Lazy.IO as Text
16 import LLVM.ExecutionEngine
18 import LLVM.PassManager
20 import LLVM.AST.AddrSpace
21 import LLVM.AST.Constant
23 import LLVM.AST.FloatingPointPredicate hiding (False, True)
24 import LLVM.AST.Operand
25 import LLVM.AST.Type as Type
31 type ModuleBuilderE = ModuleBuilderT (Either String)
33 foreign import ccall "dynamic" exprFun :: FunPtr (IO Float) -> IO Float
37 AST.Program asts <- read <$> getContents
38 let eitherMdl = buildModuleT "main" $ mapM buildAST asts
41 Right mdl -> withContext $ \ctx -> do
42 hPutStrLn stderr "Before optimisation:"
43 Text.hPutStrLn stderr (ppllvm mdl)
44 withMCJIT ctx Nothing Nothing Nothing Nothing $ \mcjit ->
45 withModuleFromAST ctx mdl $ \mdl' ->
46 withPassManager defaultCuratedPassSetSpec $ \pm -> do
47 runPassManager pm mdl' >>= guard
48 hPutStrLn stderr "After optimisation:"
49 Text.hPutStrLn stderr . ppllvm =<< moduleAST mdl'
50 withModuleInEngine mcjit mdl' $ \emdl -> do
51 Just f <- getFunction emdl "expr"
52 let f' = castFunPtr f :: FunPtr (IO Float)
55 buildAST :: AST.AST -> ModuleBuilderE Operand
56 buildAST (AST.Function nameStr paramStrs body) = do
57 let n = fromString nameStr
58 function n params float $ \binds -> do
59 let bindMap = Map.fromList (zip paramStrs binds)
60 buildExpr bindMap body >>= ret
61 where params = zip (repeat float) (map fromString paramStrs)
62 buildAST (AST.Eval e) =
63 function "expr" [] float $ \_ -> buildExpr mempty e >>= ret
65 buildExpr :: Map.Map String Operand -> AST.Expr -> IRBuilderT ModuleBuilderE Operand
66 buildExpr _ (AST.Num a) = pure $ ConstantOperand (Float (Single a))
67 buildExpr binds (AST.Var n) = case binds Map.!? n of
69 Nothing -> lift $ lift $ Left $ "'" <> n <> "' doesn't exist in scope"
71 buildExpr binds (AST.Call nameStr params) = do
72 paramOps <- mapM (buildExpr binds) params
73 let name = fromString nameStr
74 -- get a pointer to the function
75 typ = FunctionType float (replicate (length params) float) False
76 ptrTyp = Type.PointerType typ (AddrSpace 0)
77 ref = GlobalReference ptrTyp name
78 call (ConstantOperand ref) (zip paramOps (repeat []))
80 buildExpr binds (AST.BinOp op a b) = do
81 va <- buildExpr binds a
82 vb <- buildExpr binds b
83 let instr = case op of
87 AST.Cmp GT -> fcmp OGT
88 AST.Cmp LT -> fcmp OLT
89 AST.Cmp EQ -> fcmp OEQ
92 buildExpr binds (AST.If cond thenE elseE) = mdo
93 _ifB <- block `named` "if"
95 condV <- buildExpr binds cond
96 when (typeOf condV /= i1) $ lift $ lift $ Left "Not a boolean"
97 condBr condV thenB elseB
99 thenB <- block `named` "then"
100 thenOp <- buildExpr binds thenE
103 elseB <- block `named` "else"
104 elseOp <- buildExpr binds elseE
107 mergeB <- block `named` "ifcont"
108 traceShowId <$> phi [(thenOp, thenB), (elseOp, elseB)]