From 749e5a29af22fc74b8c597485de9be6485ccc62f Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 18 Mar 2019 15:50:30 +0000 Subject: [PATCH] Add externs and change type to double --- AST.hs | 27 +++++++++++++++------------ Main.hs | 29 ++++++++++++++++------------- 2 files changed, 31 insertions(+), 25 deletions(-) diff --git a/AST.hs b/AST.hs index 6b9928d..99b6d42 100644 --- a/AST.hs +++ b/AST.hs @@ -18,9 +18,10 @@ instance Read Program where return asts data AST = Function String [String] Expr + | Extern String [String] | Eval Expr deriving Show -data Expr = Num Float +data Expr = Num Double | BinOp BinOpType Expr Expr | Var String | Call String [Expr] @@ -30,17 +31,20 @@ data BinOpType = Add | Sub | Mul | Cmp Ordering deriving Show instance Read AST where - readPrec = parseFunction +++ (Eval <$> readPrec) - where parseFunction = lift $ do - skipSpaces - string "def" - skipSpaces + readPrec = parseFunction +++ parseExtern +++ (Eval <$> readPrec) + where parseFunction = do + lift $ string "def" >> skipSpaces + (name, params) <- parsePrototype + lift skipSpaces + Function name params <$> readPrec + parseExtern = do + lift $ string "extern" >> skipSpaces + uncurry Extern <$> parsePrototype + parsePrototype = lift $ do name <- munch1 isAlpha params <- between (char '(') (char ')') $ sepBy (munch1 isAlpha) skipSpaces - skipSpaces - body <- readS_to_P reads - return (Function name params body) + return (name, params) instance Read Expr where readPrec = choice [ parseParens @@ -66,13 +70,12 @@ instance Read Expr where (skipSpaces >> char ',' >> skipSpaces) return (Call func params) parseBinOp s typ = step $ do - a <- prec 11 readPrec + a <- prec 11 readPrec -- set recursion limit of 11 lift $ do skipSpaces string s skipSpaces - b <- readPrec - return (BinOp typ a b) + BinOp typ a <$> readPrec parseIf = do lift $ do string "if" diff --git a/Main.hs b/Main.hs index eba1ce1..4d82758 100644 --- a/Main.hs +++ b/Main.hs @@ -28,7 +28,7 @@ import LLVM.Pretty type ModuleBuilderE = ModuleBuilderT (Either String) -foreign import ccall "dynamic" exprFun :: FunPtr (IO Float) -> IO Float +foreign import ccall "dynamic" exprFun :: FunPtr (IO Double) -> IO Double main :: IO () main = do @@ -40,17 +40,17 @@ main = do hPutStrLn stderr "Before optimisation:" Text.hPutStrLn stderr (ppllvm mdl) withMCJIT ctx Nothing Nothing Nothing Nothing $ \mcjit -> - withModuleFromAST ctx mdl $ \mdl' -> - withPassManager defaultCuratedPassSetSpec $ \pm -> do - runPassManager pm mdl' >>= guard + withModuleFromAST ctx mdl $ \mdl' -> do + -- withPassManager defaultCuratedPassSetSpec $ \pm -> do + -- runPassManager pm mdl' >>= guard hPutStrLn stderr "After optimisation:" Text.hPutStrLn stderr . ppllvm =<< moduleAST mdl' withModuleInEngine mcjit mdl' $ \emdl -> do Just f <- getFunction emdl "expr" - let f' = castFunPtr f :: FunPtr (IO Float) + let f' = castFunPtr f :: FunPtr (IO Double) exprFun f' >>= print -evalProg :: AST.Program -> IO (Maybe Float) +evalProg :: AST.Program -> IO (Maybe Double) evalProg (AST.Program asts) = do let eitherMdl = buildModuleT "main" $ mapM buildAST asts case eitherMdl of @@ -60,21 +60,25 @@ evalProg (AST.Program asts) = do withModuleFromAST ctx mdl $ \mdl' -> withModuleInEngine mcjit mdl' $ \emdl -> do Just f <- getFunction emdl "expr" - let f' = castFunPtr f :: FunPtr (IO Float) + let f' = castFunPtr f :: FunPtr (IO Double) Just <$> exprFun f' -- | Builds up programs at the top-level of an LLVM Module -- >>> evalProg (read "31 - 5") -- Just 26.0 +-- >>> evalProg (read "extern pow(x e); pow(3,2)") +-- Just 9.0 buildAST :: AST.AST -> ModuleBuilderE Operand buildAST (AST.Function nameStr paramStrs body) = do let n = fromString nameStr - function n params float $ \binds -> do + function n params Type.double $ \binds -> do let bindMap = Map.fromList (zip paramStrs binds) buildExpr bindMap body >>= ret - where params = zip (repeat float) (map fromString paramStrs) + where params = zip (repeat Type.double) (map fromString paramStrs) +buildAST (AST.Extern nameStr params) = + extern (fromString nameStr) (replicate (length params) Type.double) Type.double buildAST (AST.Eval e) = - function "expr" [] float $ \_ -> buildExpr mempty e >>= ret + function "expr" [] Type.double $ \_ -> buildExpr mempty e >>= ret -- | Builds up expressions, which are operands in LLVM IR -- >>> evalProg (read "def foo(x) x * 2; foo(6)") @@ -82,7 +86,7 @@ buildAST (AST.Eval e) = -- >>> evalProg (read "if 3 > 2 then 42 else 12") -- Just 42.0 buildExpr :: Map.Map String Operand -> AST.Expr -> IRBuilderT ModuleBuilderE Operand -buildExpr _ (AST.Num a) = pure $ ConstantOperand (Float (Single a)) +buildExpr _ (AST.Num a) = pure $ ConstantOperand (Float (Double a)) buildExpr binds (AST.Var n) = case binds Map.!? n of Just x -> pure x Nothing -> lift $ lift $ Left $ "'" <> n <> "' doesn't exist in scope" @@ -91,7 +95,7 @@ buildExpr binds (AST.Call nameStr params) = do paramOps <- mapM (buildExpr binds) params let name = fromString nameStr -- get a pointer to the function - typ = FunctionType float (replicate (length params) float) False + typ = FunctionType Type.double (replicate (length params) Type.double) False ptrTyp = Type.PointerType typ (AddrSpace 0) ref = GlobalReference ptrTyp name call (ConstantOperand ref) (zip paramOps (repeat [])) @@ -110,7 +114,6 @@ buildExpr binds (AST.BinOp op a b) = do buildExpr binds (AST.If cond thenE elseE) = mdo _ifB <- block `named` "if" - condV <- buildExpr binds cond when (typeOf condV /= i1) $ lift $ lift $ Left "Not a boolean" condBr condV thenB elseB -- 2.30.2