From 45b6c9dae9dee5e62398e64367421a496aa00db0 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Tue, 23 Jan 2024 15:05:20 +0100 Subject: [PATCH 1/2] add the 'juvix dev tree compile' command --- app/Commands/Dev/Tree.hs | 2 + app/Commands/Dev/Tree/Compile.hs | 25 +++++++ app/Commands/Dev/Tree/Compile/Base.hs | 93 ++++++++++++++++++++++++ app/Commands/Dev/Tree/Compile/Options.hs | 23 ++++++ app/Commands/Dev/Tree/Options.hs | 12 +++ src/Juvix/Compiler/Pipeline.hs | 6 ++ 6 files changed, 161 insertions(+) create mode 100644 app/Commands/Dev/Tree/Compile.hs create mode 100644 app/Commands/Dev/Tree/Compile/Base.hs create mode 100644 app/Commands/Dev/Tree/Compile/Options.hs diff --git a/app/Commands/Dev/Tree.hs b/app/Commands/Dev/Tree.hs index 62005a1101..d8042f6f6e 100644 --- a/app/Commands/Dev/Tree.hs +++ b/app/Commands/Dev/Tree.hs @@ -1,6 +1,7 @@ module Commands.Dev.Tree where import Commands.Base +import Commands.Dev.Tree.Compile as Compile import Commands.Dev.Tree.Eval as Eval import Commands.Dev.Tree.FromAsm as FromAsm import Commands.Dev.Tree.Options @@ -9,5 +10,6 @@ import Commands.Dev.Tree.Read as Read runCommand :: forall r. (Members '[Embed IO, App, TaggedLock] r) => TreeCommand -> Sem r () runCommand = \case Eval opts -> Eval.runCommand opts + Compile opts -> Compile.runCommand opts Read opts -> Read.runCommand opts FromAsm opts -> FromAsm.runCommand opts diff --git a/app/Commands/Dev/Tree/Compile.hs b/app/Commands/Dev/Tree/Compile.hs new file mode 100644 index 0000000000..0073b25ff5 --- /dev/null +++ b/app/Commands/Dev/Tree/Compile.hs @@ -0,0 +1,25 @@ +module Commands.Dev.Tree.Compile where + +import Commands.Base +import Commands.Dev.Tree.Compile.Base +import Commands.Dev.Tree.Compile.Options +import Juvix.Compiler.Tree.Translation.FromSource qualified as Tree + +runCommand :: forall r. (Members '[Embed IO, App, TaggedLock] r) => CompileOptions -> Sem r () +runCommand opts = do + file <- getFile + s <- readFile (toFilePath file) + tab <- getRight (mapLeft JuvixError (Tree.runParser (toFilePath file) s)) + let arg = PipelineArg opts file tab + case opts ^. compileTarget of + TargetWasm32Wasi -> runCPipeline arg + TargetNative64 -> runCPipeline arg + TargetGeb -> return () + TargetVampIR -> return () + TargetCore -> return () + TargetAsm -> runAsmPipeline arg + TargetTree -> return () + TargetNockma -> runNockmaPipeline arg + where + getFile :: Sem r (Path Abs File) + getFile = getMainFile (opts ^. compileInputFile) diff --git a/app/Commands/Dev/Tree/Compile/Base.hs b/app/Commands/Dev/Tree/Compile/Base.hs new file mode 100644 index 0000000000..c640579287 --- /dev/null +++ b/app/Commands/Dev/Tree/Compile/Base.hs @@ -0,0 +1,93 @@ +module Commands.Dev.Tree.Compile.Base where + +import Commands.Base +import Commands.Dev.Tree.Compile.Options +import Commands.Extra.Compile qualified as Compile +import Juvix.Compiler.Asm.Pretty qualified as Asm +import Juvix.Compiler.Backend qualified as Backend +import Juvix.Compiler.Backend.C qualified as C +import Juvix.Compiler.Nockma.Pretty qualified as Nockma +import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree + +data PipelineArg = PipelineArg + { _pipelineArgOptions :: CompileOptions, + _pipelineArgFile :: Path Abs File, + _pipelineArgTable :: Tree.InfoTable + } + +getEntry :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r EntryPoint +getEntry PipelineArg {..} = do + ep <- getEntryPoint (AppPath (preFileFromAbs _pipelineArgFile) True) + return $ + ep + { _entryPointTarget = getTarget (_pipelineArgOptions ^. compileTarget), + _entryPointDebug = _pipelineArgOptions ^. compileDebug, + _entryPointUnsafe = _pipelineArgOptions ^. compileUnsafe, + _entryPointOptimizationLevel = fromMaybe defaultOptLevel (_pipelineArgOptions ^. compileOptimizationLevel), + _entryPointInliningDepth = _pipelineArgOptions ^. compileInliningDepth + } + where + getTarget :: CompileTarget -> Backend.Target + getTarget = \case + TargetWasm32Wasi -> Backend.TargetCWasm32Wasi + TargetNative64 -> Backend.TargetCNative64 + TargetGeb -> Backend.TargetGeb + TargetVampIR -> Backend.TargetVampIR + TargetCore -> Backend.TargetCore + TargetAsm -> Backend.TargetAsm + TargetTree -> Backend.TargetTree + TargetNockma -> Backend.TargetNockma + + defaultOptLevel :: Int + defaultOptLevel + | _pipelineArgOptions ^. compileDebug = 0 + | otherwise = defaultOptimizationLevel + +runCPipeline :: + forall r. + (Members '[Embed IO, App, TaggedLock] r) => + PipelineArg -> + Sem r () +runCPipeline pa@PipelineArg {..} = do + entryPoint <- getEntry pa + C.MiniCResult {..} <- getRight (run (runReader entryPoint (runError (treeToMiniC _pipelineArgTable :: Sem '[Error JuvixError, Reader EntryPoint] C.MiniCResult)))) + cFile <- inputCFile _pipelineArgFile + embed @IO (writeFile (toFilePath cFile) _resultCCode) + outfile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile + Compile.runCommand + _pipelineArgOptions + { _compileInputFile = Just (AppPath (preFileFromAbs cFile) False), + _compileOutputFile = Just (AppPath (preFileFromAbs outfile) False) + } + where + inputCFile :: Path Abs File -> Sem r (Path Abs File) + inputCFile inputFileCompile = do + buildDir <- askBuildDir + ensureDir buildDir + return (buildDir replaceExtension' ".c" (filename inputFileCompile)) + +runAsmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () +runAsmPipeline pa@PipelineArg {..} = do + entryPoint <- getEntry pa + asmFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile + r <- + runReader entryPoint + . runError @JuvixError + . treeToAsm + $ _pipelineArgTable + tab' <- getRight r + let code = Asm.ppPrint tab' tab' + embed @IO (writeFile (toFilePath asmFile) code) + +runNockmaPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () +runNockmaPipeline pa@PipelineArg {..} = do + entryPoint <- getEntry pa + nockmaFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile + r <- + runReader entryPoint + . runError @JuvixError + . treeToNockma + $ _pipelineArgTable + tab' <- getRight r + let code = Nockma.ppSerialize tab' + embed @IO (writeFile (toFilePath nockmaFile) code) diff --git a/app/Commands/Dev/Tree/Compile/Options.hs b/app/Commands/Dev/Tree/Compile/Options.hs new file mode 100644 index 0000000000..84885fd0ae --- /dev/null +++ b/app/Commands/Dev/Tree/Compile/Options.hs @@ -0,0 +1,23 @@ +module Commands.Dev.Tree.Compile.Options + ( module Commands.Dev.Tree.Compile.Options, + module Commands.Extra.Compile.Options, + ) +where + +import Commands.Extra.Compile.Options +import CommonOptions +import Data.List.NonEmpty qualified as NonEmpty + +treeSupportedTargets :: NonEmpty CompileTarget +treeSupportedTargets = + NonEmpty.fromList + [ TargetWasm32Wasi, + TargetNative64, + TargetAsm + ] + +parseTreeCompileOptions :: Parser CompileOptions +parseTreeCompileOptions = + parseCompileOptions + treeSupportedTargets + (parseInputFile FileExtJuvixTree) diff --git a/app/Commands/Dev/Tree/Options.hs b/app/Commands/Dev/Tree/Options.hs index 2faa628991..1f2da46cff 100644 --- a/app/Commands/Dev/Tree/Options.hs +++ b/app/Commands/Dev/Tree/Options.hs @@ -1,5 +1,6 @@ module Commands.Dev.Tree.Options where +import Commands.Dev.Tree.Compile.Options import Commands.Dev.Tree.Eval.Options import Commands.Dev.Tree.FromAsm.Options import Commands.Dev.Tree.Read.Options @@ -7,6 +8,7 @@ import CommonOptions data TreeCommand = Eval TreeEvalOptions + | Compile CompileOptions | Read TreeReadOptions | FromAsm TreeFromAsmOptions deriving stock (Data) @@ -16,6 +18,7 @@ parseTreeCommand = hsubparser $ mconcat [ commandEval, + commandCompile, commandRead, commandFromAsm ] @@ -23,6 +26,9 @@ parseTreeCommand = commandEval :: Mod CommandFields TreeCommand commandEval = command "eval" evalInfo + commandCompile :: Mod CommandFields TreeCommand + commandCompile = command "compile" compileInfo + commandRead :: Mod CommandFields TreeCommand commandRead = command "read" readInfo @@ -35,6 +41,12 @@ parseTreeCommand = (Eval <$> parseTreeEvalOptions) (progDesc "Evaluate a JuvixTree file") + compileInfo :: ParserInfo TreeCommand + compileInfo = + info + (Compile <$> parseTreeCompileOptions) + (progDesc "Compile a JuvixTree file") + readInfo :: ParserInfo TreeCommand readInfo = info diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 29b115740c..05de506ba6 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -179,6 +179,12 @@ coreToVampIR' = Core.toStored' >=> storedCoreToVampIR' treeToAsm :: Tree.InfoTable -> Sem r Asm.InfoTable treeToAsm = return . Asm.fromTree +treeToNockma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r (Nockma.Cell Natural) +treeToNockma = treeToAsm >=> asmToNockma + +treeToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r C.MiniCResult +treeToMiniC = treeToAsm >=> asmToMiniC + asmToNockma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r (Nockma.Cell Natural) asmToNockma = Asm.toNockma >=> mapReader Nockma.fromEntryPoint . Nockma.fromAsmTable From 368772adbfbacc6a39cd40765da3d29179572153 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 26 Jan 2024 11:10:29 +0100 Subject: [PATCH 2/2] style changes --- app/Commands/Dev/Tree/Compile/Base.hs | 7 ++++++- app/Commands/Dev/Tree/Compile/Options.hs | 3 +-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/app/Commands/Dev/Tree/Compile/Base.hs b/app/Commands/Dev/Tree/Compile/Base.hs index c640579287..3595673649 100644 --- a/app/Commands/Dev/Tree/Compile/Base.hs +++ b/app/Commands/Dev/Tree/Compile/Base.hs @@ -50,7 +50,12 @@ runCPipeline :: Sem r () runCPipeline pa@PipelineArg {..} = do entryPoint <- getEntry pa - C.MiniCResult {..} <- getRight (run (runReader entryPoint (runError (treeToMiniC _pipelineArgTable :: Sem '[Error JuvixError, Reader EntryPoint] C.MiniCResult)))) + C.MiniCResult {..} <- + getRight + . run + . runReader entryPoint + . runError @JuvixError + $ treeToMiniC _pipelineArgTable cFile <- inputCFile _pipelineArgFile embed @IO (writeFile (toFilePath cFile) _resultCCode) outfile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile diff --git a/app/Commands/Dev/Tree/Compile/Options.hs b/app/Commands/Dev/Tree/Compile/Options.hs index 84885fd0ae..4b18273a97 100644 --- a/app/Commands/Dev/Tree/Compile/Options.hs +++ b/app/Commands/Dev/Tree/Compile/Options.hs @@ -6,11 +6,10 @@ where import Commands.Extra.Compile.Options import CommonOptions -import Data.List.NonEmpty qualified as NonEmpty treeSupportedTargets :: NonEmpty CompileTarget treeSupportedTargets = - NonEmpty.fromList + nonEmpty' [ TargetWasm32Wasi, TargetNative64, TargetAsm