diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 600a640..0916a2a 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -12,9 +12,9 @@ jobs: strategy: fail-fast: false matrix: - os: [ubuntu-20.04] - ghc: ["8.10.7"] - cabal: ["3.6"] + os: [ubuntu-24.04] + ghc: ["9.4.8"] + cabal: ["3.8"] steps: - name: Checkout code @@ -27,7 +27,7 @@ jobs: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} - name: Cache Cabal - uses: actions/cache@v3 + uses: actions/cache@v4 env: cache-name: cache-cabal with: @@ -41,12 +41,14 @@ jobs: with: fail-on: warning - name: Check for Ormolu formatting - uses: haskell-actions/run-ormolu@v14 + uses: haskell-actions/run-ormolu@v16 with: - pattern: "**/*.hs" - version: 0.3.1.0 + pattern: | + app/**/*.hs + lib/**/*.hs + test/**/*.hs - name: Install LLVM - run: sudo apt install -y llvm-9 llvm-9-dev + run: sudo apt install -y llvm-17 llvm-17-dev - name: Build project run: cabal build - name: Run tests diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index 9b173d0..40366dc 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -11,9 +11,9 @@ jobs: strategy: fail-fast: false matrix: - os: [ubuntu-20.04] - ghc: ["8.10.7"] - cabal: ["3.6"] + os: [ubuntu-24.04] + ghc: ["9.4.8"] + cabal: ["3.8"] steps: - name: Checkout code @@ -26,7 +26,7 @@ jobs: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} - name: Cache Cabal - uses: actions/cache@v3 + uses: actions/cache@v4 env: cache-name: cache-cabal with: @@ -34,7 +34,7 @@ jobs: key: ${{ runner.os }}-docs-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} restore-keys: ${{ runner.os }}-docs-${{ env.cache-name }}- - name: Install LLVM - run: sudo apt install -y llvm-9 llvm-9-dev + run: sudo apt install -y llvm-17 llvm-17-dev - name: Build docs run: > cabal haddock diff --git a/README.md b/README.md index e990149..e85cf67 100644 --- a/README.md +++ b/README.md @@ -109,3 +109,9 @@ Global options: - [Implementation details](docs/dev/impl.md) - [Development workflow](docs/dev/flow.md) + +### Build Requirements + +- **GHC**: 9.4.8 +- **Cabal**: 3.8 +- **LLVM**: 17 diff --git a/app/Commands/Compile.hs b/app/Commands/Compile.hs index eaa5bb4..1d634bc 100644 --- a/app/Commands/Compile.hs +++ b/app/Commands/Compile.hs @@ -1,16 +1,18 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Commands.Compile (compile) where import CodeGen.Llvm.Runner (compileToBinary, compileToLlvmIr) import CodeGen.TimedValue (TimedValue (TimedValue)) -import Configuration.AppConfiguration (CompilationTarget (..), Compile (..), Debug (Yes), Output (..)) +import Configuration.AppConfiguration (CompilationTarget (..), Compile (..), Debug (Yes), Input (..), Output (..)) import Control.Monad (when) import Data.Text (Text) import qualified Data.Text as Txt import System.Exit (die) +import System.FilePath (takeBaseName) import qualified Text.Printf as Printf -import Utils (inputToModuleName, ns2s, readText) +import Utils (ns2s, readText) compile :: Compile -> Debug -> IO () compile (Compile input target output) debug = do @@ -20,10 +22,10 @@ compile (Compile input target output) debug = do TimedValue res compTime <- case target of TargetBinary -> do let outputFilePath = outputToFilePath output moduleName "out" - compileToBinary moduleName text outputFilePath + compileToBinary text outputFilePath TargetLlvmIr -> do let outputFilePath = outputToFilePath output moduleName "ll" - compileToLlvmIr moduleName text outputFilePath + compileToLlvmIr text outputFilePath when (debug == Yes) $ do putStrLn $ Printf.printf "Finished compiling in %0.5f sec" (ns2s compTime) @@ -31,6 +33,11 @@ compile (Compile input target output) debug = do either (die . Txt.unpack) return res +inputToModuleName :: Input -> Text +inputToModuleName = \case + StdInput -> "unnamed" + FileInput filePath -> Txt.pack $ takeBaseName filePath + outputToFilePath :: Output -> Text -> Text -> FilePath outputToFilePath output moduleName ext = case output of FileOutput filePath -> filePath diff --git a/app/Commands/Run.hs b/app/Commands/Run.hs index 8e27f20..6aa8b5b 100644 --- a/app/Commands/Run.hs +++ b/app/Commands/Run.hs @@ -11,14 +11,13 @@ import System.Exit (ExitCode (..), die, exitWith) import System.IO (hPutStr) import qualified System.IO as Sys import qualified Text.Printf as Printf -import Utils (inputToModuleName, ns2s, readText) +import Utils (ns2s, readText) run :: Run -> Debug -> IO () run (Run input) debug = do - let moduleName = inputToModuleName input text <- readText input - runResult <- Llvm.run moduleName text + runResult <- Llvm.run text case runResult of Success stdout compTime runTime -> do diff --git a/app/Configuration/Commands/Run.hs b/app/Configuration/Commands/Run.hs index 9d58afc..c5580e1 100644 --- a/app/Configuration/Commands/Run.hs +++ b/app/Configuration/Commands/Run.hs @@ -11,7 +11,7 @@ runParserInfo :: ParserInfo Command runParserInfo = info runParser runInfoMod runParser :: Parser Command -runParser = CmdRun <$> (Run <$> inputParser) +runParser = CmdRun . Run <$> inputParser runInfoMod :: InfoMod a runInfoMod = diff --git a/app/Utils.hs b/app/Utils.hs index 5182d37..ec00408 100644 --- a/app/Utils.hs +++ b/app/Utils.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} module Utils where @@ -8,16 +6,10 @@ import CodeGen.TimedValue (Nanoseconds (..)) import Configuration.AppConfiguration (Input (..)) import Data.Text (Text) import qualified Data.Text as Txt -import System.FilePath (takeBaseName) readText :: Input -> IO Text readText (FileInput path) = Txt.pack <$> readFile path readText StdInput = Txt.pack <$> getContents -inputToModuleName :: Input -> Text -inputToModuleName = \case - StdInput -> "unnamed" - FileInput filePath -> Txt.pack $ takeBaseName filePath - ns2s :: Nanoseconds -> Double ns2s ns = let Nanoseconds ns' = ns in fromInteger ns' / 1_000_000_000 diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..ffadd11 --- /dev/null +++ b/cabal.project @@ -0,0 +1,6 @@ +source-repository-package + type: git + location: https://github.com/luc-tielen/llvm-codegen.git + tag: 83b04cb576208ea74ddd62016e4fa03f0df138ac + +packages: . diff --git a/cabal.project.freeze b/cabal.project.freeze index edf61ee..edc8d7f 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -1,23 +1,21 @@ active-repositories: hackage.haskell.org:merge -constraints: any.Cabal ==3.6.3.0, - Cabal -bundled-binary-generic, +constraints: any.Cabal ==3.8.1.0, + any.Cabal-syntax ==3.8.1.0, any.StateVar ==1.2.2, - any.ansi-terminal ==1.0, + any.ansi-terminal ==1.1.1, ansi-terminal -example, - any.ansi-terminal-types ==0.11.5, + any.ansi-terminal-types ==1.1, any.array ==0.5.4.0, - any.assoc ==1.1, - assoc +tagged, + any.assoc ==1.1.1, + assoc -tagged, any.async ==2.2.5, async -bench, - any.attoparsec ==0.14.4, - attoparsec -developer, - any.base ==4.14.3.0, - any.base-orphans ==0.9.1, - any.bifunctors ==5.6.1, + any.base ==4.17.2.1, + any.base-orphans ==0.9.2, + any.bifunctors ==5.6.2, bifunctors +tagged, any.binary ==0.8.9.1, - any.bytestring ==0.11.2.0, + any.bytestring ==0.11.5.3, any.cabal-doctest ==1.0.9, any.call-stack ==0.4.0, any.case-insensitive ==1.2.1.0, @@ -26,44 +24,42 @@ constraints: any.Cabal ==3.6.3.0, any.colour ==2.3.6, any.comonad ==5.0.8, comonad +containers +distributive +indexed-traversable, - any.containers ==0.6.8, + any.containers ==0.6.7, any.contravariant ==1.5.5, contravariant +semigroups +statevar +tagged, - any.data-array-byte ==0.1.0.1, - any.data-fix ==0.3.2, - any.deepseq ==1.4.4.0, + any.data-fix ==0.3.3, + any.deepseq ==1.4.8.0, any.directory ==1.3.7.1, any.distributive ==0.6.2.1, distributive +semigroups +tagged, - any.exceptions ==0.10.4, - any.extra ==1.7.14, - any.fail ==4.9.0.0, - any.file-embed ==0.0.15.0, - any.filepath ==1.4.2.1, + any.dlist ==1.0, + dlist -werror, + any.exceptions ==0.10.8, + exceptions +transformers-0-4, + any.extra ==1.7.16, + any.file-embed ==0.0.16.0, + any.filepath ==1.4.2.2, any.foldable1-classes-compat ==0.1, foldable1-classes-compat +tagged, any.free ==5.2, - any.ghc-boot-th ==8.10.7, - any.ghc-prim ==0.6.1, - any.hashable ==1.4.3.0, - hashable +integer-gmp -random-initial-seed, - any.hsc2hs ==0.68.10, - hsc2hs -in-ghc-tree, - any.indexed-traversable ==0.1.3, - any.integer-gmp ==1.0.3.0, + any.ghc-bignum ==1.3, + any.ghc-boot-th ==9.4.8, + any.ghc-prim ==0.9.1, + any.hashable ==1.4.6.0, + hashable +arch-native +integer-gmp -random-initial-seed, + any.indexed-traversable ==0.1.4, any.integer-logarithms ==1.0.3.1, integer-logarithms -check-bounds +integer-gmp, - any.llvm-hs ==9.0.1, - llvm-hs -debug +shared-llvm, - any.llvm-hs-pretty ==0.9.0.0, - any.llvm-hs-pure ==9.0.0, + any.llvm-codegen ==0.1.0.0, any.logict ==0.8.0.0, - any.megaparsec ==9.2.1, + any.megaparsec ==9.6.1, megaparsec -dev, - any.mtl ==2.2.2, + any.mmorph ==1.2.0, + any.mtl ==2.2.2 || ==2.3.1, any.optparse-applicative ==0.18.1.0, optparse-applicative +process, - any.parsec ==3.1.17.0, + any.os-string ==2.0.3, + any.parsec ==3.1.16.1, any.parser-combinators ==1.3.0, parser-combinators -dev, any.pretty ==1.1.3.6, @@ -75,17 +71,18 @@ constraints: any.Cabal ==3.6.3.0, any.primitive ==0.9.0.0, any.process ==1.6.18.0, any.profunctors ==5.6.2, - any.random ==1.2.1.1, - any.recursion-schemes ==5.2.2.5, + any.quote-quot ==0.2.1.0, + any.random ==1.2.1.2, + any.recursion-schemes ==5.2.3, recursion-schemes +template-haskell, - any.rts ==1.0.1, - any.scientific ==0.3.7.0, - scientific -bytestring-builder -integer-simple, - any.semigroupoids ==6.0.0.1, + any.rts ==1.0.2, + any.scientific ==0.3.8.0, + scientific -integer-simple, + any.semigroupoids ==6.0.1, semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, any.splitmix ==0.1.0.5, splitmix -optimised-mixer, - any.stm ==2.5.0.1, + any.stm ==2.5.1.0, any.string-conversions ==0.4.0.1, any.string-transform ==1.1.1, any.tagged ==0.8.8, @@ -95,12 +92,12 @@ constraints: any.Cabal ==3.6.3.0, any.tasty-golden ==2.3.5, tasty-golden -build-example, any.tasty-hunit ==0.10.1, - any.template-haskell ==2.16.0.0, + any.template-haskell ==2.19.0.0, any.temporary ==1.3, any.text ==2.0.2, - text -developer +simdutf, - any.th-abstraction ==0.6.0.0, - any.time ==1.9.3, + any.text-builder-linear ==0.1.2, + any.th-abstraction ==0.7.0.0, + any.time ==1.12.2, any.transformers ==0.5.6.2, any.transformers-base ==0.4.6, transformers-base +orphaninstances, @@ -110,7 +107,7 @@ constraints: any.Cabal ==3.6.3.0, any.unification-fd ==0.11.2, any.unix ==2.7.3, any.unliftio-core ==0.2.1.0, - any.unordered-containers ==0.2.19.1, + any.unordered-containers ==0.2.20, unordered-containers -debug, any.utf8-string ==1.0.2 -index-state: hackage.haskell.org 2024-01-02T19:29:37Z +index-state: hackage.haskell.org 2024-06-20T07:22:15Z diff --git a/lib/CodeGen/Llvm/LlvmIrGen.hs b/lib/CodeGen/Llvm/LlvmIrGen.hs index 2e579a1..43f83d4 100644 --- a/lib/CodeGen/Llvm/LlvmIrGen.hs +++ b/lib/CodeGen/Llvm/LlvmIrGen.hs @@ -11,19 +11,10 @@ import Control.Monad.State (MonadState, State, evalState, gets, modify) import Data.Map (Map) import qualified Data.Map as Map import Data.String.Conversions (cs) -import Data.String.Transform (toShortByteString) import Data.Text (Text) import qualified Data.Text as Txt import Foreign (fromBool) -import qualified LLVM.AST as LLVM hiding (function) -import qualified LLVM.AST.Constant as C -import qualified LLVM.AST.IntegerPredicate as LLVM -import qualified LLVM.AST.Type as LLVM -import qualified LLVM.IRBuilder.Constant as LLVM -import qualified LLVM.IRBuilder.Instruction as LLVM -import qualified LLVM.IRBuilder.Module as LLVM -import qualified LLVM.IRBuilder.Monad as LLVM -import LLVM.Pretty (ppllvm) +import qualified LLVM.Codegen as LLVM import MonadUtils (locally) import qualified StdLib import Transformations.Anf.Anf @@ -35,7 +26,7 @@ genLlvmIrModule :: Module -> LLVM.Module genLlvmIrModule = genModule ppLlvmModule :: LLVM.Module -> Text -ppLlvmModule = cs . ppllvm +ppLlvmModule = cs . LLVM.ppllvm -- * Implementation @@ -50,8 +41,8 @@ data Env = Env } genModule :: Module -> LLVM.Module -genModule (Module name (Program decls)) = flip evalState (Env Map.empty Map.empty Map.empty) $ - LLVM.buildModuleT (toShortByteString name) $ do +genModule (Module (Program decls)) = flip evalState (Env Map.empty Map.empty Map.empty) $ + LLVM.runModuleBuilderT $ do mapM_ genStdLibDecl StdLib.allDeclsWithArity mapM_ genGlobDecl decls @@ -74,7 +65,7 @@ genStdLibDecl decl = declareAsExtern decl >>= register decl declareAsExtern :: StdLib.DeclarationWithArity -> Llvm LLVM.Operand declareAsExtern (ident, arity) = LLVM.extern - (LLVM.mkName $ Txt.unpack ident) + (LLVM.Name ident) (replicate arity LLVM.i64) LLVM.i64 @@ -84,14 +75,14 @@ genStdLibDecl decl = declareAsExtern decl >>= register decl genGlobDecl :: GlobalDeclaration -> Llvm () genGlobDecl = \case GlobVarDecl ident _ -> do - var <- LLVM.global (LLVM.mkName $ genId ident) LLVM.i64 (C.Int 64 0) + var <- LLVM.global (LLVM.Name $ Txt.pack $ genId ident) LLVM.i64 (LLVM.Int 64 0) regGlobVar ident var GlobFunDecl ident params body -> mdo regFun ident fun (length params) fun <- locally $ do LLVM.function - (LLVM.mkName $ genId ident) - ((LLVM.i64,) . LLVM.ParameterName . toShortByteString . genId <$> params) + (LLVM.Name $ Txt.pack $ genId ident) + ((LLVM.i64,) . LLVM.ParameterName . Txt.pack . genId <$> params) LLVM.i64 $ \args -> do mapM_ (uncurry regLocVar) (params `zip` args) @@ -109,7 +100,7 @@ genExpr = \case ExprAtom atom -> genAtom atom ExprComp ce -> genComp ce ExprLetIn (ident, val) expr -> do - val' <- genExpr val `LLVM.named` toShortByteString (genId ident) + val' <- genExpr val regLocVar ident val' genExpr expr @@ -126,22 +117,22 @@ genComp = \case f' <- findAny f arg' <- genAtom arg applyF <- findFun (Txt "miniml_apply") - LLVM.call applyF [(f', []), (arg', [])] + LLVM.call applyF [f', arg'] CompIte c t e -> mdo rv <- allocate' c' <- genAtom c >>= intToBool LLVM.condBr c' tBlock eBlock - tBlock <- LLVM.block `LLVM.named` "if.then" + tBlock <- LLVM.blockNamed "if.then" store' rv =<< genExpr t LLVM.br end - eBlock <- LLVM.block `LLVM.named` "if.else" + eBlock <- LLVM.blockNamed "if.else" store' rv =<< genExpr e LLVM.br end - end <- LLVM.block `LLVM.named` "if.end" + end <- LLVM.blockNamed "if.end" load' rv CompBinOp op lhs rhs -> do @@ -156,7 +147,7 @@ genComp = \case ArithOp DivOp -> ( \lhs'' rhs'' -> do divF <- findFun (Txt "miniml_div") - LLVM.call divF [(lhs'', []), (rhs'', [])] + LLVM.call divF [lhs'', rhs''] ) CompOp cOp -> let cOpF = case cOp of @@ -187,24 +178,24 @@ findAny ident = do Just (fun, arity) -> do funToPafF <- findFun (Txt "miniml_fun_to_paf") fun' <- LLVM.ptrtoint fun LLVM.i64 - LLVM.call funToPafF [(fun', []), (LLVM.int64 (toInteger arity), [])] + LLVM.call funToPafF [fun', LLVM.int64 (toInteger arity)] Nothing -> load' =<< findGlobVar ident -findGlobVar :: MonadState Env m => Identifier' -> m LLVM.Operand +findGlobVar :: (MonadState Env m) => Identifier' -> m LLVM.Operand findGlobVar ident = gets ((Map.! ident) . globVars) findFun :: Identifier' -> CodeGenM LLVM.Operand findFun ident = gets (fst . (Map.! ident) . funs) -regLocVar :: MonadState Env m => Identifier' -> LLVM.Operand -> m () +regLocVar :: (MonadState Env m) => Identifier' -> LLVM.Operand -> m () regLocVar ident var = modify $ \env -> env {locVars = Map.insert ident var (locVars env)} -regGlobVar :: MonadState Env m => Identifier' -> LLVM.Operand -> m () +regGlobVar :: (MonadState Env m) => Identifier' -> LLVM.Operand -> m () regGlobVar ident gVar = modify $ \env -> env {globVars = Map.insert ident gVar (globVars env)} -regFun :: MonadState Env m => Identifier' -> LLVM.Operand -> Arity -> m () +regFun :: (MonadState Env m) => Identifier' -> LLVM.Operand -> Arity -> m () regFun ident fun paramsCnt = modify $ \env -> env {funs = Map.insert ident (fun, paramsCnt) (funs env)} diff --git a/lib/CodeGen/Llvm/Runner.hs b/lib/CodeGen/Llvm/Runner.hs index ba0b623..e1002d2 100644 --- a/lib/CodeGen/Llvm/Runner.hs +++ b/lib/CodeGen/Llvm/Runner.hs @@ -11,7 +11,6 @@ import Control.Monad.Except (Except, runExcept) import Data.FileEmbed (embedFile, makeRelativeToProject) import Data.String.Conversions (cs) import Data.Text (Text) -import qualified Data.Text as Txt import qualified Data.Text.Encoding as Txt import qualified Data.Text.IO as Txt import System.Directory (removePathForcibly, withCurrentDirectory) @@ -20,9 +19,9 @@ import System.IO (IOMode (WriteMode), hClose, withFile) import System.Posix.Temp (mkdtemp, mkstemps) import System.Process (callProcess, readProcessWithExitCode) -run :: Text -> Text -> IO RR.RunResult -run moduleName text = do - TimedValue compResult compTime <- compileToBinary moduleName text outputFilePath +run :: Text -> IO RR.RunResult +run text = do + TimedValue compResult compTime <- compileToBinary text outputFilePath case compResult of Right () -> do @@ -50,7 +49,7 @@ run moduleName text = do } where outputFilePath :: FilePath - outputFilePath = "./" <> Txt.unpack moduleName + outputFilePath = "./program" runCompiledModule :: IO (TimedValue (Either (String, String, Int) String)) runCompiledModule = do @@ -64,15 +63,15 @@ run moduleName text = do return measuredResult -compileToBinary :: Text -> Text -> FilePath -> IO (TimedValue (Either Text ())) -compileToBinary moduleName text outputFilePath = measureTimedValue $ +compileToBinary :: Text -> FilePath -> IO (TimedValue (Either Text ())) +compileToBinary text outputFilePath = measureTimedValue $ sequenceA $ runExcept $ do - llvmIrText <- compileToLlvmIr' moduleName text + llvmIrText <- compileToLlvmIr' text return $ bracket (mkdtemp "build") removePathForcibly $ \buildDir -> withCurrentDirectory buildDir $ do - (llvm, llvmHandle) <- mkstemps (Txt.unpack moduleName) ".ll" + (llvm, llvmHandle) <- mkstemps "module" ".ll" Txt.hPutStrLn llvmHandle llvmIrText hClose llvmHandle @@ -83,18 +82,18 @@ compileToBinary moduleName text outputFilePath = measureTimedValue $ callProcess "clang" ["-Wno-override-module", "-O3", "-lm", llvm, runtime, "-o", "../" <> outputFilePath] -compileToLlvmIr :: Text -> Text -> FilePath -> IO (TimedValue (Either Text ())) -compileToLlvmIr moduleName text outputFilePath = measureTimedValue $ +compileToLlvmIr :: Text -> FilePath -> IO (TimedValue (Either Text ())) +compileToLlvmIr text outputFilePath = measureTimedValue $ sequenceA $ runExcept $ do - llvmIrText <- compileToLlvmIr' moduleName text + llvmIrText <- compileToLlvmIr' text return $ withFile outputFilePath WriteMode $ \handle -> do Txt.hPutStrLn handle llvmIrText -- * Internal -compileToLlvmIr' :: Text -> Text -> Except Text Text -compileToLlvmIr' moduleName text = do - irModule <- compileToModule moduleName text +compileToLlvmIr' :: Text -> Except Text Text +compileToLlvmIr' text = do + irModule <- compileToModule text return $ ppLlvmModule $ genLlvmIrModule irModule diff --git a/lib/CodeGen/Module.hs b/lib/CodeGen/Module.hs index 81455d8..50b4731 100644 --- a/lib/CodeGen/Module.hs +++ b/lib/CodeGen/Module.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module CodeGen.Module - ( Module (Module, name, code), + ( Module (Module, code), compileToModule, ) where @@ -21,18 +21,15 @@ import Transformations.Simplifier.Simplifier (simplifyAst) import qualified TypeChecker.PrettyPrinter as TC import TypeChecker.TypeChecker (checkProgram) -data Module = Module - { name :: Text, - code :: Anf.Program - } +newtype Module = Module {code :: Anf.Program} deriving (Show, Eq) -compileToModule :: Text -> Text -> Except Text Module -compileToModule moduleName text = do +compileToModule :: Text -> Except Text Module +compileToModule text = do program <- parseAndVerify text let astToAnf = genAnf . llAst . ccAst . relabelAst . simplifyAst anf = astToAnf program - irMod = Module moduleName anf + irMod = Module anf in return irMod parseAndVerify :: Text -> Except Text Program diff --git a/lib/MonadUtils.hs b/lib/MonadUtils.hs index afc0a53..8773340 100644 --- a/lib/MonadUtils.hs +++ b/lib/MonadUtils.hs @@ -3,16 +3,16 @@ module MonadUtils where import Control.Monad (liftM2, liftM3) import Control.Monad.State (MonadState (get, put)) -liftM1' :: Monad m => (a' -> m a) -> (a -> b) -> a' -> m b +liftM1' :: (Monad m) => (a' -> m a) -> (a -> b) -> a' -> m b liftM1' lifter f a = f <$> lifter a -liftM2' :: Monad m => (a' -> m a) -> (a -> a -> b) -> a' -> a' -> m b +liftM2' :: (Monad m) => (a' -> m a) -> (a -> a -> b) -> a' -> a' -> m b liftM2' lifter f a b = liftM2 f (lifter a) (lifter b) -liftM3' :: Monad m => (a' -> m a) -> (a -> a -> a -> b) -> a' -> a' -> a' -> m b +liftM3' :: (Monad m) => (a' -> m a) -> (a -> a -> a -> b) -> a' -> a' -> a' -> m b liftM3' lifter f a b c = liftM3 f (lifter a) (lifter b) (lifter c) -locally :: MonadState s m => m a -> m a +locally :: (MonadState s m) => m a -> m a locally computation = do oldState <- get result <- computation diff --git a/lib/Transformations/Anf/AnfGen.hs b/lib/Transformations/Anf/AnfGen.hs index fc1abc2..160028a 100644 --- a/lib/Transformations/Anf/AnfGen.hs +++ b/lib/Transformations/Anf/AnfGen.hs @@ -60,10 +60,10 @@ genExpr (Lfr.ExprLetIn (Lfr.VarDecl ident val) expr) = do expr' <- genExpr expr return $ Anf.ExprLetIn (ident, val') expr' -returnAtom :: MonadState Env m => Anf.AtomicExpression -> m Anf.Expression +returnAtom :: (MonadState Env m) => Anf.AtomicExpression -> m Anf.Expression returnAtom = return . Anf.ExprAtom -returnComplex :: MonadState Env m => Anf.ComplexExpression -> m Anf.Expression +returnComplex :: (MonadState Env m) => Anf.ComplexExpression -> m Anf.Expression returnComplex = return . Anf.ExprComp -- ** Normalizers diff --git a/lib/Transformations/Cc/Cc.hs b/lib/Transformations/Cc/Cc.hs index 530417b..fc2425e 100644 --- a/lib/Transformations/Cc/Cc.hs +++ b/lib/Transformations/Cc/Cc.hs @@ -84,7 +84,7 @@ ccExpr = \case closedFun <- cc1 (Ast.Fun (prependList fv params)) body return $ apply (Ast.ExprFun closedFun) (Ast.ExprId <$> fv) where - apply :: Foldable t => Ast.Expression -> t Ast.Expression -> Ast.Expression + apply :: (Foldable t) => Ast.Expression -> t Ast.Expression -> Ast.Expression apply = foldl' Ast.ExprApp findFv :: Ast.Expression -> Set Ast.Identifier' @@ -112,7 +112,7 @@ findFv = \case -- ** Collection Utils -toSet :: Ord a => NonEmpty a -> Set a +toSet :: (Ord a) => NonEmpty a -> Set a toSet = Set.fromList . NE.toList prependList :: [a] -> NonEmpty a -> NonEmpty a diff --git a/lib/TypeChecker/HindleyMilner.hs b/lib/TypeChecker/HindleyMilner.hs index 6bb6218..980b081 100644 --- a/lib/TypeChecker/HindleyMilner.hs +++ b/lib/TypeChecker/HindleyMilner.hs @@ -10,7 +10,25 @@ {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} -module TypeChecker.HindleyMilner where +module TypeChecker.HindleyMilner + ( Infer, + TypeError (..), + UType, + Polytype, + applyBindings, + generalize, + toPolytype, + toUType, + withBinding, + fresh, + Poly (..), + UTerm (UTVar, UTUnit, UTBool, UTInt, UTFun), + (=:=), + lookup, + TypeF (..), + mkVarName, + ) +where import Control.Monad.Except import Control.Monad.Reader @@ -27,86 +45,78 @@ import Data.Set (Set, (\\)) import qualified Data.Set as S import Data.Text (pack) import GHC.Generics (Generic1) -import Trees.Common (Identifier, Type (..)) +import qualified Trees.Common as L -- Lang import Prelude hiding (lookup) -data HType a - = TyVarF Identifier - | TyUnitF - | TyBoolF - | TyIntF - | TyFunF a a - deriving (Show, Eq, Functor, Foldable, Traversable, Generic1, Unifiable) - -type TypeF = Fix HType - -type UType = UTerm HType IntVar +-- * Type -data Poly t = Forall [Identifier] t - deriving (Eq, Show, Functor) +type Type = Fix TypeF -type Polytype = Poly TypeF +data TypeF a + = TVarF L.Identifier + | TUnitF + | TBoolF + | TIntF + | TFunF a a + deriving (Show, Eq, Functor, Foldable, Traversable, Generic1, Unifiable) -type UPolytype = Poly UType +-- * UType --- TypeF +type UType = UTerm TypeF IntVar -pattern TyVar :: Identifier -> TypeF -pattern TyVar v = Fix (TyVarF v) +pattern UTVar :: L.Identifier -> UType +pattern UTVar var = UTerm (TVarF var) -pattern TyUnit :: TypeF -pattern TyUnit = Fix TyUnitF +pattern UTUnit :: UType +pattern UTUnit = UTerm TUnitF -pattern TyBool :: TypeF -pattern TyBool = Fix TyBoolF +pattern UTBool :: UType +pattern UTBool = UTerm TBoolF -pattern TyInt :: TypeF -pattern TyInt = Fix TyIntF +pattern UTInt :: UType +pattern UTInt = UTerm TIntF -pattern TyFun :: TypeF -> TypeF -> TypeF -pattern TyFun t1 t2 = Fix (TyFunF t1 t2) +pattern UTFun :: UType -> UType -> UType +pattern UTFun funT argT = UTerm (TFunF funT argT) --- UType +-- * Polytype -pattern UTyVar :: Identifier -> UType -pattern UTyVar v = UTerm (TyVarF v) +data Poly t = Forall [L.Identifier] t + deriving (Eq, Show, Functor) -pattern UTyUnit :: UType -pattern UTyUnit = UTerm TyUnitF +type Polytype = Poly Type -pattern UTyBool :: UType -pattern UTyBool = UTerm TyBoolF +type UPolytype = Poly UType -pattern UTyInt :: UType -pattern UTyInt = UTerm TyIntF +-- * Converters -pattern UTyFun :: UType -> UType -> UType -pattern UTyFun t1 t2 = UTerm (TyFunF t1 t2) +toUType :: L.Type -> UType +toUType = \case + L.TUnit -> UTUnit + L.TBool -> UTBool + L.TInt -> UTInt + L.TFun funT argT -> UTFun (toUType funT) (toUType argT) -toTypeF :: Type -> TypeF -toTypeF = \case - TUnit -> TyUnit - TBool -> TyBool - TInt -> TyInt - TFun t1 t2 -> TyFun (toTypeF t1) (toTypeF t2) +toPolytype :: UPolytype -> Polytype +toPolytype = fmap (fromJust . freeze) -fromTypeToUType :: Type -> UType -fromTypeToUType = \case - TUnit -> UTyUnit - TBool -> UTyBool - TInt -> UTyInt - TFun t1 t2 -> UTyFun (fromTypeToUType t1) (fromTypeToUType t2) +-- * Infer -type Infer = ReaderT Ctx (ExceptT TypeError (IntBindingT HType Identity)) +type Infer = ReaderT Ctx (ExceptT TypeError (IntBindingT TypeF Identity)) -type Ctx = Map Identifier UPolytype +type Ctx = Map L.Identifier UPolytype -lookup :: LookUpType -> Infer UType -lookup (Var v) = do - ctx <- ask - maybe (throwError $ UnboundVar v) instantiate (M.lookup v ctx) +lookup :: L.Identifier -> Infer UType +lookup var = do + varUPT <- asks $ M.lookup var + maybe (throwError $ UnboundVar var) instantiate varUPT + where + instantiate :: UPolytype -> Infer UType + instantiate (Forall xs uty) = do + xs' <- mapM (const fresh) xs + return $ substU (M.fromList (zip (map Left xs) xs')) uty -withBinding :: (MonadReader Ctx m) => Identifier -> UPolytype -> m a -> m a +withBinding :: (MonadReader Ctx m) => L.Identifier -> UPolytype -> m a -> m a withBinding x ty = local (M.insert x ty) ucata :: (Functor t) => (v -> a) -> (t a -> a) -> UTerm t v -> a @@ -115,8 +125,10 @@ ucata f g (UTerm t) = g (fmap (ucata f g) t) deriving instance Ord IntVar +-- * FreeVars + class FreeVars a where - freeVars :: a -> Infer (Set (Either Identifier IntVar)) + freeVars :: a -> Infer (Set (Either L.Identifier IntVar)) instance FreeVars UType where freeVars ut = do @@ -124,7 +136,7 @@ instance FreeVars UType where let ftvs = ucata (const S.empty) - (\case TyVarF x -> S.singleton (Left x); f -> fold f) + (\case TVarF x -> S.singleton (Left x); f -> fold f) ut return $ fuvs `S.union` ftvs @@ -134,67 +146,48 @@ instance FreeVars UPolytype where instance FreeVars Ctx where freeVars = fmap S.unions . mapM freeVars . M.elems -newtype LookUpType = Var Identifier +fresh :: Infer UType +fresh = UVar <$> lift (lift freeVar) + +-- * Errors data TypeError where Unreachable :: TypeError - UnboundVar :: Identifier -> TypeError + UnboundVar :: L.Identifier -> TypeError Infinite :: IntVar -> UType -> TypeError ImpossibleBinOpApplication :: UType -> UType -> TypeError ImpossibleUnOpApplication :: UType -> TypeError - Mismatch :: HType UType -> HType UType -> TypeError + Mismatch :: TypeF UType -> TypeF UType -> TypeError deriving (Show) -instance Fallible HType IntVar TypeError where +instance Fallible TypeF IntVar TypeError where occursFailure = Infinite mismatchFailure = Mismatch -fresh :: Infer UType -fresh = UVar <$> lift (lift freeVar) - (=:=) :: UType -> UType -> Infer UType s =:= t = lift $ s U.=:= t applyBindings :: UType -> Infer UType applyBindings = lift . U.applyBindings -instantiate :: UPolytype -> Infer UType -instantiate (Forall xs uty) = do - xs' <- mapM (const fresh) xs - return $ substU (M.fromList (zip (map Left xs) xs')) uty - -substU :: Map (Either Identifier IntVar) UType -> UType -> UType +substU :: Map (Either L.Identifier IntVar) UType -> UType -> UType substU m = ucata (\v -> fromMaybe (UVar v) (M.lookup (Right v) m)) ( \case - TyVarF v -> fromMaybe (UTyVar v) (M.lookup (Left v) m) + TVarF v -> fromMaybe (UTVar v) (M.lookup (Left v) m) f -> UTerm f ) -skolemize :: UPolytype -> Infer UType -skolemize (Forall xs uty) = do - xs' <- mapM (const fresh) xs - return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty - where - toSkolem (UVar v) = UTyVar (mkVarName "s" v) - toSkolem _ = undefined -- We can't reach another situation, because we previously give `fresh` variable - -mkVarName :: String -> IntVar -> Identifier -mkVarName nm (IntVar v) = pack (nm ++ show (v + (maxBound :: Int) + 1)) +mkVarName :: String -> IntVar -> L.Identifier +mkVarName nm (IntVar v) = pack (nm <> show (v + (maxBound :: Int) + 1)) generalize :: UType -> Infer UPolytype generalize uty = do uty' <- applyBindings uty ctx <- ask - tmfvs <- freeVars uty' - ctxfvs <- freeVars ctx - let fvs = S.toList $ tmfvs \\ ctxfvs + tmFreeVars <- freeVars uty' + ctxFreeVars <- freeVars ctx + let fvs = S.toList $ tmFreeVars \\ ctxFreeVars xs = map (either id (mkVarName "a")) fvs - return $ Forall xs (substU (M.fromList (zip fvs (map UTyVar xs))) uty') - -toUPolytype :: Polytype -> UPolytype -toUPolytype = fmap unfreeze - -fromUPolytype :: UPolytype -> Polytype -fromUPolytype = fmap (fromJust . freeze) + return $ Forall xs (substU (M.fromList (zip fvs (map UTVar xs))) uty') diff --git a/lib/TypeChecker/PrettyPrinter.hs b/lib/TypeChecker/PrettyPrinter.hs index c88e355..5efccb9 100644 --- a/lib/TypeChecker/PrettyPrinter.hs +++ b/lib/TypeChecker/PrettyPrinter.hs @@ -23,12 +23,12 @@ type Prec = Int instance (Pretty (t (Fix t))) => Pretty (Fix t) where prettyPrec p = prettyPrec p . unFix -instance (Pretty t) => Pretty (HType t) where - prettyPrec _ (TyVarF x) = unpack x - prettyPrec _ TyUnitF = "unit" - prettyPrec _ TyBoolF = "bool" - prettyPrec _ TyIntF = "int" - prettyPrec p (TyFunF ty1 ty2) = +instance (Pretty t) => Pretty (TypeF t) where + prettyPrec _ (TVarF x) = unpack x + prettyPrec _ TUnitF = "unit" + prettyPrec _ TBoolF = "bool" + prettyPrec _ TIntF = "int" + prettyPrec p (TFunF ty1 ty2) = mparens (p > 0) $ prettyPrec 1 ty1 ++ " -> " ++ prettyPrec 0 ty2 instance (Pretty (t (UTerm t v)), Pretty v) => Pretty (UTerm t v) where diff --git a/lib/TypeChecker/TypeChecker.hs b/lib/TypeChecker/TypeChecker.hs index d44173f..e8496c1 100644 --- a/lib/TypeChecker/TypeChecker.hs +++ b/lib/TypeChecker/TypeChecker.hs @@ -14,6 +14,7 @@ import Data.Maybe import Parser.Ast import qualified StdLib import Trees.Common +import qualified Trees.Common as L import TypeChecker.HindleyMilner import Prelude hiding (lookup) @@ -28,14 +29,14 @@ inferProgram (Program stmts) = runInfer $ withStdLib (inferStatements stmts) runInfer :: Infer UType -> Either TypeError Polytype runInfer = (>>= applyBindings) - >>> (>>= (generalize >>> fmap fromUPolytype)) + >>> (>>= (generalize >>> fmap toPolytype)) >>> flip runReaderT M.empty >>> runExceptT >>> evalIntBindingT >>> runIdentity withStdLib infer = do - let generalizeDecl (ident, t) = (ident,) <$> generalize (fromTypeToUType t) + let generalizeDecl (ident, t) = (ident,) <$> generalize (toUType t) generalizedDecls <- mapM generalizeDecl StdLib.typedDecls local (M.union (M.fromList generalizedDecls)) infer @@ -45,102 +46,95 @@ inferStatements :: [Statement] -> Infer UType inferStatements x = inferStatements' x (throwError Unreachable) inferStatements' :: [Statement] -> Infer UType -> Infer UType -inferStatements' [] pr = pr -inferStatements' ((StmtExpr e) : xs) _ = do +inferStatements' [] t = t +inferStatements' ((StmtExpr e) : stmts) _ = do res <- inferExpr e - inferStatements' xs (return res) -inferStatements' ((StmtDecl (DeclVar (ident, t) body)) : xs) _ = do - res <- inferExpr body - vType <- maybe (return res) ((=:=) res <$> fromTypeToUType) t - pvType <- generalize vType - withBinding ident pvType (inferStatements' xs $ return vType) -inferStatements' ((StmtDecl (DeclFun ident False fun)) : xs) _ = do - res <- inferFun fun - withBinding ident (Forall [] res) (inferStatements' xs $ return res) -inferStatements' ((StmtDecl (DeclFun ident True fun)) : xs) _ = do - preT <- fresh - next <- withBinding ident (Forall [] preT) $ inferFun fun - after <- withBinding ident (Forall [] next) $ inferFun fun - withBinding ident (Forall [] after) (inferStatements' xs $ return next) + inferStatements' stmts (return res) +inferStatements' ((StmtDecl (DeclVar (ident, t) val)) : stmts) _ = do + t' <- inferExpr val + t'' <- checkByAnnotation t' t + upt <- generalize t'' + withBinding ident upt $ inferStatements' stmts (return t'') +inferStatements' ((StmtDecl (DeclFun ident isRec fun)) : stmts) _ = do + funT <- + if isRec + then do + funT <- fresh + funT' <- withBinding ident (Forall [] funT) $ inferFun fun + withBinding ident (Forall [] funT') $ inferFun fun + else inferFun fun + funUT <- generalize funT + withBinding ident funUT $ inferStatements' stmts (return funT) inferExpr :: Expression -> Infer UType -inferExpr (ExprId x) = lookup (Var x) +inferExpr (ExprId ident) = lookup ident inferExpr (ExprPrimVal value) = case value of - PrimValUnit -> return UTyUnit - PrimValBool _ -> return UTyBool - PrimValInt _ -> return UTyInt + PrimValUnit -> return UTUnit + PrimValBool _ -> return UTBool + PrimValInt _ -> return UTInt inferExpr (ExprBinOp op lhs rhs) = do - utLhs <- inferExpr lhs - utRhs <- inferExpr rhs - withError (const $ ImpossibleBinOpApplication utLhs utRhs) $ do - ut <- utLhs =:= utRhs + lhsT <- inferExpr lhs + rhsT <- inferExpr rhs + withError (const $ ImpossibleBinOpApplication lhsT rhsT) $ do + valT <- lhsT =:= rhsT case op of - BoolOp _ -> ut =:= UTyBool - ArithOp _ -> ut =:= UTyInt - CompOp _ -> return UTyBool -inferExpr (ExprUnOp op x) = do - ut <- inferExpr x - withError (const $ ImpossibleUnOpApplication ut) $ case op of - UnMinusOp -> ut =:= UTyInt + BoolOp _ -> valT =:= UTBool + ArithOp _ -> valT =:= UTInt + CompOp _ -> return UTBool +inferExpr (ExprUnOp op val) = do + valT <- inferExpr val + withError (const $ ImpossibleUnOpApplication valT) $ case op of + UnMinusOp -> valT =:= UTInt inferExpr (ExprApp funExpr argExpr) = do - funUT <- inferExpr funExpr - argUT <- inferExpr argExpr - resUT <- fresh - _ <- funUT =:= UTyFun argUT resUT - return resUT + funT <- inferExpr funExpr + argT <- inferExpr argExpr + resT <- fresh + _ <- funT =:= UTFun argT resT + return resT inferExpr (ExprIte c t e) = do - _ <- check c UTyBool - t' <- inferExpr t - e' <- inferExpr e - t' =:= e' + _ <- check c UTBool + tT <- inferExpr t + eT <- inferExpr e + tT =:= eT inferExpr (ExprLetIn decl expr) = inferLetIn decl expr inferExpr (ExprFun fun) = inferFun fun inferLetIn :: Declaration -> Expression -> Infer UType -inferLetIn (DeclVar (x, Just pty) xdef) expr = do - let upty = toUPolytype (Forall [] $ toTypeF pty) - upty' <- skolemize upty - bl <- inferExpr xdef - _ <- bl =:= upty' - withBinding x upty $ inferExpr expr -inferLetIn (DeclVar (x, Nothing) xdef) expr = do - ty <- inferExpr xdef - pty <- generalize ty - withBinding x pty $ inferExpr expr -inferLetIn (DeclFun f False fun) expr = do - fdef <- inferFun fun - pfdef <- generalize fdef - withBinding f pfdef $ inferExpr expr -inferLetIn (DeclFun f True fun) expr = do - preT <- fresh - next <- withBinding f (Forall [] preT) $ inferFun fun - after <- withBinding f (Forall [] next) $ inferFun fun - inferredBlock <- withBinding f (Forall [] next) (inferExpr expr) - pfdef <- generalize after - withBinding f pfdef (return inferredBlock) +inferLetIn (DeclVar (ident, t) val) expr = do + t' <- inferExpr val + t'' <- checkByAnnotation t' t + upt <- generalize t'' + withBinding ident upt $ inferExpr expr +inferLetIn (DeclFun ident isRec fun) expr = do + funT <- + if isRec + then do + funT <- fresh + funT' <- withBinding ident (Forall [] funT) $ inferFun fun + withBinding ident (Forall [] funT') $ inferFun fun + else inferFun fun + funUT <- generalize funT + withBinding ident funUT $ inferExpr expr inferFun :: Fun -> Infer UType -inferFun (Fun args restype body) = inferFun' $ toList args +inferFun (Fun params resT body) = inferFun' $ toList params where - inferFun' args' = case args' of + inferFun' params' = case params' of [] -> do - inferredBody <- inferExpr body - case restype of - Just t -> fromTypeToUType t =:= inferredBody - Nothing -> return inferredBody - (ident, t) : ys -> do - t' <- maybe fresh (return . fromTypeToUType) t - withBinding ident (Forall [] t') $ UTyFun t' <$> inferFun' ys + bodyT <- inferExpr body + checkByAnnotation bodyT resT + (ident, t) : params'' -> do + t' <- maybe fresh (return . toUType) t + withBinding ident (Forall [] t') $ UTFun t' <$> inferFun' params'' --- Utils +-- ** Utils check :: Expression -> UType -> Infer UType -check e ty = do - ty' <- inferExpr e - ty =:= ty' - -withError :: MonadError e m => (e -> e) -> m a -> m a -withError f action = tryError action >>= either (throwError . f) pure - -tryError :: MonadError e m => m a -> m (Either e a) -tryError action = (Right <$> action) `catchError` (pure . Left) +check expr t = do + exprT <- inferExpr expr + t =:= exprT + +checkByAnnotation :: UType -> Maybe L.Type -> Infer UType +checkByAnnotation t ann = case ann of + Just annT -> toUType annT =:= t + Nothing -> return t diff --git a/miniml.cabal b/miniml.cabal index 38d61bc..1d4a74d 100644 --- a/miniml.cabal +++ b/miniml.cabal @@ -1,122 +1,120 @@ -cabal-version: 3.6 -name: mini-ml -version: 0.1.0.0 -synopsis: MiniML compiler -description: MiniML is a minimal dialect of ML (Meta Language). -homepage: https://github.com/AzimMuradov/miniml-compiler-haskell-spbu +cabal-version: 3.8 +name: mini-ml +version: 0.1.0.0 +synopsis: MiniML compiler +description: MiniML is a minimal dialect of ML (Meta Language). +homepage: https://github.com/AzimMuradov/miniml-compiler-haskell-spbu bug-reports: - https://github.com/AzimMuradov/miniml-compiler-haskell-spbu/issues + https://github.com/AzimMuradov/miniml-compiler-haskell-spbu/issues -license: MIT -license-file: LICENSE -author: Azim Muradov, Alexander Zadorozhnyy -maintainer: azim.muradov.dev@gmail.com, alexander.zadorozhnyy@yandex.ru -copyright: Copyright (c) 2023 Azim Muradov, Alexander Zadorozhnyy -category: Language +license: MIT +license-file: LICENSE +author: Azim Muradov, Alexander Zadorozhnyy +maintainer: azim.muradov.dev@gmail.com, alexander.zadorozhnyy@yandex.ru +copyright: Copyright (c) 2023 Azim Muradov, Alexander Zadorozhnyy +category: Language common shared-properties - default-language: Haskell2010 - build-depends: - , base >=4.14 - , bytestring >=0.11.2.0 - , extra >=1.7.12 - , text >=2.0.1 + default-language: Haskell2010 + build-depends: + , base >=4.7 && <5 + , bytestring >=0.11 && <0.12 + , extra >=1.7.12 + , text >=2.0.1 - ghc-options: - -Wall -Wcompat -Widentities -Wincomplete-uni-patterns - -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-uni-patterns + -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints library - import: shared-properties - exposed-modules: - CodeGen.Llvm.LlvmIrGen - CodeGen.Llvm.Runner - CodeGen.Module - CodeGen.RunResult - CodeGen.TimedValue - MonadUtils - Parser.Ast - Parser.Lexer - Parser.Parser - Parser.Utils - StdLib - Transformations.Anf.Anf - Transformations.Anf.AnfGen - Transformations.Anf.PrettyPrinter - Transformations.Cc.Cc - Transformations.Ll.Lfr - Transformations.Ll.Ll - Transformations.Relabeler.Relabeler - Transformations.Simplifier.SimplifiedAst - Transformations.Simplifier.Simplifier - Trees.Common - TypeChecker.HindleyMilner - TypeChecker.PrettyPrinter - TypeChecker.TypeChecker + import: shared-properties + exposed-modules: + CodeGen.Llvm.LlvmIrGen + CodeGen.Llvm.Runner + CodeGen.Module + CodeGen.RunResult + CodeGen.TimedValue + MonadUtils + Parser.Ast + Parser.Lexer + Parser.Parser + Parser.Utils + StdLib + Transformations.Anf.Anf + Transformations.Anf.AnfGen + Transformations.Anf.PrettyPrinter + Transformations.Cc.Cc + Transformations.Ll.Lfr + Transformations.Ll.Ll + Transformations.Relabeler.Relabeler + Transformations.Simplifier.SimplifiedAst + Transformations.Simplifier.Simplifier + Trees.Common + TypeChecker.HindleyMilner + TypeChecker.PrettyPrinter + TypeChecker.TypeChecker - other-modules: - other-extensions: - build-depends: - , containers >=0.6.6 - , directory - , file-embed - , llvm-hs >=9.0.1 - , llvm-hs-pretty >=0.9.0.0 - , llvm-hs-pure >=9.0.0 - , megaparsec >=9.2 - , mtl >=2.2.2 - , parser-combinators >=1.3.0 - , process - , recursion-schemes - , string-conversions - , string-transform - , transformers >=0.5.6 - , unification-fd >=0.5.0 - , unix + other-modules: + other-extensions: + build-depends: + , containers >=0.6.6 + , directory + , file-embed + , llvm-codegen + , megaparsec >=9.2 + , mtl >=2.3.0 + , parser-combinators >=1.3.0 + , process + , recursion-schemes + , string-conversions + , string-transform + , transformers >=0.5.6 + , unification-fd >=0.5.0 + , unix - hs-source-dirs: lib + hs-source-dirs: lib executable miniml - import: shared-properties - main-is: Main.hs - other-modules: - Commands.Compile - Commands.Run - Configuration.AppConfiguration - Configuration.Commands.Compile - Configuration.Commands.MiniMl - Configuration.Commands.Run - Configuration.CommonParsers - Utils + import: shared-properties + main-is: Main.hs + other-modules: + Commands.Compile + Commands.Run + Configuration.AppConfiguration + Configuration.Commands.Compile + Configuration.Commands.MiniMl + Configuration.Commands.Run + Configuration.CommonParsers + Utils - other-extensions: - build-depends: - , filepath - , mini-ml - , optparse-applicative >=0.18 + other-extensions: + build-depends: + , filepath + , mini-ml + , optparse-applicative >=0.18 - hs-source-dirs: app + hs-source-dirs: app test-suite tests - import: shared-properties - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Sample.AnfTest - Sample.FactorialTest - Sample.FibonacciTest - Sample.SimpleTest - Sample.Utils - Unit.Parser.ParserTest - Unit.StdLibTest - Unit.TypeInference.TypeInferenceTest - Utils + import: shared-properties + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Sample.AnfTest + Sample.FactorialTest + Sample.FibonacciTest + Sample.SimpleTest + Sample.Utils + Unit.Parser.ParserTest + Unit.StdLibTest + Unit.TypeInference.TypeInferenceTest + Utils - build-depends: - , mini-ml - , pretty-simple >=4.1.2.0 - , tasty >=1.5 - , tasty-golden >=2.3.5 - , tasty-hunit >=0.10.1 + build-depends: + , mini-ml + , pretty-simple >=4.1.2.0 + , tasty >=1.5 + , tasty-golden >=2.3.5 + , tasty-hunit >=0.10.1 - hs-source-dirs: test + hs-source-dirs: test diff --git a/test/Sample/Factorial/FacRec.ll b/test/Sample/Factorial/FacRec.ll index 7f968cd..120e740 100644 --- a/test/Sample/Factorial/FacRec.ll +++ b/test/Sample/Factorial/FacRec.ll @@ -1,61 +1,48 @@ -; ModuleID = 'unnamed' +declare external ccc i64 @not(i64) +declare external ccc i64 @print_bool(i64) - +declare external ccc i64 @print_int(i64) +declare external ccc i64 @miniml_div(i64, i64) -declare external ccc i64 @not(i64) +declare external ccc i64 @miniml_fun_to_paf(i64, i64) +declare external ccc i64 @miniml_apply(i64, i64) -declare external ccc i64 @print_bool(i64) - - -declare external ccc i64 @print_int(i64) - - -declare external ccc i64 @miniml_div(i64, i64) - - -declare external ccc i64 @miniml_fun_to_paf(i64, i64) - - -declare external ccc i64 @miniml_apply(i64, i64) - - -define external ccc i64 @factorial.1(i64 %n.2_0) { -;