diff --git a/example/2.hear b/example/2.hear index 50f4893..2078094 100644 --- a/example/2.hear +++ b/example/2.hear @@ -1 +1 @@ -6+8/3 \ No newline at end of file + (6+8/3) \ No newline at end of file diff --git a/package.yaml b/package.yaml index 84d4766..72cd6c8 100644 --- a/package.yaml +++ b/package.yaml @@ -7,9 +7,13 @@ dependencies: - parser-combinators - text - process + - mtl + - containers - llvm-hs >= 15 && < 16 - llvm-hs-pure >= 15 && < 16 - bytestring + - string-conversions + - transformers tested-with: GHC == 9.2.8 category: Compilers/Interpreters diff --git a/really-bad-compiler-in-haskell.cabal b/really-bad-compiler-in-haskell.cabal index f153056..31bd2b4 100644 --- a/really-bad-compiler-in-haskell.cabal +++ b/really-bad-compiler-in-haskell.cabal @@ -28,10 +28,14 @@ executable really-bad-compiler-in-haskell build-depends: base >=4.14.3 && <5 , bytestring + , containers , llvm-hs ==15.* , llvm-hs-pure ==15.* , megaparsec >=9.0.1 && <10 + , mtl , parser-combinators , process + , string-conversions , text + , transformers default-language: Haskell2010 diff --git a/src/Main/LLVMGen.hs b/src/Main/LLVMGen.hs index a8ce6c6..0032b14 100644 --- a/src/Main/LLVMGen.hs +++ b/src/Main/LLVMGen.hs @@ -1,12 +1,19 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-} -- 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 +import Control.Monad.State +import Control.Monad.Trans.Class (lift) import Data.ByteString (ByteString) +import Data.Map qualified as M +import Data.String.Conversions +import Data.Text import LLVM (moduleLLVMAssembly, withModuleFromAST) import LLVM.AST hiding (function) import LLVM.AST.Type @@ -17,34 +24,71 @@ import LLVM.IRBuilder.Module import LLVM.IRBuilder.Monad import Main.Types.Expr as Expr --- printf :: Operand --- printf = externVarArgs "printf" [ptr] i32 +data Env = Env + { 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 = - buildModule "program" $ mdo - -- TODO: better module name - printf <- externVarArgs "printf" [ptr] i32 - function "main" [] i32 $ \_ -> mdo - numFormatStr <- globalStringPtr "%d\n" (mkName "str") - ourExpression <- exprToLLVM expr - _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])] - ret $ int32 0 + flip evalState (Env {operands = M.empty, strings = M.empty}) $ + buildModuleT "program" $ mdo + -- TODO: better module name + printf <- externVarArgs "printf" [ptr] i32 + lift $ registerOperand "printf" printf + function "main" [] i32 $ \_ -> mdo + printNumStr <- globalStringPtr "%d\n" (mkName "str") + lift $ registerString "%d\n" $ ConstantOperand printNumStr + _ <- exprToLLVM expr + ret $ int32 0 --- getLLVM2 expr = --- getLLVM $ - --- return (printf) +-- +-- ourExpression <- exprToLLVM expr +-- _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])] +-- ret $ int32 0 exprToLLVM :: ( MonadIRBuilder m, - MonadModuleBuilder m + MonadModuleBuilder m, + MonadState Env m ) => Expr -> m Operand exprToLLVM (Lit prim) = pure $ primToLLVM prim 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 lhs <- exprToLLVM a rhs <- exprToLLVM b