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
17 import LLVM.OrcJIT.CompileLayer
19 import LLVM.PassManager
21 import LLVM.AST.AddrSpace
22 import LLVM.AST.Constant
24 import LLVM.AST.FloatingPointPredicate hiding (False, True)
25 import LLVM.AST.Operand
26 import LLVM.AST.Type as Type
32 import Control.Concurrent.MVar
34 type ModuleBuilderE = ModuleBuilderT (Either String)
36 foreign import ccall "dynamic" mkFun :: FunPtr (IO Double) -> IO Double
40 AST.Program asts <- read <$> getContents
41 let eitherMdl = buildModuleT "main" $ mapM buildAST asts
45 Right mdl' -> withContext $ \ctx ->
46 withHostTargetMachine $ \tm -> do
47 -- hPutStrLn stderr "Before optimisation:"
48 -- Text.hPutStrLn stderr (ppllvm mdl')
50 withModuleFromAST ctx mdl' $ \mdl -> do
51 let spec = defaultCuratedPassSetSpec { optLevel = Just 3 }
52 withPassManager spec $ flip runPassManager mdl
53 -- hPutStrLn stderr "After optimisation:"
54 -- Text.hPutStrLn stderr . ppllvm =<< moduleAST mdl
57 jit :: TargetMachine -> Module -> IO Double
59 loadLibraryPermanently (Just "stdlib.dylib") >>= guard . not
60 compLayerVar <- newEmptyMVar
63 withExecutionSession $ \exSession ->
64 withSymbolResolver exSession (SymbolResolver (symResolver compLayerVar)) $ \symResolverPtr ->
65 withObjectLinkingLayer exSession (const $ pure symResolverPtr) $ \linkingLayer ->
66 withModuleKey exSession $ \mdlKey ->
67 withIRCompileLayer linkingLayer tm $ \compLayer -> do
68 putMVar compLayerVar compLayer
70 withModule compLayer mdlKey mdl $ do
71 mangled <- mangleSymbol compLayer "expr"
72 Right (JITSymbol fPtr _) <- findSymbolIn compLayer mdlKey mangled False
73 mkFun (castPtrToFunPtr (wordPtrToPtr fPtr))
75 where symResolver clv sym = do
77 ms <- findSymbol cl sym False
79 Right s -> return (return s)
81 addr <- getSymbolAddressInProcess sym
82 return $ return (JITSymbol addr (JITSymbolFlags False False True True))
84 evalProg :: AST.Program -> IO (Maybe Double)
85 evalProg (AST.Program asts) = do
86 let eitherMdl = buildModuleT "main" $ mapM buildAST asts
88 Left _ -> return Nothing
89 Right mdl' -> withContext $ \ctx ->
90 withHostTargetMachine $ \tm ->
91 withModuleFromAST ctx mdl' (fmap Just . jit tm)
93 -- | Builds up programs at the top-level of an LLVM Module
94 -- >>> evalProg (read "31 - 5")
96 buildAST :: AST.AST -> ModuleBuilderE Operand
97 buildAST (AST.Function nameStr paramStrs body) = do
98 let n = fromString nameStr
99 function n params Type.double $ \binds -> do
100 let bindMap = Map.fromList (zip paramStrs binds)
101 buildExpr bindMap body >>= ret
102 where params = zip (repeat Type.double) (map fromString paramStrs)
103 buildAST (AST.Extern nameStr params) =
104 extern (fromString nameStr) (replicate (length params) Type.double) Type.double
105 buildAST (AST.Eval e) =
106 function "expr" [] Type.double $ \_ -> buildExpr mempty e >>= ret
108 -- | Builds up expressions, which are operands in LLVM IR
109 -- >>> evalProg (read "def foo(x) x * 2; foo(6)")
111 -- >>> evalProg (read "if 3 > 2 then 42 else 12")
113 buildExpr :: Map.Map String Operand -> AST.Expr -> IRBuilderT ModuleBuilderE Operand
114 buildExpr _ (AST.Num a) = pure $ ConstantOperand (Float (Double a))
115 buildExpr binds (AST.Var n) = case binds Map.!? n of
117 Nothing -> lift $ lift $ Left $ "'" <> n <> "' doesn't exist in scope"
119 buildExpr binds (AST.Call nameStr params) = do
120 paramOps <- mapM (buildExpr binds) params
121 let name = fromString nameStr
122 -- get a pointer to the function
123 typ = FunctionType Type.double (replicate (length params) Type.double) False
124 ptrTyp = Type.PointerType typ (AddrSpace 0)
125 ref = GlobalReference ptrTyp name
126 call (ConstantOperand ref) (zip paramOps (repeat []))
128 buildExpr binds (AST.BinOp op a b) = do
129 va <- buildExpr binds a
130 vb <- buildExpr binds b
131 let instr = case op of
135 AST.Cmp GT -> fcmp OGT
136 AST.Cmp LT -> fcmp OLT
137 AST.Cmp EQ -> fcmp OEQ
140 buildExpr binds (AST.If cond thenE elseE) = mdo
141 _ifB <- block `named` "if"
142 condV <- buildExpr binds cond
143 when (typeOf condV /= i1) $ lift $ lift $ Left "Not a boolean"
144 condBr condV thenB elseB
146 thenB <- block `named` "then"
147 thenOp <- buildExpr binds thenE
150 elseB <- block `named` "else"
151 elseOp <- buildExpr binds elseE
154 mergeB <- block `named` "ifcont"
155 phi [(thenOp, thenB), (elseOp, elseB)]