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
30 type ModuleBuilderE = ModuleBuilderT (Either String)
32 foreign import ccall "dynamic" exprFun :: FunPtr (IO Float) -> IO Float
36 AST.Program asts <- read <$> getContents
37 let eitherMdl = buildModuleT "main" $ mapM buildAST asts
40 Right mdl -> withContext $ \ctx -> do
41 hPutStrLn stderr "Before optimisation:"
42 Text.hPutStrLn stderr (ppllvm mdl)
43 withMCJIT ctx Nothing Nothing Nothing Nothing $ \mcjit ->
44 withModuleFromAST ctx mdl $ \mdl' ->
45 withPassManager defaultCuratedPassSetSpec $ \pm -> do
46 runPassManager pm mdl' >>= guard
47 hPutStrLn stderr "After optimisation:"
48 Text.hPutStrLn stderr . ppllvm =<< moduleAST mdl'
49 withModuleInEngine mcjit mdl' $ \emdl -> do
50 Just f <- getFunction emdl "expr"
51 let f' = castFunPtr f :: FunPtr (IO Float)
54 buildAST :: AST.AST -> ModuleBuilderE Operand
55 buildAST (AST.Function nameStr paramStrs body) = do
56 let n = fromString nameStr
57 function n params float $ \binds -> do
58 let bindMap = Map.fromList (zip paramStrs binds)
59 buildExpr bindMap body >>= ret
60 where params = zip (repeat float) (map fromString paramStrs)
61 buildAST (AST.Eval e) =
62 function "expr" [] float $ \_ -> buildExpr mempty e >>= ret
64 buildExpr :: Map.Map String Operand -> AST.Expr -> IRBuilderT ModuleBuilderE Operand
65 buildExpr _ (AST.Num a) = pure $ ConstantOperand (Float (Single a))
66 buildExpr binds (AST.Var n) = case binds Map.!? n of
68 Nothing -> lift $ lift $ Left $ "'" <> n <> "' doesn't exist in scope"
70 buildExpr binds (AST.Call nameStr params) = do
71 paramOps <- mapM (buildExpr binds) params
72 let name = fromString nameStr
73 -- get a pointer to the function
74 typ = FunctionType float (replicate (length params) float) False
75 ptrTyp = Type.PointerType typ (AddrSpace 0)
76 ref = GlobalReference ptrTyp name
77 call (ConstantOperand ref) (zip paramOps (repeat []))
79 buildExpr binds (AST.BinOp op a b) = do
80 va <- buildExpr binds a
81 vb <- buildExpr binds b
82 let instr = case op of
86 AST.Cmp GT -> fcmp OGT
87 AST.Cmp LT -> fcmp OLT
88 AST.Cmp EQ -> fcmp OEQ
91 buildExpr binds (AST.If cond thenE elseE) = mdo
92 _ifB <- block `named` "if"
93 condV <- buildExpr binds cond
94 condBr condV thenB elseB
96 thenB <- block `named` "then"
97 thenOp <- buildExpr binds thenE
100 elseB <- block `named` "else"
101 elseOp <- buildExpr binds elseE
104 mergeB <- block `named` "ifcont"
105 traceShowId <$> phi [(thenOp, thenB), (elseOp, elseB)]