Add print functionality

pull/25/head
Ethan Reece 2023-10-06 23:21:55 -05:00
parent 5325a845f2
commit f7e64faed5
Signed by: me
GPG Key ID: D3993665FF92E1C3
4 changed files with 69 additions and 17 deletions

View File

@ -1 +1 @@
6+8/3 (6+8/3)

View File

@ -7,9 +7,13 @@ dependencies:
- parser-combinators - parser-combinators
- text - text
- process - process
- mtl
- containers
- llvm-hs >= 15 && < 16 - llvm-hs >= 15 && < 16
- llvm-hs-pure >= 15 && < 16 - llvm-hs-pure >= 15 && < 16
- bytestring - bytestring
- string-conversions
- transformers
tested-with: GHC == 9.2.8 tested-with: GHC == 9.2.8
category: Compilers/Interpreters category: Compilers/Interpreters

View File

@ -28,10 +28,14 @@ executable really-bad-compiler-in-haskell
build-depends: build-depends:
base >=4.14.3 && <5 base >=4.14.3 && <5
, bytestring , bytestring
, containers
, llvm-hs ==15.* , llvm-hs ==15.*
, llvm-hs-pure ==15.* , llvm-hs-pure ==15.*
, megaparsec >=9.0.1 && <10 , megaparsec >=9.0.1 && <10
, mtl
, parser-combinators , parser-combinators
, process , process
, string-conversions
, text , text
, transformers
default-language: Haskell2010 default-language: Haskell2010

View File

@ -1,12 +1,19 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE RecursiveDo #-}
-- see https://gh.sudoer.ch/danieljharvey/mimsa/blob/trunk/llvm-calc/src/Calc/Compile/ToLLVM.hs -- see https://gh.sudoer.ch/danieljharvey/mimsa/blob/trunk/llvm-calc/src/Calc/Compile/ToLLVM.hs
-- see https://blog.josephmorag.com/posts/mcc3/
module Main.LLVMGen (llvmGen) where module Main.LLVMGen (llvmGen) where
import Control.Monad.State
import Control.Monad.Trans.Class (lift)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Map qualified as M
import Data.String.Conversions
import Data.Text
import LLVM (moduleLLVMAssembly, withModuleFromAST) import LLVM (moduleLLVMAssembly, withModuleFromAST)
import LLVM.AST hiding (function) import LLVM.AST hiding (function)
import LLVM.AST.Type import LLVM.AST.Type
@ -17,34 +24,71 @@ import LLVM.IRBuilder.Module
import LLVM.IRBuilder.Monad import LLVM.IRBuilder.Monad
import Main.Types.Expr as Expr import Main.Types.Expr as Expr
-- printf :: Operand data Env = Env
-- printf = externVarArgs "printf" [ptr] i32 { operands :: M.Map Text Operand,
strings :: M.Map Text Operand
}
deriving (Eq, Show)
registerOperand :: (MonadState Env m) => Text -> Operand -> m ()
registerOperand name op =
modify $ \env -> env {operands = M.insert name op (operands env)}
registerString :: (MonadState Env m) => Text -> Operand -> m ()
registerString name op =
modify $ \env -> env {strings = M.insert name op (operands env)}
getOperand :: (MonadState Env m, MonadModuleBuilder m, MonadIRBuilder m) => Text -> m Operand
getOperand name = do
env <- get
case M.lookup name (operands env) of
Just op -> return op
Nothing -> error $ "Unknown operand: " ++ show name
getString :: (MonadState Env m, MonadModuleBuilder m, MonadIRBuilder m) => Text -> m Operand
getString str = do
env <- get
case M.lookup str (strings env) of
Just s -> return s
Nothing -> do
s <- globalStringPtr (unpack str) (mkName "str")
let operand = ConstantOperand s
modify $ \env -> env {strings = M.insert str operand (strings env)}
return operand
getLLVM :: Expr -> Module getLLVM :: Expr -> Module
getLLVM expr = getLLVM expr =
buildModule "program" $ mdo flip evalState (Env {operands = M.empty, strings = M.empty}) $
-- TODO: better module name buildModuleT "program" $ mdo
printf <- externVarArgs "printf" [ptr] i32 -- TODO: better module name
function "main" [] i32 $ \_ -> mdo printf <- externVarArgs "printf" [ptr] i32
numFormatStr <- globalStringPtr "%d\n" (mkName "str") lift $ registerOperand "printf" printf
ourExpression <- exprToLLVM expr function "main" [] i32 $ \_ -> mdo
_ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])] printNumStr <- globalStringPtr "%d\n" (mkName "str")
ret $ int32 0 lift $ registerString "%d\n" $ ConstantOperand printNumStr
_ <- exprToLLVM expr
ret $ int32 0
-- getLLVM2 expr = --
-- getLLVM $ -- ourExpression <- exprToLLVM expr
-- _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])]
-- return (printf) -- ret $ int32 0
exprToLLVM :: exprToLLVM ::
( MonadIRBuilder m, ( MonadIRBuilder m,
MonadModuleBuilder m MonadModuleBuilder m,
MonadState Env m
) => ) =>
Expr -> Expr ->
m Operand m Operand
exprToLLVM (Lit prim) = pure $ primToLLVM prim exprToLLVM (Lit prim) = pure $ primToLLVM prim
exprToLLVM (Paren e) = exprToLLVM e exprToLLVM (Paren e) = exprToLLVM e
-- exprToLLVM (Print e) = mdo exprToLLVM (Print e) = mdo
val <- exprToLLVM e
printf <- getOperand "printf"
formatStr <- getString "%d\n"
_ <- call (FunctionType i32 [ptr] True) printf [(formatStr, []), (val, [])]
pure val
exprToLLVM (Expr.Add a b) = mdo exprToLLVM (Expr.Add a b) = mdo
lhs <- exprToLLVM a lhs <- exprToLLVM a
rhs <- exprToLLVM b rhs <- exprToLLVM b