anoma/juvix
1
1
Fork 0
mirror of https://github.com/anoma/juvix.git synced 2024-07-15 03:40:41 +03:00
Code Issues Projects Releases Wiki Activity

JuvixReg to CASM translation (#2671)

Browse Source 
* Closes #2562 

Checklist
---------

- [x] Translation from JuvixReg to CASM
- [x] CASM runtime
- [x] Juvix to CASM pipeline: combine the right transformations and
check prerequisites
- [x] CLI commands: add target `casm` to the `compile` commands
- [x] Tests:
   - [x] Test the translation from JuvixReg to CASM
   - [x] Test the entire pipeline from Juvix to CASM
This commit is contained in:
Łukasz Czajka 2024-03-20 12:14:12 +01:00 committed by GitHub
parent b615fde186
commit 0f713c7c84
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
254 changed files with 6140 additions and 160 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
app/Commands/Compile.hs
View File

@ -29,6 +29,7 @@ runCommand opts@CompileOptions {..} = do
TargetReg -> Compile.runRegPipeline arg
TargetNockma -> Compile.runNockmaPipeline arg
TargetAnoma -> Compile.runAnomaPipeline arg
TargetCasm -> Compile.runCasmPipeline arg
writeCoreFile :: (Members '[EmbedIO, App, TaggedLock] r) => Compile.PipelineArg -> Sem r ()
writeCoreFile pa@Compile.PipelineArg {..} = do

13
app/Commands/Dev/Asm/Compile.hs
View File

@ -6,7 +6,10 @@ import Commands.Extra.Compile qualified as Compile
import Juvix.Compiler.Asm.Translation.FromSource qualified as Asm
import Juvix.Compiler.Backend qualified as Backend
import Juvix.Compiler.Backend.C qualified as C
import Juvix.Compiler.Casm.Data.Result qualified as Casm
import Juvix.Compiler.Casm.Pretty qualified as Casm
import Juvix.Compiler.Reg.Pretty qualified as Reg
import Juvix.Prelude.Pretty
runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock] r) => AsmCompileOptions -> Sem r ()
runCommand opts = do
@ -34,6 +37,15 @@ runCommand opts = do
tab' <- getRight r
let code = Reg.ppPrint tab' tab'
writeFileEnsureLn regFile code
TargetCasm -> do
casmFile <- Compile.outputFile opts file
r <-
runReader entryPoint
. runError @JuvixError
. asmToCasm
$ tab
Casm.Result {..} <- getRight r
writeFileEnsureLn casmFile (toPlainText $ Casm.ppProgram _resultCode)
_ ->
case run $ runReader entryPoint $ runError $ asmToMiniC tab of
Left err -> exitJuvixError err
@ -57,6 +69,7 @@ runCommand opts = do
TargetWasm32Wasi -> return Backend.TargetCWasm32Wasi
TargetNative64 -> return Backend.TargetCNative64
TargetReg -> return Backend.TargetReg
TargetCasm -> return Backend.TargetCairo
TargetNockma -> err "Nockma"
TargetAnoma -> err "Anoma"
TargetTree -> err "JuvixTree"

3
app/Commands/Dev/Asm/Compile/Options.hs
View File

@ -15,7 +15,8 @@ asmSupportedTargets =
NonEmpty.fromList
[ TargetWasm32Wasi,
TargetNative64,
TargetReg
TargetReg,
TargetCasm
]
parseAsmCompileOptions :: Parser AsmCompileOptions

1
app/Commands/Dev/Core/Compile.hs
View File

@ -23,6 +23,7 @@ runCommand opts = do
TargetTree -> runTreePipeline arg
TargetNockma -> runNockmaPipeline arg
TargetAnoma -> runAnomaPipeline arg
TargetCasm -> runCasmPipeline arg
where
getFile :: Sem r (Path Abs File)
getFile = getMainFile (opts ^. compileInputFile)

16
app/Commands/Dev/Core/Compile/Base.hs
View File

@ -8,11 +8,14 @@ import Juvix.Compiler.Backend qualified as Backend
import Juvix.Compiler.Backend.C qualified as C
import Juvix.Compiler.Backend.Geb qualified as Geb
import Juvix.Compiler.Backend.VampIR.Translation qualified as VampIR
import Juvix.Compiler.Casm.Data.Result qualified as Casm
import Juvix.Compiler.Casm.Pretty qualified as Casm
import Juvix.Compiler.Core.Data.Module qualified as Core
import Juvix.Compiler.Core.Data.TransformationId qualified as Core
import Juvix.Compiler.Nockma.Pretty qualified as Nockma
import Juvix.Compiler.Reg.Pretty qualified as Reg
import Juvix.Compiler.Tree.Pretty qualified as Tree
import Juvix.Prelude.Pretty
import System.FilePath (takeBaseName)
data PipelineArg = PipelineArg
@ -45,6 +48,7 @@ getEntry PipelineArg {..} = do
TargetTree -> Backend.TargetTree
TargetNockma -> Backend.TargetNockma
TargetAnoma -> Backend.TargetAnoma
TargetCasm -> Backend.TargetCairo
defaultOptLevel :: Int
defaultOptLevel
@ -168,3 +172,15 @@ runAnomaPipeline pa@PipelineArg {..} = do
tab' <- getRight r
let code = Nockma.ppSerialize tab'
writeFileEnsureLn nockmaFile code
runCasmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
runCasmPipeline pa@PipelineArg {..} = do
entryPoint <- getEntry pa
casmFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
r <-
runReader entryPoint
. runError @JuvixError
. coreToCasm
$ _pipelineArgModule
Casm.Result {..} <- getRight r
writeFileEnsureLn casmFile (toPlainText $ Casm.ppProgram _resultCode)

3
app/Commands/Dev/Core/Compile/Options.hs
View File

@ -19,7 +19,8 @@ coreSupportedTargets =
TargetVampIR,
TargetTree,
TargetAsm,
TargetReg
TargetReg,
TargetCasm
]
parseCoreCompileOptions :: Parser CoreCompileOptions

2
app/Commands/Dev/Reg.hs
View File

@ -1,11 +1,13 @@
module Commands.Dev.Reg where
import Commands.Base
import Commands.Dev.Reg.Compile as Compile
import Commands.Dev.Reg.Options
import Commands.Dev.Reg.Read as Read
import Commands.Dev.Reg.Run as Run
runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock] r) => RegCommand -> Sem r ()
runCommand = \case
Compile opts -> Compile.runCommand opts
Run opts -> Run.runCommand opts
Read opts -> Read.runCommand opts

79
app/Commands/Dev/Reg/Compile.hs Normal file
View File

@ -0,0 +1,79 @@
module Commands.Dev.Reg.Compile where
import Commands.Base
import Commands.Dev.Reg.Compile.Options
import Commands.Extra.Compile qualified as Compile
import Juvix.Compiler.Backend qualified as Backend
import Juvix.Compiler.Backend.C qualified as C
import Juvix.Compiler.Casm.Data.Result qualified as Casm
import Juvix.Compiler.Casm.Pretty qualified as Casm
import Juvix.Compiler.Reg.Translation.FromSource qualified as Reg
import Juvix.Prelude.Pretty
runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock] r) => CompileOptions -> Sem r ()
runCommand opts = do
file <- getFile
s <- readFile file
case Reg.runParser file s of
Left err -> exitJuvixError (JuvixError err)
Right tab -> do
ep <- getEntryPoint (AppPath (preFileFromAbs file) True)
tgt <- getTarget (opts ^. compileTarget)
let entryPoint :: EntryPoint
entryPoint =
ep
{ _entryPointTarget = tgt,
_entryPointDebug = opts ^. compileDebug
}
case opts ^. compileTarget of
TargetCasm -> do
casmFile <- Compile.outputFile opts file
r <-
runReader entryPoint
. runError @JuvixError
. regToCasm
$ tab
Casm.Result {..} <- getRight r
writeFileEnsureLn casmFile (toPlainText $ Casm.ppProgram _resultCode)
_ ->
case run $ runReader entryPoint $ runError $ regToMiniC tab of
Left err -> exitJuvixError err
Right C.MiniCResult {..} -> do
buildDir <- askBuildDir
ensureDir buildDir
cFile <- inputCFile file
writeFileEnsureLn cFile _resultCCode
outfile <- Compile.outputFile opts file
Compile.runCommand
opts
{ _compileInputFile = Just (AppPath (preFileFromAbs cFile) False),
_compileOutputFile = Just (AppPath (preFileFromAbs outfile) False)
}
where
getFile :: Sem r (Path Abs File)
getFile = getMainFile (opts ^. compileInputFile)
getTarget :: CompileTarget -> Sem r Backend.Target
getTarget = \case
TargetWasm32Wasi -> return Backend.TargetCWasm32Wasi
TargetNative64 -> return Backend.TargetCNative64
TargetCasm -> return Backend.TargetCairo
TargetReg -> err "JuvixReg"
TargetNockma -> err "Nockma"
TargetAnoma -> err "Anoma"
TargetTree -> err "JuvixTree"
TargetGeb -> err "GEB"
TargetVampIR -> err "VampIR"
TargetCore -> err "JuvixCore"
TargetAsm -> err "JuvixAsm"
where
err :: Text -> Sem r a
err tgt = exitMsg (ExitFailure 1) ("error: " <> tgt <> " target not supported for JuvixReg")
inputCFile :: (Members '[App] r) => Path Abs File -> Sem r (Path Abs File)
inputCFile inputFileCompile = do
buildDir <- askBuildDir
return (buildDir <//> outputMiniCFile)
where
outputMiniCFile :: Path Rel File
outputMiniCFile = replaceExtension' ".c" (filename inputFileCompile)

23
app/Commands/Dev/Reg/Compile/Options.hs Normal file
View File

@ -0,0 +1,23 @@
module Commands.Dev.Reg.Compile.Options
( module Commands.Dev.Reg.Compile.Options,
module Commands.Extra.Compile.Options,
)
where
import Commands.Extra.Compile.Options
import CommonOptions
import Data.List.NonEmpty qualified as NonEmpty
regSupportedTargets :: NonEmpty CompileTarget
regSupportedTargets =
NonEmpty.fromList
[ TargetWasm32Wasi,
TargetNative64,
TargetCasm
]
parseRegCompileOptions :: Parser CompileOptions
parseRegCompileOptions =
parseCompileOptions
regSupportedTargets
(parseInputFile FileExtJuvixReg)

16
app/Commands/Dev/Reg/Options.hs
View File

@ -1,11 +1,13 @@
module Commands.Dev.Reg.Options where
import Commands.Dev.Reg.Compile.Options
import Commands.Dev.Reg.Read.Options
import Commands.Dev.Reg.Run.Options
import CommonOptions
data RegCommand
= Run RegRunOptions
= Compile CompileOptions
| Run RegRunOptions
| Read RegReadOptions
deriving stock (Data)
@ -13,16 +15,26 @@ parseRegCommand :: Parser RegCommand
parseRegCommand =
hsubparser $
mconcat
[ commandRun,
[ commandCompile,
commandRun,
commandRead
]
where
commandCompile :: Mod CommandFields RegCommand
commandCompile = command "compile" compileInfo
commandRun :: Mod CommandFields RegCommand
commandRun = command "run" runInfo
commandRead :: Mod CommandFields RegCommand
commandRead = command "read" readInfo
compileInfo :: ParserInfo RegCommand
compileInfo =
info
(Compile <$> parseRegCompileOptions)
(progDesc "Compile a JuvixReg file")
runInfo :: ParserInfo RegCommand
runInfo =
info

1
app/Commands/Dev/Tree/Compile.hs
View File

@ -22,6 +22,7 @@ runCommand opts = do
TargetTree -> return ()
TargetNockma -> runNockmaPipeline arg
TargetAnoma -> runAnomaPipeline arg
TargetCasm -> runCasmPipeline arg
where
getFile :: Sem r (Path Abs File)
getFile = getMainFile (opts ^. compileInputFile)

16
app/Commands/Dev/Tree/Compile/Base.hs
View File

@ -6,9 +6,12 @@ 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.Casm.Data.Result qualified as Casm
import Juvix.Compiler.Casm.Pretty qualified as Casm
import Juvix.Compiler.Nockma.Pretty qualified as Nockma
import Juvix.Compiler.Reg.Pretty qualified as Reg
import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree
import Juvix.Prelude.Pretty
data PipelineArg = PipelineArg
{ _pipelineArgOptions :: CompileOptions,
@ -40,6 +43,7 @@ getEntry PipelineArg {..} = do
TargetTree -> Backend.TargetTree
TargetNockma -> Backend.TargetNockma
TargetAnoma -> Backend.TargetAnoma
TargetCasm -> Backend.TargetCairo
defaultOptLevel :: Int
defaultOptLevel
@ -125,3 +129,15 @@ runAnomaPipeline pa@PipelineArg {..} = do
tab' <- getRight r
let code = Nockma.ppSerialize tab'
writeFileEnsureLn nockmaFile code
runCasmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
runCasmPipeline pa@PipelineArg {..} = do
entryPoint <- getEntry pa
casmFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
r <-
runReader entryPoint
. runError @JuvixError
. treeToCasm
$ _pipelineArgTable
Casm.Result {..} <- getRight r
writeFileEnsureLn casmFile (toPlainText $ Casm.ppProgram _resultCode)

3
app/Commands/Dev/Tree/Compile/Options.hs
View File

@ -14,7 +14,8 @@ treeSupportedTargets =
TargetNative64,
TargetAsm,
TargetReg,
TargetNockma
TargetNockma,
TargetCasm
]
parseTreeCompileOptions :: Parser CompileOptions

4
app/Commands/Extra/Compile.hs
View File

@ -37,6 +37,7 @@ runCompile inputFile o = do
TargetTree -> return (Right ())
TargetNockma -> return (Right ())
TargetAnoma -> return (Right ())
TargetCasm -> return (Right ())
prepareRuntime :: forall r. (Members '[App, EmbedIO] r) => Path Abs Dir -> CompileOptions -> Sem r ()
prepareRuntime buildDir o = do
@ -56,6 +57,7 @@ prepareRuntime buildDir o = do
TargetTree -> return ()
TargetNockma -> return ()
TargetAnoma -> return ()
TargetCasm -> return ()
where
wasiReleaseRuntime :: BS.ByteString
wasiReleaseRuntime = $(FE.makeRelativeToProject "runtime/_build.wasm32-wasi/libjuvix.a" >>= FE.embedFile)
@ -121,6 +123,8 @@ outputFile opts inputFile =
replaceExtension' nockmaFileExt baseOutputFile
TargetAnoma ->
replaceExtension' nockmaFileExt baseOutputFile
TargetCasm ->
replaceExtension' casmFileExt baseOutputFile
clangNativeCompile ::
forall r.

2
app/Commands/Extra/Compile/Options.hs
View File

@ -15,6 +15,7 @@ data CompileTarget
| TargetTree
| TargetNockma
| TargetAnoma
| TargetCasm
deriving stock (Eq, Data, Bounded, Enum)
instance Show CompileTarget where
@ -29,6 +30,7 @@ instance Show CompileTarget where
TargetTree -> "tree"
TargetNockma -> "nockma"
TargetAnoma -> "anoma"
TargetCasm -> "casm"
data CompileOptions = CompileOptions
{ _compileDebug :: Bool,

6
cntlines.sh
View File

@ -11,8 +11,9 @@ function count_ext () {
RUNTIME_C=$(count runtime/src/juvix)
RUNTIME_VAMPIR=$(count_ext '*.pir' runtime/src/vampir)
RUNTIME_JVT=$(count_ext '*.jvt' runtime/src/tree)
RUNTIME_CASM=$(count_ext '*.casm' runtime/src/casm)
RUNTIME=$((RUNTIME_C+RUNTIME_VAMPIR+RUNTIME_JVT))
RUNTIME=$((RUNTIME_C+RUNTIME_VAMPIR+RUNTIME_JVT+RUNTIME_CASM))
BACKENDC=$(count src/Juvix/Compiler/Backend/C/)
CAIRO=$(count src/Juvix/Compiler/Backend/Cairo/)
@ -62,6 +63,7 @@ echo " JuvixCore: $CORE LOC"
echo "Runtime: $RUNTIME LOC"
echo " C runtime: $RUNTIME_C LOC"
echo " JuvixTree runtime: $RUNTIME_JVT LOC"
echo " Cairo assembly runtime: $RUNTIME_CASM LOC"
echo " VampIR runtime: $RUNTIME_VAMPIR LOC"
echo "Other: $OTHER LOC"
echo " Application: $APP LOC"
@ -72,4 +74,4 @@ echo " Data: $DATA LOC"
echo " Prelude: $PRELUDE LOC"
echo "Tests: $TESTS LOC"
echo ""
echo "Total: $TOTAL Haskell LOC + $RUNTIME_C C LOC + $RUNTIME_JVT JuvixTree LOC + $RUNTIME_VAMPIR VampIR LOC"
echo "Total: $TOTAL Haskell LOC + $RUNTIME_C C LOC + $RUNTIME_JVT JuvixTree LOC + $RUNTIME_CASM CASM LOC + $RUNTIME_VAMPIR VampIR LOC"

1
package.yaml
View File

@ -40,6 +40,7 @@ extra-source-files:
- runtime/**/*.a
- runtime/src/tree/*.jvt
- runtime/src/vampir/*.pir
- runtime/src/casm/*.casm
dependencies:
- aeson-better-errors == 0.9.*

99
runtime/src/casm/stdlib.casm Normal file
View File

@ -0,0 +1,99 @@
-- Juvix runtime for Cairo assembly
-- Closure layout: [ addr | 9 - sargs | 9 - argsnum | arguments... ]
-- sargs -- number of arguments stored in the closure
-- argsnum -- number of arguments left
-- sargs + argsnum = total numer of arguments for the function
-- Maximum number of function arguments: 8
-- after calling juvix_get_regs:
-- [ap - 4] == fp
-- [ap - 3] == pc
-- [ap - 2] == ap - 2
juvix_get_regs:
call juvix_get_ap_reg
ret
juvix_get_ap_reg:
ret
-- [fp - 3]: closure; [fp - 3 - k]: argument k to closure call
juvix_call_closure:
ap += 1
-- closure addr
[fp] = [[fp - 3]]
-- jmp rel (9 - argsnum)
jmp rel [[fp - 3] + 2]
[ap] = [fp - 11]; ap++
[ap] = [fp - 10]; ap++
[ap] = [fp - 9]; ap++
[ap] = [fp - 8]; ap++
[ap] = [fp - 7]; ap++
[ap] = [fp - 6]; ap++
[ap] = [fp - 5]; ap++
[ap] = [fp - 4]; ap++
-- jmp rel (9 - sargs)
jmp rel [[fp - 3] + 1]
[ap] = [[fp - 3] + 10]; ap++
[ap] = [[fp - 3] + 9]; ap++
[ap] = [[fp - 3] + 8]; ap++
[ap] = [[fp - 3] + 7]; ap++
[ap] = [[fp - 3] + 6]; ap++
[ap] = [[fp - 3] + 5]; ap++
[ap] = [[fp - 3] + 4]; ap++
[ap] = [[fp - 3] + 3]; ap++
call [fp]
ret
-- [fp - 3]: closure
-- [fp - 4]: n = the number of arguments to extend with
-- [fp - 4 - k]: argument n - k - 1 (reverse order!)
juvix_extend_closure:
ap += 6
-- 9 - sargs
[fp + 1] = [[fp - 3] + 1]
-- 9 - argsnum (expected)
[fp + 2] = [[fp - 3] + 2]
[fp + 3] = 9
-- [fp + 4] = sargs
[fp + 4] = [fp + 3] - [fp + 1]
-- [fp + 5] = 9 - n
[fp + 5] = [fp + 3] - [fp - 4]
-- copy stored args reversing them
jmp rel [fp + 1]
[ap] = [[fp - 3] + 10]; ap++
[ap] = [[fp - 3] + 9]; ap++
[ap] = [[fp - 3] + 8]; ap++
[ap] = [[fp - 3] + 7]; ap++
[ap] = [[fp - 3] + 6]; ap++
[ap] = [[fp - 3] + 5]; ap++
[ap] = [[fp - 3] + 4]; ap++
[ap] = [[fp - 3] + 3]; ap++
call juvix_get_regs
[fp] = [ap - 2] + 2
-- closure header
[ap] = [[fp - 3]]; ap++
[ap] = [fp + 1] - [fp - 4]; ap++
[ap] = [fp + 2] + [fp - 4]; ap++
-- copy stored args: jmp rel (9 - sargs)
jmp rel [fp + 1]
[ap] = [fp + 13]; ap++
[ap] = [fp + 12]; ap++
[ap] = [fp + 11]; ap++
[ap] = [fp + 10]; ap++
[ap] = [fp + 9]; ap++
[ap] = [fp + 8]; ap++
[ap] = [fp + 7]; ap++
[ap] = [fp + 6]; ap++
-- copy extra args: jmp rel (9 - extra args num)
jmp rel [fp + 5]
[ap] = [fp - 12]; ap++
[ap] = [fp - 11]; ap++
[ap] = [fp - 10]; ap++
[ap] = [fp - 9]; ap++
[ap] = [fp - 8]; ap++
[ap] = [fp - 7]; ap++
[ap] = [fp - 6]; ap++
[ap] = [fp - 5]; ap++
-- return value
[ap] = [fp]; ap++
ret

11
src/Juvix/Compiler/Asm/Interpreter.hs
View File

@ -156,18 +156,9 @@ runCodeR infoTable funInfo = goCode (funInfo ^. functionCode) >> popLastValueSta
goUnop :: (Member Runtime r) => (Val -> Either Text Val) -> Sem r ()
goUnop op = goUnop' (eitherToError . op)
getConstantVal :: Constant -> Val
getConstantVal = \case
ConstInt i -> ValInteger i
ConstField f -> ValField f
ConstBool b -> ValBool b
ConstString s -> ValString s
ConstUnit -> ValUnit
ConstVoid -> ValVoid
getVal :: (Member Runtime r) => Value -> Sem r Val
getVal = \case
Constant c -> return (getConstantVal c)
Constant c -> return (constantToValue c)
Ref r -> getMemVal r
getMemVal :: forall r. (Member Runtime r) => MemRef -> Sem r Val

16
src/Juvix/Compiler/Backend.hs
View File

@ -14,6 +14,7 @@ data Target
| TargetTree
| TargetNockma
| TargetAnoma
| TargetCairo
deriving stock (Data, Eq, Show)
data Limits = Limits
@ -97,6 +98,21 @@ getLimits tgt debug = case tgt of
defaultLimits
TargetAnoma ->
defaultLimits
TargetCairo ->
Limits
{ _limitsMaxConstrs = 1048568,
_limitsMaxConstrArgs = 255,
_limitsMaxFunctionArgs = 8,
_limitsMaxLocalVars = 2048,
_limitsMaxClosureSize = 8 + 3,
_limitsClosureHeadSize = 3,
_limitsMaxStringSize = 0,
_limitsMaxStackDelta = 0, -- irrelevant
_limitsMaxFunctionAlloc = 0, -- irrelevant
_limitsDispatchStackSize = 0, -- irrelevant
_limitsBuiltinUIDsNum = 8,
_limitsSpecialisedApply = 3
}
defaultLimits :: Limits
defaultLimits =

5
src/Juvix/Compiler/Casm/Data/LabelInfoBuilder.hs
View File

@ -29,6 +29,11 @@ emptyBuilderState =
_stateIdents = mempty
}
runLabelInfoBuilderWithNextId :: Word -> Sem (LabelInfoBuilder ': r) a -> Sem r (LabelInfo, a)
runLabelInfoBuilderWithNextId nextSymId =
fmap (first (^. stateLabelInfo))
. runLabelInfoBuilder' emptyBuilderState {_stateNextSymbolId = nextSymId}
runLabelInfoBuilder :: Sem (LabelInfoBuilder ': r) a -> Sem r (LabelInfo, a)
runLabelInfoBuilder = fmap (first (^. stateLabelInfo)) . runLabelInfoBuilder' emptyBuilderState

16
src/Juvix/Compiler/Casm/Data/Limits.hs Normal file
View File

@ -0,0 +1,16 @@
module Juvix.Compiler.Casm.Data.Limits where
import Juvix.Compiler.Backend
import Juvix.Compiler.Casm.Language
casmMaxFunctionArgs :: Int
casmMaxFunctionArgs = getLimits TargetCairo False ^. limitsMaxFunctionArgs
casmClosureAddrOffset :: Offset
casmClosureAddrOffset = 0
casmClosureStoredArgsOffset :: Offset
casmClosureStoredArgsOffset = 1
casmClosureArgsNumOffset :: Offset
casmClosureArgsNumOffset = 2

11
src/Juvix/Compiler/Casm/Data/Result.hs Normal file
View File

@ -0,0 +1,11 @@
module Juvix.Compiler.Casm.Data.Result where
import Juvix.Compiler.Casm.Data.LabelInfo
import Juvix.Compiler.Casm.Language
data Result = Result
{ _resultLabelInfo :: LabelInfo,
_resultCode :: [Instruction]
}
makeLenses ''Result

107
src/Juvix/Compiler/Casm/Extra/Base.hs Normal file
View File

@ -0,0 +1,107 @@
module Juvix.Compiler.Casm.Extra.Base where
import Juvix.Compiler.Casm.Data.Limits
import Juvix.Compiler.Casm.Language
toOffset :: (Show a, Integral a) => a -> Offset
toOffset x
| fromIntegral v == x = v
| otherwise = error ("invalid offset: " <> show x)
where
v = fromIntegral x
adjustAp :: Int16 -> MemRef -> MemRef
adjustAp idx mr@MemRef {..} = case _memRefReg of
Ap -> MemRef Ap (_memRefOff - idx)
Fp -> mr
mkExtraBinop :: ExtraOpcode -> MemRef -> MemRef -> Value -> Instruction
mkExtraBinop op res arg1 arg2 =
ExtraBinop
InstrExtraBinop
{ _instrExtraBinopOpcode = op,
_instrExtraBinopResult = res,
_instrExtraBinopArg1 = arg1,
_instrExtraBinopArg2 = arg2,
_instrExtraBinopIncAp = False
}
mkNativeBinop :: Opcode -> MemRef -> MemRef -> Value -> Instruction
mkNativeBinop op res arg1 arg2 =
Assign
InstrAssign
{ _instrAssignResult = res,
_instrAssignValue =
Binop
BinopValue
{ _binopValueOpcode = op,
_binopValueArg1 = arg1,
_binopValueArg2 = arg2
},
_instrAssignIncAp = False
}
mkEq :: MemRef -> MemRef -> Value -> Instruction
mkEq res arg1 arg2 = mkExtraBinop FieldSub res arg1 arg2
mkIntLe :: MemRef -> MemRef -> Value -> [Instruction]
mkIntLe res arg1 arg2 = case arg2 of
Imm v ->
[mkExtraBinop IntLt res arg1 (Imm (v + 1))]
Ref mref ->
[inc, mkExtraBinop IntLt res (adjustAp 1 arg1) (Ref $ MemRef Ap (-1))]
where
inc =
Assign
InstrAssign
{ _instrAssignResult = MemRef Ap 0,
_instrAssignValue =
Binop
BinopValue
{ _binopValueArg1 = mref,
_binopValueArg2 = Imm 1,
_binopValueOpcode = FieldAdd
},
_instrAssignIncAp = True
}
Lab {} -> impossible
mkAssign :: MemRef -> RValue -> Instruction
mkAssign mr rv =
Assign
InstrAssign
{ _instrAssignResult = mr,
_instrAssignValue = rv,
_instrAssignIncAp = False
}
mkAssignAp :: RValue -> Instruction
mkAssignAp v =
Assign
InstrAssign
{ _instrAssignResult = MemRef Ap 0,
_instrAssignValue = v,
_instrAssignIncAp = True
}
mkOpArgsNum :: MemRef -> MemRef -> [Instruction]
mkOpArgsNum res v =
[ mkAssignAp (Val $ Imm $ fromIntegral casmMaxFunctionArgs + 1),
mkAssignAp (Load $ LoadValue (adjustAp 1 v) casmClosureArgsNumOffset),
mkExtraBinop FieldSub res (MemRef Ap (-2)) (Ref $ MemRef Ap (-1))
]
mkCall :: Value -> Instruction
mkCall = Call . InstrCall
mkJump :: RValue -> Instruction
mkJump tgt = Jump (InstrJump tgt False False)
mkJumpIf :: Value -> MemRef -> Instruction
mkJumpIf tgt v = JumpIf (InstrJumpIf tgt v False False)
mkJumpRel :: RValue -> Instruction
mkJumpRel tgt = Jump (InstrJump tgt True False)
mkJumpRelIf :: Value -> MemRef -> Instruction
mkJumpRelIf tgt v = JumpIf (InstrJumpIf tgt v True False)

32
src/Juvix/Compiler/Casm/Extra/Stdlib.hs Normal file
View File

@ -0,0 +1,32 @@
module Juvix.Compiler.Casm.Extra.Stdlib where
import Data.FileEmbed qualified as FE
import Data.Text.Encoding
import Juvix.Compiler.Casm.Data.LabelInfoBuilder
import Juvix.Compiler.Casm.Language
import Juvix.Compiler.Casm.Translation.FromSource
data StdlibBuiltins = StdlibBuiltins
{ _stdlibGetRegs :: Symbol,
_stdlibCallClosure :: Symbol,
_stdlibExtendClosure :: Symbol,
_stdlibGetRegsName :: Text,
_stdlibCallClosureName :: Text,
_stdlibExtendClosureName :: Text
}
makeLenses ''StdlibBuiltins
addStdlibBuiltins :: (Member LabelInfoBuilder r) => Address -> Sem r (StdlibBuiltins, [Instruction])
addStdlibBuiltins addr = do
instrs <-
fmap (fromRight impossible) $
runParser' addr "stdlib.casm" $
decodeUtf8 $(FE.makeRelativeToProject "runtime/src/casm/stdlib.casm" >>= FE.embedFile)
let _stdlibGetRegsName :: Text = "juvix_get_regs"
_stdlibCallClosureName :: Text = "juvix_call_closure"
_stdlibExtendClosureName :: Text = "juvix_extend_closure"
_stdlibGetRegs <- fromJust <$> getIdent _stdlibGetRegsName
_stdlibCallClosure <- fromJust <$> getIdent _stdlibCallClosureName
_stdlibExtendClosure <- fromJust <$> getIdent _stdlibExtendClosureName
return (StdlibBuiltins {..}, instrs)

29
src/Juvix/Compiler/Casm/Interpreter.hs
View File

@ -19,9 +19,12 @@ import Juvix.Data.Field
type Memory s = MV.MVector s (Maybe FField)
-- | Runs Cairo Assembly. Returns the value of `[ap - 1]` at program exit.
runCode :: LabelInfo -> [Instruction] -> FField
runCode (LabelInfo labelInfo) instrs0 = runST goCode
runCode = hRunCode stderr
-- | Runs Cairo Assembly. Returns the value of `[ap - 1]` at program exit.
hRunCode :: Handle -> LabelInfo -> [Instruction] -> FField
hRunCode hout (LabelInfo labelInfo) instrs0 = runST goCode
where
instrs :: Vec.Vector Instruction
instrs = Vec.fromList instrs0
@ -48,6 +51,8 @@ runCode (LabelInfo labelInfo) instrs0 = runST goCode
when (Vec.length instrs < pc) $
throwRunError ("invalid program counter: " <> show pc)
checkGaps mem
when (ap == 0) $
throwRunError "nothing to return"
readMem mem (ap - 1)
| otherwise =
case instrs Vec.! pc of
@ -55,7 +60,6 @@ runCode (LabelInfo labelInfo) instrs0 = runST goCode
ExtraBinop x -> goExtraBinop x pc ap fp mem
Jump x -> goJump x pc ap fp mem
JumpIf x -> goJumpIf x pc ap fp mem
JumpRel x -> goJumpRel x pc ap fp mem
Call x -> goCall x pc ap fp mem
Return -> goReturn pc ap fp mem
Alloc x -> goAlloc x pc ap fp mem
@ -182,7 +186,7 @@ runCode (LabelInfo labelInfo) instrs0 = runST goCode
IntMod -> fieldFromInteger fsize (fieldToInt x `rem` fieldToInt y)
IntLt ->
fieldFromInteger fsize $
if fieldToInt x < fieldToInt y then 1 else 0
if fieldToInt x < fieldToInt y then 0 else 1
fieldToInt :: FField -> Integer
fieldToInt f
@ -192,20 +196,17 @@ runCode (LabelInfo labelInfo) instrs0 = runST goCode
v = fieldToInteger f
goJump :: InstrJump -> Address -> Address -> Address -> Memory s -> ST s FField
goJump InstrJump {..} _ ap fp mem = do
tgt <- readValue ap fp mem _instrJumpTarget
go (fromInteger (fieldToInteger tgt)) (ap + fromEnum _instrJumpIncAp) fp mem
goJump InstrJump {..} pc ap fp mem = do
tgt <- readRValue ap fp mem _instrJumpTarget
let off = if _instrJumpRel then pc else 0
go (off + fromInteger (fieldToInteger tgt)) (ap + fromEnum _instrJumpIncAp) fp mem
goJumpIf :: InstrJumpIf -> Address -> Address -> Address -> Memory s -> ST s FField
goJumpIf InstrJumpIf {..} pc ap fp mem = do
tgt <- readValue ap fp mem _instrJumpIfTarget
v <- readMemRef ap fp mem _instrJumpIfValue
go (if fieldToInteger v /= 0 then fromInteger (fieldToInteger tgt) else pc + 1) (ap + fromEnum _instrJumpIfIncAp) fp mem
goJumpRel :: InstrJumpRel -> Address -> Address -> Address -> Memory s -> ST s FField
goJumpRel InstrJumpRel {..} pc ap fp mem = do
tgt <- readRValue ap fp mem _instrJumpRelTarget
go (pc + fromInteger (fieldToInteger tgt)) (ap + fromEnum _instrJumpRelIncAp) fp mem
let off = if _instrJumpIfRel then pc else 0
go (if fieldToInteger v /= 0 then off + fromInteger (fieldToInteger tgt) else pc + 1) (ap + fromEnum _instrJumpIfIncAp) fp mem
goCall :: InstrCall -> Address -> Address -> Address -> Memory s -> ST s FField
goCall InstrCall {..} pc ap fp mem = do
@ -228,7 +229,7 @@ runCode (LabelInfo labelInfo) instrs0 = runST goCode
goTrace :: InstrTrace -> Address -> Address -> Address -> Memory s -> ST s FField
goTrace InstrTrace {..} pc ap fp mem = do
v <- readRValue ap fp mem _instrTraceValue
GHC.unsafePerformIO (print v >> return (pure ()))
GHC.unsafePerformIO (hPrint hout v >> return (pure ()))
go (pc + 1) ap fp mem
catchRunErrorIO :: a -> IO (Either CasmError a)

25
src/Juvix/Compiler/Casm/Language.hs
View File

@ -7,10 +7,11 @@ where
{-
This module defines data structures for an extended subset of the Cairo Assembly
language, following Section 5 of [1]. Except the `ExtraBinop` instruction, all
instructions correspond to the instructions from [1]. The parser and pretty
printer implemented in `Juvix.Compiler.Casm.Translation.FromSource` and
`Juvix.Compiler.Casm.Pretty` follow the syntax of [1, Section 5].
language, following Section 5 of [1]. Except for the `ExtraBinop` instruction
and absolute conditional jumps, all instructions correspond to the instructions
from [1]. The parser and pretty printer implemented in
`Juvix.Compiler.Casm.Translation.FromSource` and `Juvix.Compiler.Casm.Pretty`
follow the syntax of [1, Section 5].
[1] Goldberg, Papini, Riabzev: "Cairo – a Turing-complete STARK-friendly CPU
architecture" (https://ia.cr/2021/1063)
@ -78,7 +79,7 @@ data ExtraOpcode
| IntMul
| IntDiv
| IntMod
| -- | Sets the result to 1 if arg1 < arg2, or to 0 otherwise
| -- | Sets the result to zero if arg1 < arg2, or to non-zero otherwise
IntLt
data Instruction
@ -88,7 +89,6 @@ data Instruction
ExtraBinop InstrExtraBinop
| Jump InstrJump
| JumpIf InstrJumpIf
| JumpRel InstrJumpRel
| Call InstrCall
| Return
| Alloc InstrAlloc
@ -110,22 +110,20 @@ data InstrExtraBinop = InstrExtraBinop
}
data InstrJump = InstrJump
{ _instrJumpTarget :: Value,
{ _instrJumpTarget :: RValue,
_instrJumpRel :: Bool,
_instrJumpIncAp :: Bool
}
-- | Jump if value is nonzero
-- | Jump if value is nonzero. Boolean true is translated to zero, false to
-- non-zero.
data InstrJumpIf = InstrJumpIf
{ _instrJumpIfTarget :: Value,
_instrJumpIfValue :: MemRef,
_instrJumpIfRel :: Bool,
_instrJumpIfIncAp :: Bool
}
data InstrJumpRel = InstrJumpRel
{ _instrJumpRelTarget :: RValue,
_instrJumpRelIncAp :: Bool
}
newtype InstrCall = InstrCall
{ _instrCallTarget :: Value
}
@ -148,7 +146,6 @@ makeLenses ''InstrAssign
makeLenses ''InstrExtraBinop
makeLenses ''InstrJump
makeLenses ''InstrJumpIf
makeLenses ''InstrJumpRel
makeLenses ''InstrCall
makeLenses ''InstrAlloc
makeLenses ''InstrTrace

13
src/Juvix/Compiler/Casm/Pretty/Base.hs
View File

@ -116,20 +116,16 @@ instance PrettyCode InstrJump where
ppCode InstrJump {..} = do
tgt <- ppCode _instrJumpTarget
incAp <- ppIncAp _instrJumpIncAp
return $ Str.jmp <+> tgt <> incAp
let rel = if _instrJumpRel then Str.rel <> space else mempty
return $ Str.jmp <+> rel <> tgt <> incAp
instance PrettyCode InstrJumpIf where
ppCode InstrJumpIf {..} = do
tgt <- ppCode _instrJumpIfTarget
v <- ppCode _instrJumpIfValue
incAp <- ppIncAp _instrJumpIfIncAp
return $ Str.jmp <+> tgt <+> Str.if_ <+> v <+> Str.notequal <+> annotate AnnLiteralInteger "0" <> incAp
instance PrettyCode InstrJumpRel where
ppCode InstrJumpRel {..} = do
tgt <- ppCode _instrJumpRelTarget
incAp <- ppIncAp _instrJumpRelIncAp
return $ Str.jmp <+> Str.rel <+> tgt <> incAp
let rel = if _instrJumpIfRel then Str.rel <> space else mempty
return $ Str.jmp <+> rel <> tgt <+> Str.if_ <+> v <+> Str.notequal <+> annotate AnnLiteralInteger "0" <> incAp
instance PrettyCode InstrCall where
ppCode InstrCall {..} = do
@ -152,7 +148,6 @@ instance PrettyCode Instruction where
ExtraBinop x -> ppCode x
Jump x -> ppCode x
JumpIf x -> ppCode x
JumpRel x -> ppCode x
Call x -> ppCode x
Return -> return Str.ret
Alloc x -> ppCode x

376
src/Juvix/Compiler/Casm/Translation/FromReg.hs
View File

@ -1 +1,377 @@
module Juvix.Compiler.Casm.Translation.FromReg where
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Juvix.Compiler.Backend
import Juvix.Compiler.Casm.Data.LabelInfoBuilder
import Juvix.Compiler.Casm.Data.Limits
import Juvix.Compiler.Casm.Data.Result
import Juvix.Compiler.Casm.Extra.Base
import Juvix.Compiler.Casm.Extra.Stdlib
import Juvix.Compiler.Casm.Language
import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg
import Juvix.Compiler.Reg.Extra.Info qualified as Reg
import Juvix.Compiler.Reg.Language qualified as Reg
import Juvix.Compiler.Tree.Evaluator.Builtins qualified as Reg
import Juvix.Data.Field
fromReg :: Reg.InfoTable -> Result
fromReg tab = uncurry Result $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolId tab) $ do
let initialOffset :: Int = 2
(blts, binstrs) <- addStdlibBuiltins initialOffset
endSym <- freshSymbol
let endName :: Text = "__juvix_end"
endLab = LabelRef endSym (Just endName)
(addr, instrs) <- second (concat . reverse) <$> foldM (goFun blts endLab) (initialOffset + length binstrs, []) (tab ^. Reg.infoFunctions)
eassert (addr == length instrs + length binstrs + initialOffset)
registerLabelName endSym endName
registerLabelAddress endSym addr
let mainSym = fromJust $ tab ^. Reg.infoMainFunction
mainName = fromJust (HashMap.lookup mainSym (tab ^. Reg.infoFunctions)) ^. Reg.functionName
callInstr = Call $ InstrCall $ Lab $ LabelRef mainSym (Just mainName)
jmpInstr = mkJump (Val $ Lab endLab)
return $ callInstr : jmpInstr : binstrs ++ instrs ++ [Label endLab]
where
info :: Reg.ExtraInfo
info = Reg.computeExtraInfo (getLimits TargetCairo False) tab
getTagId :: Tag -> Int
getTagId tag =
1 + fromJust (HashMap.lookup tag (info ^. Reg.extraInfoCIDs))
goFun :: forall r. (Member LabelInfoBuilder r) => StdlibBuiltins -> LabelRef -> (Address, [[Instruction]]) -> Reg.FunctionInfo -> Sem r (Address, [[Instruction]])
goFun blts failLab (addr0, acc) funInfo = do
let sym = funInfo ^. Reg.functionSymbol
funName = funInfo ^. Reg.functionName
registerLabelName sym funName
registerLabelAddress sym addr0
let lab = Label $ LabelRef sym (Just funName)
code = funInfo ^. Reg.functionCode
n = fromJust $ HashMap.lookup (funInfo ^. Reg.functionSymbol) (info ^. Reg.extraInfoLocalVarsNum)
i1 = Alloc $ InstrAlloc $ Val $ Imm $ fromIntegral n
pre = [lab, i1]
addr1 = addr0 + length pre
instrs <- goCode addr1 code
return (addr1 + length instrs, (pre ++ instrs) : acc)
where
unsupported :: Text -> a
unsupported what = error ("Cairo backend: unsupported: " <> what)
goCode :: Address -> Reg.Code -> Sem r [Instruction]
goCode addr code = concat . reverse . snd <$> foldM go' (addr, []) code
where
go' :: (Address, [[Instruction]]) -> Reg.Instruction -> Sem r (Address, [[Instruction]])
go' (addr', acc') i = do
is <- goInstr addr' i
return (addr' + length is, is : acc')
goInstr :: Address -> Reg.Instruction -> Sem r [Instruction]
goInstr addr = \case
Reg.Binop x -> goBinop addr x
Reg.Unop x -> goUnop addr x
Reg.Assign x -> goAssign addr x
Reg.Alloc x -> goAlloc addr x
Reg.AllocClosure x -> goAllocClosure addr x
Reg.ExtendClosure x -> goExtendClosure addr x
Reg.Call x -> goCall addr x
Reg.TailCall x -> goTailCall addr x
Reg.CallClosures {} -> impossible
Reg.TailCallClosures {} -> impossible
Reg.Return x -> goReturn addr x
Reg.Branch x -> goBranch addr x
Reg.Case x -> goCase addr x
Reg.Trace x -> goTrace addr x
Reg.Dump -> unsupported "dump"
Reg.Failure x -> goFail addr x
Reg.Prealloc {} -> return []
Reg.Nop -> return []
Reg.Block x -> goBlock addr x
goConst :: Reg.Constant -> Integer
goConst = \case
Reg.ConstInt x -> x
Reg.ConstBool True -> 0
Reg.ConstBool False -> 1
Reg.ConstField f -> fieldToInteger f
Reg.ConstUnit -> 0
Reg.ConstVoid -> 0
Reg.ConstString {} -> unsupported "strings"
goConstrField :: Reg.ConstrField -> RValue
goConstrField Reg.ConstrField {..} =
Load $ LoadValue (goVarRef _constrFieldRef) (toOffset _constrFieldIndex + 1)
goVarRef :: Reg.VarRef -> MemRef
goVarRef Reg.VarRef {..} = case _varRefGroup of
Reg.VarGroupArgs ->
MemRef Fp (-3 - toOffset _varRefIndex)
Reg.VarGroupLocal ->
MemRef Fp (toOffset _varRefIndex)
goValue :: Reg.Value -> ([Instruction], Value)
goValue = \case
Reg.Const c -> ([], Imm $ goConst c)
Reg.CRef x -> ([mkAssignAp (goConstrField x)], Ref $ MemRef Ap (-1))
Reg.VRef x -> ([], Ref $ goVarRef x)
goRValue :: Reg.Value -> RValue
goRValue = \case
Reg.Const c -> Val $ Imm $ goConst c
Reg.CRef x -> goConstrField x
Reg.VRef x -> Val $ Ref $ goVarRef x
goLoad :: Reg.Value -> Offset -> ([Instruction], RValue)
goLoad v off = case goRValue v of
Val (Ref r) -> ([], Load $ LoadValue r off)
v' -> ([mkAssignAp v'], Load $ LoadValue (MemRef Ap (-1)) off)
goAssignValue :: MemRef -> Reg.Value -> Instruction
goAssignValue res = mkAssign res . goRValue
goAssignApValue :: Reg.Value -> Instruction
goAssignApValue = mkAssignAp . goRValue
mkBinop :: Reg.BinaryOp -> MemRef -> MemRef -> Value -> [Instruction]
mkBinop op res arg1 arg2 = case op of
Reg.OpIntAdd ->
[mkExtraBinop IntAdd res arg1 arg2]
Reg.OpIntSub ->
[mkExtraBinop IntSub res arg1 arg2]
Reg.OpIntMul ->
[mkExtraBinop IntMul res arg1 arg2]
Reg.OpIntDiv ->
[mkExtraBinop IntDiv res arg1 arg2]
Reg.OpIntMod ->
[mkExtraBinop IntMod res arg1 arg2]
Reg.OpIntLt ->
[mkExtraBinop IntLt res arg1 arg2]
Reg.OpIntLe ->
mkIntLe res arg1 arg2
Reg.OpFieldAdd ->
[mkNativeBinop FieldAdd res arg1 arg2]
Reg.OpFieldSub ->
[mkExtraBinop FieldSub res arg1 arg2]
Reg.OpFieldMul ->
[mkNativeBinop FieldMul res arg1 arg2]
Reg.OpFieldDiv ->
[mkExtraBinop FieldDiv res arg1 arg2]
Reg.OpEq ->
[mkEq res arg1 arg2]
Reg.OpStrConcat ->
unsupported "strings"
goBinop :: Address -> Reg.InstrBinop -> Sem r [Instruction]
goBinop addr x@Reg.InstrBinop {..} = case _instrBinopArg1 of
Reg.Const c1 -> case _instrBinopArg2 of
Reg.Const c2 -> case Reg.evalBinop' _instrBinopOpcode c1 c2 of
Left err -> error err
Right c ->
return [mkAssign res (Val $ Imm $ goConst c)]
_ ->
goBinop
addr
x
{ Reg._instrBinopArg1 = _instrBinopArg2,
Reg._instrBinopArg2 = _instrBinopArg1
}
Reg.CRef ctr1 ->
case _instrBinopArg2 of
Reg.CRef {} ->
return $ i : is2 ++ mkBinop _instrBinopOpcode res (MemRef Ap (-2)) (Ref $ MemRef Ap (-1))
_ -> do
eassert (null is2)
return $ i : mkBinop _instrBinopOpcode res (MemRef Ap (-1)) v2
where
i = mkAssignAp (goConstrField ctr1)
Reg.VRef var1 ->
return $ is2 ++ mkBinop _instrBinopOpcode res (goVarRef var1) v2
where
res = goVarRef _instrBinopResult
(is2, v2) = goValue _instrBinopArg2
goUnop :: Address -> Reg.InstrUnop -> Sem r [Instruction]
goUnop _ Reg.InstrUnop {..} = case _instrUnopOpcode of
Reg.OpShow -> unsupported "strings"
Reg.OpStrToInt -> unsupported "strings"
Reg.OpFieldToInt -> return [goAssignValue res _instrUnopArg]
Reg.OpIntToField -> return [goAssignValue res _instrUnopArg]
Reg.OpArgsNum -> case v of
Ref mr ->
return $ is ++ mkOpArgsNum res mr
Imm {} -> impossible
Lab {} -> impossible
where
res = goVarRef _instrUnopResult
(is, v) = goValue _instrUnopArg
goAssign :: Address -> Reg.InstrAssign -> Sem r [Instruction]
goAssign _ Reg.InstrAssign {..} =
return [goAssignValue res _instrAssignValue]
where
res = goVarRef _instrAssignResult
mkAllocCall :: MemRef -> [Instruction]
mkAllocCall res =
[ mkCall $ Lab $ LabelRef (blts ^. stdlibGetRegs) (Just (blts ^. stdlibGetRegsName)),
mkNativeBinop FieldAdd res (MemRef Ap (-2)) (Imm 2)
]
goAlloc :: Address -> Reg.InstrAlloc -> Sem r [Instruction]
goAlloc _ Reg.InstrAlloc {..} =
return $
mkAllocCall res
++ [ mkAssignAp (Val $ Imm $ fromIntegral tagId)
]
++ map goAssignApValue _instrAllocArgs
where
res = goVarRef _instrAllocResult
tagId = getTagId _instrAllocTag
goAllocClosure :: Address -> Reg.InstrAllocClosure -> Sem r [Instruction]
goAllocClosure _ Reg.InstrAllocClosure {..} =
return $
mkAllocCall res
++ [ mkAssignAp (Val $ Lab $ LabelRef _instrAllocClosureSymbol (Just funName)),
mkAssignAp (Val $ Imm $ fromIntegral $ casmMaxFunctionArgs + 1 - storedArgsNum),
mkAssignAp (Val $ Imm $ fromIntegral $ casmMaxFunctionArgs + 1 - leftArgsNum)
]
++ map goAssignApValue _instrAllocClosureArgs
where
res = goVarRef _instrAllocClosureResult
funName = Reg.lookupFunInfo tab _instrAllocClosureSymbol ^. Reg.functionName
storedArgsNum = length _instrAllocClosureArgs
leftArgsNum = _instrAllocClosureExpectedArgsNum - storedArgsNum
goExtendClosure :: Address -> Reg.InstrExtendClosure -> Sem r [Instruction]
goExtendClosure _ Reg.InstrExtendClosure {..} =
return $
map goAssignApValue _instrExtendClosureArgs
++ [ mkAssignAp (Val $ Imm $ fromIntegral $ length _instrExtendClosureArgs),
mkAssignAp (Val $ Ref val),
mkCall $ Lab $ LabelRef (blts ^. stdlibExtendClosure) (Just (blts ^. stdlibExtendClosureName)),
mkAssign res (Val $ Ref $ MemRef Ap (-1))
]
where
res = goVarRef _instrExtendClosureResult
val = goVarRef _instrExtendClosureValue
goCall' :: Instruction -> Reg.CallType -> [Reg.Value] -> [Instruction]
goCall' saveOrRet ct args = case ct of
Reg.CallFun sym ->
args'
++ [ mkCall $ Lab $ LabelRef sym (Just funName),
saveOrRet
]
where
funName = Reg.lookupFunInfo tab sym ^. Reg.functionName
Reg.CallClosure cl ->
args'
++ [ mkAssignAp (Val $ Ref $ goVarRef cl),
mkCall $ Lab $ LabelRef (blts ^. stdlibCallClosure) (Just (blts ^. stdlibCallClosureName)),
saveOrRet
]
where
args' = map goAssignApValue (reverse args)
goCall :: Address -> Reg.InstrCall -> Sem r [Instruction]
goCall _ Reg.InstrCall {..} =
return $
goCall' (mkAssign res (Val $ Ref $ MemRef Ap (-1))) _instrCallType _instrCallArgs
where
res = goVarRef _instrCallResult
-- There is no way to make "proper" tail calls in Cairo, because
-- the only way to set the `fp` register is via the `call` instruction.
-- So we just translate tail calls into `call` followed by `ret`.
goTailCall :: Address -> Reg.InstrTailCall -> Sem r [Instruction]
goTailCall _ Reg.InstrTailCall {..} =
return $
goCall' Return _instrTailCallType _instrTailCallArgs
goReturn :: Address -> Reg.InstrReturn -> Sem r [Instruction]
goReturn _ Reg.InstrReturn {..} =
return $
[ goAssignApValue _instrReturnValue,
Return
]
goBranch :: Address -> Reg.InstrBranch -> Sem r [Instruction]
goBranch addr Reg.InstrBranch {..} = case v of
Imm c
| c == 0 -> goCode addr _instrBranchTrue
| otherwise -> goCode addr _instrBranchFalse
Ref r -> do
symFalse <- freshSymbol
symEnd <- freshSymbol
let labFalse = LabelRef symFalse Nothing
labEnd = LabelRef symEnd Nothing
addr1 = addr + length is + 1
codeTrue <- goCode addr1 _instrBranchTrue
let addr2 = addr1 + length codeTrue + 1
registerLabelAddress symFalse addr2
codeFalse <- goCode (addr2 + 1) _instrBranchFalse
registerLabelAddress symEnd (addr2 + 1 + length codeFalse)
return $
is
++ [mkJumpIf (Lab labFalse) r]
++ codeTrue
++ [ mkJump (Val $ Lab labEnd),
Label labFalse
]
++ codeFalse
++ [Label labEnd]
Lab {} -> impossible
where
(is, v) = goValue _instrBranchValue
goCase :: Address -> Reg.InstrCase -> Sem r [Instruction]
goCase addr Reg.InstrCase {..} = do
syms <- replicateM (length tags) freshSymbol
symEnd <- freshSymbol
let symMap = HashMap.fromList $ zip tags syms
labs = map (flip LabelRef Nothing) syms
labEnd = LabelRef symEnd Nothing
jmps = map (mkJump . Val . Lab) labs
addr1 = addr + length is + 1 + length jmps
(addr2, instrs) <- second (concat . reverse) <$> foldM (goCaseBranch symMap labEnd) (addr1, []) _instrCaseBranches
(addr3, instrs') <- second reverse <$> foldM (goDefaultLabel symMap) (addr2, []) defaultTags
instrs'' <- maybe (return []) (goCode addr3) _instrCaseDefault
let addr4 = addr3 + length instrs''
registerLabelAddress symEnd addr4
return $ is ++ mkJumpRel v : jmps ++ instrs ++ instrs' ++ instrs'' ++ [Label labEnd]
where
(is, v) = goLoad _instrCaseValue 0
tags = Reg.lookupInductiveInfo tab _instrCaseInductive ^. Reg.inductiveConstructors
ctrTags = HashSet.fromList $ map (^. Reg.caseBranchTag) _instrCaseBranches
defaultTags = filter (not . flip HashSet.member ctrTags) tags
goCaseBranch :: HashMap Tag Symbol -> LabelRef -> (Address, [[Instruction]]) -> Reg.CaseBranch -> Sem r (Address, [[Instruction]])
goCaseBranch symMap labEnd (addr', acc') Reg.CaseBranch {..} = do
let sym = fromJust $ HashMap.lookup _caseBranchTag symMap
lab = LabelRef sym Nothing
registerLabelAddress sym addr'
instrs <- goCode (addr' + 1) _caseBranchCode
let instrs' = Label lab : instrs ++ [mkJump (Val $ Lab labEnd)]
return (addr' + length instrs', instrs' : acc')
goDefaultLabel :: HashMap Tag Symbol -> (Address, [Instruction]) -> Reg.Tag -> Sem r (Address, [Instruction])
goDefaultLabel symMap (addr', acc') tag = do
let sym = fromJust $ HashMap.lookup tag symMap
lab = LabelRef sym Nothing
registerLabelAddress sym addr'
return (addr' + 1, Label lab : acc')
goTrace :: Address -> Reg.InstrTrace -> Sem r [Instruction]
goTrace _ Reg.InstrTrace {..} =
return [Trace (InstrTrace (goRValue _instrTraceValue))]
goFail :: Address -> Reg.InstrFailure -> Sem r [Instruction]
goFail _ Reg.InstrFailure {..} =
return
[ Trace (InstrTrace (goRValue _instrFailureValue)),
mkJump (Val $ Lab failLab)
]
goBlock :: Address -> Reg.InstrBlock -> Sem r [Instruction]
goBlock addr Reg.InstrBlock {..} =
goCode addr _instrBlockCode

71
src/Juvix/Compiler/Casm/Translation/FromSource.hs
View File

@ -14,13 +14,20 @@ parseText = runParser noFile
runParser :: Path Abs File -> Text -> Either MegaparsecError (LabelInfo, [Instruction])
runParser fileName input_ =
case run . runLabelInfoBuilder $ P.runParserT parseToplevel (toFilePath fileName) input_ of
(_, Left err) -> Left (MegaparsecError err)
case run . runLabelInfoBuilder $ runParser' 0 (toFilePath fileName) input_ of
(_, Left err) -> Left err
(li, Right instrs) -> Right (li, instrs)
parseToplevel :: (Member LabelInfoBuilder r) => ParsecS r [Instruction]
parseToplevel = do
instrs <- statements 0
runParser' :: (Member LabelInfoBuilder r) => Address -> FilePath -> Text -> Sem r (Either MegaparsecError [Instruction])
runParser' addr fileName input_ = do
e <- P.runParserT (parseToplevel addr) fileName input_
return $ case e of
Left err -> Left (MegaparsecError err)
Right instrs -> Right instrs
parseToplevel :: (Member LabelInfoBuilder r) => Address -> ParsecS r [Instruction]
parseToplevel addr = do
instrs <- statements addr
P.eof
return instrs
@ -160,44 +167,38 @@ parseIncAp = (kw delimSemicolon >> kw kwApPlusPlus >> return True) <|> return Fa
parseJump :: forall r. (Member LabelInfoBuilder r) => ParsecS r Instruction
parseJump = do
kw kwJmp
relJmp <|> jmp
P.try jmpIf <|> jmp
where
relJmp :: ParsecS r Instruction
relJmp = do
kw kwRel
tgt <- parseRValue
jmpIf :: ParsecS r Instruction
jmpIf = do
isRel <- isJust <$> optional (kw kwRel)
tgt <- parseValue
kw kwIf
v <- parseMemRef
kw kwNotEq
symbol "0"
incAp <- parseIncAp
return $
JumpRel $
InstrJumpRel
{ _instrJumpRelTarget = tgt,
_instrJumpRelIncAp = incAp
JumpIf $
InstrJumpIf
{ _instrJumpIfTarget = tgt,
_instrJumpIfValue = v,
_instrJumpIfRel = isRel,
_instrJumpIfIncAp = incAp
}
jmp :: ParsecS r Instruction
jmp = do
tgt <- parseValue
mv <- optional if_
isRel <- isJust <$> optional (kw kwRel)
tgt <- parseRValue
incAp <- parseIncAp
case mv of
Nothing ->
return $ Jump $ InstrJump {_instrJumpTarget = tgt, _instrJumpIncAp = incAp}
Just v ->
return $
JumpIf $
InstrJumpIf
{ _instrJumpIfTarget = tgt,
_instrJumpIfValue = v,
_instrJumpIfIncAp = incAp
}
where
if_ :: ParsecS r MemRef
if_ = do
kw kwIf
v <- parseMemRef
kw kwNotEq
symbol "0"
return v
return $
Jump $
InstrJump
{ _instrJumpTarget = tgt,
_instrJumpRel = isRel,
_instrJumpIncAp = incAp
}
parseCall :: (Member LabelInfoBuilder r) => ParsecS r Instruction
parseCall = do

6
src/Juvix/Compiler/Casm/Validate.hs
View File

@ -15,7 +15,6 @@ validate labi instrs = mapM_ go instrs
ExtraBinop x -> goExtraBinop x
Jump x -> goJump x
JumpIf x -> goJumpIf x
JumpRel x -> goJumpRel x
Call x -> goCall x
Return -> return ()
Alloc x -> goAlloc x
@ -52,14 +51,11 @@ validate labi instrs = mapM_ go instrs
goExtraBinop InstrExtraBinop {..} = goValue _instrExtraBinopArg2
goJump :: InstrJump -> Either CasmError ()
goJump InstrJump {..} = goValue _instrJumpTarget
goJump InstrJump {..} = goRValue _instrJumpTarget
goJumpIf :: InstrJumpIf -> Either CasmError ()
goJumpIf InstrJumpIf {..} = goValue _instrJumpIfTarget
goJumpRel :: InstrJumpRel -> Either CasmError ()
goJumpRel InstrJumpRel {..} = goRValue _instrJumpRelTarget
goCall :: InstrCall -> Either CasmError ()
goCall InstrCall {..} = goValue _instrCallTarget

2
src/Juvix/Compiler/Core/Data/TransformationId.hs
View File

@ -25,6 +25,7 @@ data TransformationId
| CheckExec
| CheckVampIR
| CheckAnoma
| CheckCairo
| Normalize
| LetFolding
| LambdaFolding
@ -99,6 +100,7 @@ instance TransformationId' TransformationId where
CheckExec -> strCheckExec
CheckVampIR -> strCheckVampIR
CheckAnoma -> strCheckAnoma
CheckCairo -> strCheckCairo
Normalize -> strNormalize
LetFolding -> strLetFolding
LambdaFolding -> strLambdaFolding

3
src/Juvix/Compiler/Core/Data/TransformationId/Strings.hs
View File

@ -83,6 +83,9 @@ strCheckVampIR = "check-vampir"
strCheckAnoma :: Text
strCheckAnoma = "check-anoma"
strCheckCairo :: Text
strCheckCairo = "check-cairo"
strNormalize :: Text
strNormalize = "normalize"

2
src/Juvix/Compiler/Core/Transformation.hs
View File

@ -14,6 +14,7 @@ import Juvix.Compiler.Core.Error
import Juvix.Compiler.Core.Options
import Juvix.Compiler.Core.Transformation.Base
import Juvix.Compiler.Core.Transformation.Check.Anoma
import Juvix.Compiler.Core.Transformation.Check.Cairo
import Juvix.Compiler.Core.Transformation.Check.Exec
import Juvix.Compiler.Core.Transformation.Check.Geb
import Juvix.Compiler.Core.Transformation.Check.VampIR
@ -77,6 +78,7 @@ applyTransformations ts tbl = foldM (flip appTrans) tbl ts
CheckExec -> mapError (JuvixError @CoreError) . checkExec
CheckVampIR -> mapError (JuvixError @CoreError) . checkVampIR
CheckAnoma -> mapError (JuvixError @CoreError) . checkAnoma
CheckCairo -> mapError (JuvixError @CoreError) . checkCairo
Normalize -> normalize
LetFolding -> return . letFolding
LambdaFolding -> return . lambdaFolding

13
src/Juvix/Compiler/Core/Transformation/Check/Cairo.hs Normal file
View File

@ -0,0 +1,13 @@
module Juvix.Compiler.Core.Transformation.Check.Cairo where
import Juvix.Compiler.Core.Error
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Transformation.Base
import Juvix.Compiler.Core.Transformation.Check.Base
checkCairo :: forall r. (Member (Error CoreError) r) => Module -> Sem r Module
checkCairo md = do
checkMainExists md
checkNoAxioms md
mapAllNodesM checkNoIO md
mapAllNodesM (checkBuiltins' [OpStrConcat, OpStrToInt, OpShow] [PrimString]) md

27
src/Juvix/Compiler/Pipeline.hs
View File

@ -16,6 +16,8 @@ import Juvix.Compiler.Backend qualified as Backend
import Juvix.Compiler.Backend.C qualified as C
import Juvix.Compiler.Backend.Geb qualified as Geb
import Juvix.Compiler.Backend.VampIR.Translation qualified as VampIR
import Juvix.Compiler.Casm.Data.Result qualified as Casm
import Juvix.Compiler.Casm.Translation.FromReg qualified as Casm
import Juvix.Compiler.Concrete.Data.Highlight.Input
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Translation.FromParsed qualified as Scoper
@ -42,6 +44,7 @@ import Juvix.Compiler.Tree qualified as Tree
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.Process
import Juvix.Data.Effect.TaggedLock
import Juvix.Data.Field
type PipelineAppEffects = '[TaggedLock, EmbedIO, Resource, Final IO]
@ -101,6 +104,12 @@ upToAsm ::
upToAsm =
upToStoredCore >>= \Core.CoreResult {..} -> storedCoreToAsm _coreResultModule
upToCasm ::
(Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) =>
Sem r Casm.Result
upToCasm =
upToStoredCore >>= \Core.CoreResult {..} -> storedCoreToCasm _coreResultModule
upToMiniC ::
(Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) =>
Sem r C.MiniCResult
@ -153,6 +162,9 @@ storedCoreToReg = storedCoreToAsm >=> asmToReg
storedCoreToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r C.MiniCResult
storedCoreToMiniC = storedCoreToAsm >=> asmToMiniC
storedCoreToCasm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Casm.Result
storedCoreToCasm = local (set entryPointFieldSize cairoFieldSize) . storedCoreToTree Core.CheckCairo >=> treeToCasm
storedCoreToGeb :: (Members '[Error JuvixError, Reader EntryPoint] r) => Geb.ResultSpec -> Core.Module -> Sem r Geb.Result
storedCoreToGeb spec = Core.toGeb >=> return . uncurry (Geb.toResult spec) . Geb.fromCore . Core.computeCombinedInfoTable
@ -175,6 +187,9 @@ coreToAsm = Core.toStored >=> storedCoreToAsm
coreToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Reg.InfoTable
coreToReg = Core.toStored >=> storedCoreToReg
coreToCasm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Casm.Result
coreToCasm = Core.toStored >=> storedCoreToCasm
coreToNockma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r (Nockma.Cell Natural)
coreToNockma = coreToTree Core.CheckAnoma >=> treeToNockma
@ -200,6 +215,9 @@ coreToVampIR' = Core.toStored' >=> storedCoreToVampIR'
treeToAsm :: (Member (Error JuvixError) r) => Tree.InfoTable -> Sem r Asm.InfoTable
treeToAsm = Tree.toAsm >=> return . Asm.fromTree
treeToCairoAsm :: (Member (Error JuvixError) r) => Tree.InfoTable -> Sem r Asm.InfoTable
treeToCairoAsm = Tree.toCairoAsm >=> return . Asm.fromTree
treeToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r Reg.InfoTable
treeToReg = treeToAsm >=> asmToReg
@ -212,9 +230,15 @@ treeToAnoma = Tree.toNockma >=> mapReader NockmaTree.fromEntryPoint . NockmaTree
treeToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r C.MiniCResult
treeToMiniC = treeToAsm >=> asmToMiniC
treeToCasm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r Casm.Result
treeToCasm = treeToCairoAsm >=> asmToCasm
asmToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r Reg.InfoTable
asmToReg = Asm.toReg >=> return . Reg.fromAsm
asmToCasm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r Casm.Result
asmToCasm = asmToReg >=> regToCasm
asmToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r C.MiniCResult
asmToMiniC = asmToReg >=> regToMiniC
@ -224,6 +248,9 @@ regToMiniC tab = do
e <- ask
return $ C.fromReg (Backend.getLimits (e ^. entryPointTarget) (e ^. entryPointDebug)) tab'
regToCasm :: Reg.InfoTable -> Sem r Casm.Result
regToCasm = Reg.toCasm >=> return . Casm.fromReg
treeToNockma' :: (Members '[Error JuvixError, Reader NockmaTree.CompilerOptions] r) => Tree.InfoTable -> Sem r (Nockma.Cell Natural)
treeToNockma' = Tree.toNockma >=> NockmaTree.fromTreeTable NockmaTree.ProgramCallingConventionJuvix

10
src/Juvix/Compiler/Reg/Data/TransformationId.hs
View File

@ -12,7 +12,7 @@ data TransformationId
deriving stock (Data, Bounded, Enum, Show)
data PipelineId
= PipelineCairo
= PipelineCasm
| PipelineC
deriving stock (Data, Bounded, Enum)
@ -21,8 +21,8 @@ type TransformationLikeId = TransformationLikeId' TransformationId PipelineId
toCTransformations :: [TransformationId]
toCTransformations = [Cleanup]
toCairoTransformations :: [TransformationId]
toCairoTransformations = [Cleanup, SSA, InitBranchVars]
toCasmTransformations :: [TransformationId]
toCasmTransformations = [Cleanup, SSA, InitBranchVars]
instance TransformationId' TransformationId where
transformationText :: TransformationId -> Text
@ -36,9 +36,9 @@ instance PipelineId' TransformationId PipelineId where
pipelineText :: PipelineId -> Text
pipelineText = \case
PipelineC -> strCPipeline
PipelineCairo -> strCairoPipeline
PipelineCasm -> strCasmPipeline
pipeline :: PipelineId -> [TransformationId]
pipeline = \case
PipelineC -> toCTransformations
PipelineCairo -> toCairoTransformations
PipelineCasm -> toCasmTransformations

4
src/Juvix/Compiler/Reg/Data/TransformationId/Strings.hs
View File

@ -5,8 +5,8 @@ import Juvix.Prelude
strCPipeline :: Text
strCPipeline = "pipeline-c"
strCairoPipeline :: Text
strCairoPipeline = "pipeline-cairo"
strCasmPipeline :: Text
strCasmPipeline = "pipeline-casm"
strIdentity :: Text
strIdentity = "identity"

12
src/Juvix/Compiler/Reg/Extra/Info.hs
View File

@ -196,8 +196,13 @@ computeLocalVarsNum = maximum . map go
data ExtraInfo = ExtraInfo
{ _extraInfoTable :: InfoTable,
-- | Globally unique IDs for constructor tags
_extraInfoUIDs :: HashMap Tag Int,
-- | Globally unique IDs for function symbols
_extraInfoFUIDs :: HashMap Symbol Int,
-- | IDs for constructor tags, consecutive starting from 0 for each
-- inductive type separately
_extraInfoCIDs :: HashMap Tag Int,
_extraInfoStringMap :: HashMap Text Int,
_extraInfoMaxStackHeight :: HashMap Symbol Int,
_extraInfoLocalVarsNum :: HashMap Symbol Int,
@ -226,12 +231,19 @@ computeFUIDs tab =
(HashMap.elems (tab ^. infoFunctions))
[0 ..]
computeCIDs :: InfoTable -> HashMap Tag Int
computeCIDs tab = HashMap.fromList $ concatMap go (tab ^. infoInductives)
where
go :: InductiveInfo -> [(Tag, Int)]
go InductiveInfo {..} = zip _inductiveConstructors [0 ..]
computeExtraInfo :: Limits -> InfoTable -> ExtraInfo
computeExtraInfo lims tab =
ExtraInfo
{ _extraInfoTable = tab,
_extraInfoUIDs = computeUIDs lims tab,
_extraInfoFUIDs = computeFUIDs tab,
_extraInfoCIDs = computeCIDs tab,
_extraInfoStringMap =
foldr
(\fi mp -> computeStringMap mp (fi ^. functionCode))

11
src/Juvix/Compiler/Reg/Interpreter.hs
View File

@ -65,15 +65,6 @@ runFunction hout infoTable args0 info0 = do
[] ->
return $ ValVoid
readConst :: Constant -> Val
readConst = \case
ConstInt i -> ValInteger i
ConstField f -> ValField f
ConstBool b -> ValBool b
ConstString s -> ValString s
ConstUnit -> ValUnit
ConstVoid -> ValVoid
readVarRef :: Args -> Vars s -> VarRef -> ST s Val
readVarRef args tmps VarRef {..} = case _varRefGroup of
VarGroupArgs -> return $ args Vec.! _varRefIndex
@ -97,7 +88,7 @@ runFunction hout infoTable args0 info0 = do
readValue :: Args -> Vars s -> Value -> ST s Val
readValue args tmps = \case
Const c -> return $ readConst c
Const c -> return $ constantToValue c
CRef r -> readConstrRef args tmps r
VRef r -> readVarRef args tmps r

1
src/Juvix/Compiler/Reg/Language.hs
View File

@ -19,6 +19,7 @@ data ConstrField = ConstrField
_constrFieldMemRep :: MemRep,
-- | Location where the data is stored.
_constrFieldRef :: VarRef,
-- | Index of the constructor argument being referenced.
_constrFieldIndex :: Index
}

7
src/Juvix/Compiler/Reg/Pipeline.hs
View File

@ -11,6 +11,7 @@ import Juvix.Compiler.Reg.Transformation
toC :: InfoTable -> Sem r InfoTable
toC = applyTransformations toCTransformations
-- | Perform transformations on JuvixReg necessary before the translation to Cairo
toCairo :: InfoTable -> Sem r InfoTable
toCairo = applyTransformations toCairoTransformations
-- | Perform transformations on JuvixReg necessary before the translation to
-- Cairo assembly
toCasm :: InfoTable -> Sem r InfoTable
toCasm = applyTransformations toCasmTransformations

6
src/Juvix/Compiler/Tree/Data/TransformationId.hs
View File

@ -17,6 +17,7 @@ data TransformationId
data PipelineId
= PipelineNockma
| PipelineAsm
| PipelineCairoAsm
deriving stock (Data, Bounded, Enum)
type TransformationLikeId = TransformationLikeId' TransformationId PipelineId
@ -27,6 +28,9 @@ toNockmaTransformations = [Validate, Apply, FilterUnreachable, TempHeight]
toAsmTransformations :: [TransformationId]
toAsmTransformations = [Validate]
toCairoAsmTransformations :: [TransformationId]
toCairoAsmTransformations = [Validate, Apply, FilterUnreachable]
instance TransformationId' TransformationId where
transformationText :: TransformationId -> Text
transformationText = \case
@ -43,8 +47,10 @@ instance PipelineId' TransformationId PipelineId where
pipelineText = \case
PipelineNockma -> strNockmaPipeline
PipelineAsm -> strAsmPipeline
PipelineCairoAsm -> strCairoAsmPipeline
pipeline :: PipelineId -> [TransformationId]
pipeline = \case
PipelineNockma -> toNockmaTransformations
PipelineAsm -> toAsmTransformations
PipelineCairoAsm -> toCairoAsmTransformations

3
src/Juvix/Compiler/Tree/Data/TransformationId/Strings.hs
View File

@ -8,6 +8,9 @@ strNockmaPipeline = "pipeline-nockma"
strAsmPipeline :: Text
strAsmPipeline = "pipeline-asm"
strCairoAsmPipeline :: Text
strCairoAsmPipeline = "pipeline-cairo-asm"
strIdentity :: Text
strIdentity = "identity"

8
src/Juvix/Compiler/Tree/Evaluator.hs
View File

@ -81,13 +81,7 @@ hEval hout tab = eval' [] mempty
goTrace v = unsafePerformIO (hPutStrLn hout (printValue tab v) >> return v)
goConstant :: NodeConstant -> Value
goConstant NodeConstant {..} = case _nodeConstant of
ConstInt i -> ValInteger i
ConstField f -> ValField f
ConstBool b -> ValBool b
ConstString s -> ValString s
ConstUnit -> ValUnit
ConstVoid -> ValVoid
goConstant NodeConstant {..} = constantToValue _nodeConstant
goMemRef :: NodeMemRef -> Value
goMemRef NodeMemRef {..} = case _nodeMemRef of

31
src/Juvix/Compiler/Tree/Evaluator/Builtins.hs
View File

@ -1,12 +1,12 @@
module Juvix.Compiler.Tree.Evaluator.Builtins where
import Juvix.Compiler.Tree.Data.InfoTable.Base
import Juvix.Compiler.Tree.Language.Base
import Juvix.Compiler.Tree.Language.Builtins
import Juvix.Compiler.Tree.Language.Value
import Juvix.Compiler.Tree.Pretty.Base
import Juvix.Data.Field
import Juvix.Data.PPOutput
import Juvix.Prelude
import Text.Read qualified as T
type ErrorMsg = Text
@ -104,3 +104,32 @@ printValue :: InfoTable' t e -> Value -> Text
printValue tab = \case
ValString s -> s
v -> toPlainText . mkAnsiText . PPOutput . doc (defaultOptions tab) $ v
constantToValue :: Constant -> Value
constantToValue = \case
ConstInt i -> ValInteger i
ConstField f -> ValField f
ConstBool b -> ValBool b
ConstString s -> ValString s
ConstUnit -> ValUnit
ConstVoid -> ValVoid
valueToConstant :: Value -> Constant
valueToConstant = \case
ValInteger i -> ConstInt i
ValField f -> ConstField f
ValBool b -> ConstBool b
ValString s -> ConstString s
ValUnit -> ConstUnit
ValVoid -> ConstVoid
_ -> impossible
evalBinop' :: BinaryOp -> Constant -> Constant -> Either ErrorMsg Constant
evalBinop' op arg1 arg2 =
mapRight valueToConstant $
evalBinop op (constantToValue arg1) (constantToValue arg2)
evalUnop' :: InfoTable' t e -> UnaryOp -> Constant -> Either ErrorMsg Constant
evalUnop' tab op v =
mapRight valueToConstant $
evalUnop tab op (constantToValue v)

8
src/Juvix/Compiler/Tree/EvaluatorEff.hs
View File

@ -77,13 +77,7 @@ eval tab = E.runReader emptyEvalCtx . eval'
goTrace v = E.output v $> v
goConstant :: NodeConstant -> Value
goConstant NodeConstant {..} = case _nodeConstant of
ConstInt i -> ValInteger i
ConstField f -> ValField f
ConstBool b -> ValBool b
ConstString s -> ValString s
ConstUnit -> ValUnit
ConstVoid -> ValVoid
goConstant NodeConstant {..} = constantToValue _nodeConstant
askTemp :: Eff r' (BL.BinderList Value)
askTemp = E.asks (^. evalCtxTemp)

8
src/Juvix/Compiler/Tree/EvaluatorSem.hs
View File

@ -75,13 +75,7 @@ eval tab = runReader emptyEvalCtx . eval'
goTrace v = output v $> v
goConstant :: NodeConstant -> Value
goConstant NodeConstant {..} = case _nodeConstant of
ConstInt i -> ValInteger i
ConstField f -> ValField f
ConstBool b -> ValBool b
ConstString s -> ValString s
ConstUnit -> ValUnit
ConstVoid -> ValVoid
goConstant NodeConstant {..} = constantToValue _nodeConstant
askTemp :: Sem r' (BL.BinderList Value)
askTemp = asks (^. evalCtxTemp)

3
src/Juvix/Compiler/Tree/Pipeline.hs
View File

@ -12,3 +12,6 @@ toNockma = applyTransformations toNockmaTransformations
toAsm :: (Member (Error JuvixError) r) => InfoTable -> Sem r InfoTable
toAsm = applyTransformations toAsmTransformations
toCairoAsm :: (Member (Error JuvixError) r) => InfoTable -> Sem r InfoTable
toCairoAsm = applyTransformations toCairoAsmTransformations

4
test/Casm.hs
View File

@ -1,7 +1,9 @@
module Casm where
import Base
import Casm.Compilation qualified as Compile
import Casm.Reg qualified as Reg
import Casm.Run qualified as Run
allTests :: TestTree
allTests = testGroup "CASM tests" [Run.allTests]
allTests = testGroup "CASM tests" [Run.allTests, Reg.allTests, Compile.allTests]

7
test/Casm/Compilation.hs Normal file
View File

@ -0,0 +1,7 @@
module Casm.Compilation where
import Base
import Casm.Compilation.Positive qualified as P
allTests :: TestTree
allTests = testGroup "Juvix to CASM compilation" [P.allTests, P.allTestsNoOptimize]

52
test/Casm/Compilation/Base.hs Normal file
View File

@ -0,0 +1,52 @@
module Casm.Compilation.Base where
import Base
import Juvix.Compiler.Casm.Data.Result
import Juvix.Compiler.Casm.Interpreter
import Juvix.Compiler.Casm.Pretty
import Juvix.Compiler.Core qualified as Core
import Juvix.Data.Field
import Juvix.Data.PPOutput
compileAssertion ::
Path Abs Dir ->
Int ->
Path Abs File ->
Path Abs File ->
(String -> IO ()) ->
Assertion
compileAssertion = compileAssertionEntry (\e -> e {_entryPointFieldSize = cairoFieldSize})
compileAssertionEntry ::
(EntryPoint -> EntryPoint) ->
Path Abs Dir ->
Int ->
Path Abs File ->
Path Abs File ->
(String -> IO ()) ->
Assertion
compileAssertionEntry adjustEntry root' optLevel mainFile expectedFile step = do
step "Translate to JuvixCore"
entryPoint <- adjustEntry <$> testDefaultEntryPointIO root' mainFile
PipelineResult {..} <- snd <$> testRunIO entryPoint upToStoredCore
step "Translate to CASM"
let entryPoint' = entryPoint {_entryPointOptimizationLevel = optLevel}
case run $ runError @JuvixError $ runReader entryPoint' $ storedCoreToCasm (_pipelineResult ^. Core.coreResultModule) of
Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err)))
Right Result {..} -> do
withTempDir'
( \dirPath -> do
let outputFile = dirPath <//> $(mkRelFile "out.out")
let tmpFile = dirPath <//> $(mkRelFile "tmp.out")
step "Serialize"
writeFileEnsureLn tmpFile (toPlainText $ ppProgram _resultCode)
hout <- openFile (toFilePath outputFile) WriteMode
step "Interpret"
let v = hRunCode hout _resultLabelInfo _resultCode
hPutStrLn hout (show v)
hClose hout
actualOutput <- readFile outputFile
step "Compare expected and actual program output"
expected <- readFile expectedFile
assertEqDiffText ("Check: RUN output = " <> toFilePath expectedFile) actualOutput expected
)

353
test/Casm/Compilation/Positive.hs Normal file
View File

@ -0,0 +1,353 @@
module Casm.Compilation.Positive where
import Base
import Casm.Compilation.Base
import Data.HashSet qualified as HashSet
data PosTest = PosTest
{ _name :: String,
_dir :: Path Abs Dir,
_file :: Path Abs File,
_expectedFile :: Path Abs File
}
makeLenses ''PosTest
root :: Path Abs Dir
root = relToProject $(mkRelDir "tests/Casm/Compilation/positive/")
toTestDescr :: Int -> PosTest -> TestDescr
toTestDescr optLevel PosTest {..} =
let tRoot = _dir
file' = _file
expected' = _expectedFile
in TestDescr
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Steps $ compileAssertion _dir optLevel file' expected'
}
allTests :: TestTree
allTests =
testGroup
"Juvix to CASM positive tests"
(map (mkTest . toTestDescr 3) tests)
allTestsNoOptimize :: TestTree
allTestsNoOptimize =
testGroup
"Juvix to CASM positive tests (no optimization)"
(map (mkTest . toTestDescr 0) tests)
posTest :: String -> Path Rel Dir -> Path Rel File -> Path Rel File -> PosTest
posTest _name rdir rfile routfile =
let _dir = root <//> rdir
_file = _dir <//> rfile
_expectedFile = root <//> routfile
in PosTest {..}
isIgnored :: PosTest -> Bool
isIgnored t = HashSet.member (t ^. name) ignored
ignored :: HashSet String
ignored =
HashSet.fromList
[ -- strings not supported (Partial trait)
"Test026: Functional queues"
]
tests :: [PosTest]
tests =
filter
(not . isIgnored)
[ posTest
"Test001: Arithmetic operators"
$(mkRelDir ".")
$(mkRelFile "test001.juvix")
$(mkRelFile "out/test001.out"),
posTest
"Test002: Arithmetic operators inside lambdas"
$(mkRelDir ".")
$(mkRelFile "test002.juvix")
$(mkRelFile "out/test002.out"),
posTest
"Test003: Integer arithmetic"
$(mkRelDir ".")
$(mkRelFile "test003.juvix")
$(mkRelFile "out/test003.out"),
posTest
"Test005: Higher-order functions"
$(mkRelDir ".")
$(mkRelFile "test005.juvix")
$(mkRelFile "out/test005.out"),
posTest
"Test006: If-then-else and lazy boolean operators"
$(mkRelDir ".")
$(mkRelFile "test006.juvix")
$(mkRelFile "out/test006.out"),
posTest
"Test007: Pattern matching and lambda-case"
$(mkRelDir ".")
$(mkRelFile "test007.juvix")
$(mkRelFile "out/test007.out"),
posTest
"Test008: Recursion"
$(mkRelDir ".")
$(mkRelFile "test008.juvix")
$(mkRelFile "out/test008.out"),
posTest
"Test009: Tail recursion"
$(mkRelDir ".")
$(mkRelFile "test009.juvix")
$(mkRelFile "out/test009.out"),
posTest
"Test010: Let"
$(mkRelDir ".")
$(mkRelFile "test010.juvix")
$(mkRelFile "out/test010.out"),
posTest
"Test013: Functions returning functions with variable capture"
$(mkRelDir ".")
$(mkRelFile "test013.juvix")
$(mkRelFile "out/test013.out"),
posTest
"Test014: Arithmetic"
$(mkRelDir ".")
$(mkRelFile "test014.juvix")
$(mkRelFile "out/test014.out"),
posTest
"Test015: Local functions with free variables"
$(mkRelDir ".")
$(mkRelFile "test015.juvix")
$(mkRelFile "out/test015.out"),
posTest
"Test016: Recursion through higher-order functions"
$(mkRelDir ".")
$(mkRelFile "test016.juvix")
$(mkRelFile "out/test016.out"),
posTest
"Test017: Tail recursion through higher-order functions"
$(mkRelDir ".")
$(mkRelFile "test017.juvix")
$(mkRelFile "out/test017.out"),
posTest
"Test018: Higher-order functions and recursion"
$(mkRelDir ".")
$(mkRelFile "test018.juvix")
$(mkRelFile "out/test018.out"),
posTest
"Test019: Self-application"
$(mkRelDir ".")
$(mkRelFile "test019.juvix")
$(mkRelFile "out/test019.out"),
posTest
"Test020: Recursive functions: McCarthy's 91 function, subtraction by increments"
$(mkRelDir ".")
$(mkRelFile "test020.juvix")
$(mkRelFile "out/test020.out"),
posTest
"Test021: Fast exponentiation"
$(mkRelDir ".")
$(mkRelFile "test021.juvix")
$(mkRelFile "out/test021.out"),
posTest
"Test022: Lists"
$(mkRelDir ".")
$(mkRelFile "test022.juvix")
$(mkRelFile "out/test022.out"),
posTest
"Test023: Mutual recursion"
$(mkRelDir ".")
$(mkRelFile "test023.juvix")
$(mkRelFile "out/test023.out"),
posTest
"Test024: Nested binders with variable capture"
$(mkRelDir ".")
$(mkRelFile "test024.juvix")
$(mkRelFile "out/test024.out"),
posTest
"Test025: Euclid's algorithm"
$(mkRelDir ".")
$(mkRelFile "test025.juvix")
$(mkRelFile "out/test025.out"),
posTest
"Test026: Functional queues"
$(mkRelDir ".")
$(mkRelFile "test026.juvix")
$(mkRelFile "out/test026.out"),
posTest
"Test028: Streams without memoization"
$(mkRelDir ".")
$(mkRelFile "test028.juvix")
$(mkRelFile "out/test028.out"),
posTest
"Test029: Ackermann function"
$(mkRelDir ".")
$(mkRelFile "test029.juvix")
$(mkRelFile "out/test029.out"),
posTest
"Test030: Ackermann function (higher-order definition)"
$(mkRelDir ".")
$(mkRelFile "test030.juvix")
$(mkRelFile "out/test030.out"),
posTest
"Test032: Merge sort"
$(mkRelDir ".")
$(mkRelFile "test032.juvix")
$(mkRelFile "out/test032.out"),
posTest
"Test033: Eta-expansion of builtins and constructors"
$(mkRelDir ".")
$(mkRelFile "test033.juvix")
$(mkRelFile "out/test033.out"),
posTest
"Test034: Recursive let"
$(mkRelDir ".")
$(mkRelFile "test034.juvix")
$(mkRelFile "out/test034.out"),
posTest
"Test035: Pattern matching"
$(mkRelDir ".")
$(mkRelFile "test035.juvix")
$(mkRelFile "out/test035.out"),
posTest
"Test036: Eta-expansion"
$(mkRelDir ".")
$(mkRelFile "test036.juvix")
$(mkRelFile "out/test036.out"),
posTest
"Test037: Applications with lets and cases in function position"
$(mkRelDir ".")
$(mkRelFile "test037.juvix")
$(mkRelFile "out/test037.out"),
posTest
"Test038: Simple case expression"
$(mkRelDir ".")
$(mkRelFile "test038.juvix")
$(mkRelFile "out/test038.out"),
posTest
"Test039: Mutually recursive let expression"
$(mkRelDir ".")
$(mkRelFile "test039.juvix")
$(mkRelFile "out/test039.out"),
posTest
"Test040: Pattern matching nullary constructor"
$(mkRelDir ".")
$(mkRelFile "test040.juvix")
$(mkRelFile "out/test040.out"),
posTest
"Test045: Implicit builtin bool"
$(mkRelDir ".")
$(mkRelFile "test045.juvix")
$(mkRelFile "out/test045.out"),
posTest
"Test046: Polymorphic type arguments"
$(mkRelDir ".")
$(mkRelFile "test046.juvix")
$(mkRelFile "out/test046.out"),
posTest
"Test047: Local Modules"
$(mkRelDir ".")
$(mkRelFile "test047.juvix")
$(mkRelFile "out/test047.out"),
posTest
"Test050: Pattern matching with integers"
$(mkRelDir ".")
$(mkRelFile "test050.juvix")
$(mkRelFile "out/test050.out"),
posTest
"Test053: Inlining"
$(mkRelDir ".")
$(mkRelFile "test053.juvix")
$(mkRelFile "out/test053.out"),
posTest
"Test054: Iterators"
$(mkRelDir ".")
$(mkRelFile "test054.juvix")
$(mkRelFile "out/test054.out"),
posTest
"Test056: Argument specialization"
$(mkRelDir ".")
$(mkRelFile "test056.juvix")
$(mkRelFile "out/test056.out"),
posTest
"Test057: Case folding"
$(mkRelDir ".")
$(mkRelFile "test057.juvix")
$(mkRelFile "out/test057.out"),
posTest
"Test058: Ranges"
$(mkRelDir ".")
$(mkRelFile "test058.juvix")
$(mkRelFile "out/test058.out"),
posTest
"Test059: Builtin list"
$(mkRelDir ".")
$(mkRelFile "test059.juvix")
$(mkRelFile "out/test059.out"),
posTest
"Test060: Record update"
$(mkRelDir ".")
$(mkRelFile "test060.juvix")
$(mkRelFile "out/test060.out"),
posTest
"Test062: Overapplication"
$(mkRelDir ".")
$(mkRelFile "test062.juvix")
$(mkRelFile "out/test062.out"),
posTest
"Test064: Constant folding"
$(mkRelDir ".")
$(mkRelFile "test064.juvix")
$(mkRelFile "out/test064.out"),
posTest
"Test065: Arithmetic simplification"
$(mkRelDir ".")
$(mkRelFile "test065.juvix")
$(mkRelFile "out/test065.out"),
posTest
"Test066: Import function with a function call in default argument"
$(mkRelDir "test066")
$(mkRelFile "M.juvix")
$(mkRelFile "out/test066.out"),
posTest
"Test067: Dependent default values inserted during translation FromConcrete"
$(mkRelDir ".")
$(mkRelFile "test067.juvix")
$(mkRelFile "out/test067.out"),
posTest
"Test068: Dependent default values inserted in the arity checker"
$(mkRelDir ".")
$(mkRelFile "test068.juvix")
$(mkRelFile "out/test068.out"),
posTest
"Test069: Dependent default values for Ord trait"
$(mkRelDir ".")
$(mkRelFile "test069.juvix")
$(mkRelFile "out/test069.out"),
posTest
"Test070: Nested default values and named arguments"
$(mkRelDir ".")
$(mkRelFile "test070.juvix")
$(mkRelFile "out/test070.out"),
posTest
"Test071: Named application (Ord instance with default cmp)"
$(mkRelDir ".")
$(mkRelFile "test071.juvix")
$(mkRelFile "out/test071.out"),
posTest
"Test072: Monad transformers (ReaderT + StateT + Identity)"
$(mkRelDir "test072")
$(mkRelFile "ReaderT.juvix")
$(mkRelFile "out/test072.out"),
posTest
"Test073: Import and use a syntax alias"
$(mkRelDir "test073")
$(mkRelFile "test073.juvix")
$(mkRelFile "out/test073.out"),
posTest
"Test074: Fields"
$(mkRelDir ".")
$(mkRelFile "test074.juvix")
$(mkRelFile "out/test074.out")
]

7
test/Casm/Reg.hs Normal file
View File

@ -0,0 +1,7 @@
module Casm.Reg where
import Base
import Casm.Reg.Positive qualified as P
allTests :: TestTree
allTests = testGroup "CASM from JuvixReg translation" [P.allTests]

20
test/Casm/Reg/Base.hs Normal file
View File

@ -0,0 +1,20 @@
module Casm.Reg.Base where
import Base
import Juvix.Compiler.Casm.Data.Result
import Juvix.Compiler.Casm.Interpreter
import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg
import Juvix.Data.PPOutput
import Reg.Run.Base qualified as Reg
compileAssertion' :: Handle -> Symbol -> Reg.InfoTable -> IO ()
compileAssertion' hout _ tab = do
case run $ runError @JuvixError $ regToCasm tab of
Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err)))
Right Result {..} -> do
let v = hRunCode hout _resultLabelInfo _resultCode
hPutStrLn hout (show v)
regToCasmAssertion :: Path Abs File -> Path Abs File -> (String -> IO ()) -> Assertion
regToCasmAssertion mainFile expectedFile step =
Reg.regRunAssertionParam compileAssertion' mainFile expectedFile [] (const (return ())) step

183
test/Casm/Reg/Positive.hs Normal file
View File

@ -0,0 +1,183 @@
module Casm.Reg.Positive where
import Base
import Casm.Reg.Base
data PosTest = PosTest
{ _name :: String,
_relDir :: Path Rel Dir,
_file :: Path Rel File,
_expectedFile :: Path Rel File
}
root :: Path Abs Dir
root = relToProject $(mkRelDir "tests/Casm/Reg/positive")
testDescr :: PosTest -> TestDescr
testDescr PosTest {..} =
let tRoot = root <//> _relDir
file' = tRoot <//> _file
expected' = tRoot <//> _expectedFile
in TestDescr
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Steps $ regToCasmAssertion file' expected'
}
filterTests :: [String] -> [PosTest] -> [PosTest]
filterTests incl = filter (\PosTest {..} -> _name `elem` incl)
allTests :: TestTree
allTests =
testGroup
"CASM from JuvixReg translation positive tests"
(map (mkTest . testDescr) tests)
tests :: [PosTest]
tests =
[ PosTest
"Test001: Arithmetic opcodes"
$(mkRelDir ".")
$(mkRelFile "test001.jvr")
$(mkRelFile "out/test001.out"),
PosTest
"Test002: Direct call"
$(mkRelDir ".")
$(mkRelFile "test002.jvr")
$(mkRelFile "out/test002.out"),
PosTest
"Test003: Indirect call"
$(mkRelDir ".")
$(mkRelFile "test003.jvr")
$(mkRelFile "out/test003.out"),
PosTest
"Test004: Tail calls"
$(mkRelDir ".")
$(mkRelFile "test004.jvr")
$(mkRelFile "out/test004.out"),
PosTest
"Test008: Branch"
$(mkRelDir ".")
$(mkRelFile "test008.jvr")
$(mkRelFile "out/test008.out"),
PosTest
"Test009: Case"
$(mkRelDir ".")
$(mkRelFile "test009.jvr")
$(mkRelFile "out/test009.out"),
PosTest
"Test010: Recursion"
$(mkRelDir ".")
$(mkRelFile "test010.jvr")
$(mkRelFile "out/test010.out"),
PosTest
"Test011: Tail recursion"
$(mkRelDir ".")
$(mkRelFile "test011.jvr")
$(mkRelFile "out/test011.out"),
PosTest
"Test012: Temporary stack"
$(mkRelDir ".")
$(mkRelFile "test012.jvr")
$(mkRelFile "out/test012.out"),
PosTest
"Test013: Fibonacci numbers in linear time"
$(mkRelDir ".")
$(mkRelFile "test013.jvr")
$(mkRelFile "out/test013.out"),
PosTest
"Test014: Trees"
$(mkRelDir ".")
$(mkRelFile "test014.jvr")
$(mkRelFile "out/test014.out"),
PosTest
"Test015: Functions returning functions"
$(mkRelDir ".")
$(mkRelFile "test015.jvr")
$(mkRelFile "out/test015.out"),
PosTest
"Test016: Arithmetic"
$(mkRelDir ".")
$(mkRelFile "test016.jvr")
$(mkRelFile "out/test016.out"),
PosTest
"Test017: Closures as arguments"
$(mkRelDir ".")
$(mkRelFile "test017.jvr")
$(mkRelFile "out/test017.out"),
PosTest
"Test018: Closure extension"
$(mkRelDir ".")
$(mkRelFile "test018.jvr")
$(mkRelFile "out/test018.out"),
PosTest
"Test019: Recursion through higher-order functions"
$(mkRelDir ".")
$(mkRelFile "test019.jvr")
$(mkRelFile "out/test019.out"),
PosTest
"Test020: Tail recursion through higher-order functions"
$(mkRelDir ".")
$(mkRelFile "test020.jvr")
$(mkRelFile "out/test020.out"),
PosTest
"Test021: Higher-order functions and recursion"
$(mkRelDir ".")
$(mkRelFile "test021.jvr")
$(mkRelFile "out/test021.out"),
PosTest
"Test023: McCarthy's 91 function"
$(mkRelDir ".")
$(mkRelFile "test023.jvr")
$(mkRelFile "out/test023.out"),
PosTest
"Test024: Higher-order recursive functions"
$(mkRelDir ".")
$(mkRelFile "test024.jvr")
$(mkRelFile "out/test024.out"),
PosTest
"Test026: Currying & uncurrying"
$(mkRelDir ".")
$(mkRelFile "test026.jvr")
$(mkRelFile "out/test026.out"),
PosTest
"Test027: Fast exponentiation"
$(mkRelDir ".")
$(mkRelFile "test027.jvr")
$(mkRelFile "out/test027.out"),
PosTest
"Test028: Lists"
$(mkRelDir ".")
$(mkRelFile "test028.jvr")
$(mkRelFile "out/test028.out"),
PosTest
"Test030: Mutual recursion"
$(mkRelDir ".")
$(mkRelFile "test030.jvr")
$(mkRelFile "out/test030.out"),
PosTest
"Test031: Temporary stack with branching"
$(mkRelDir ".")
$(mkRelFile "test031.jvr")
$(mkRelFile "out/test031.out"),
PosTest
"Test033: Ackermann function"
$(mkRelDir ".")
$(mkRelFile "test033.jvr")
$(mkRelFile "out/test033.out"),
PosTest
"Test034: Higher-order function composition"
$(mkRelDir ".")
$(mkRelFile "test034.jvr")
$(mkRelFile "out/test034.out"),
PosTest
"Test036: Streams without memoization"
$(mkRelDir ".")
$(mkRelFile "test036.jvr")
$(mkRelFile "out/test036.out"),
PosTest
"Test038: Apply & argsnum"
$(mkRelDir ".")
$(mkRelFile "test038.jvr")
$(mkRelFile "out/test038.out")
]

2
test/Casm/Run.hs
View File

@ -1,7 +1,5 @@
module Casm.Run where
-- import Casm.Run.Negative qualified as RunN
import Base
import Casm.Run.Negative qualified as RunN
import Casm.Run.Positive qualified as RunP

1
tests/Asm/positive/out/test018.out
View File

@ -1,3 +1,4 @@
11
9
10
11

17
tests/Asm/positive/test018.jva
View File

@ -40,6 +40,17 @@ function mult(integer, integer) : integer {
ret;
}
function g(integer, integer, integer, integer) : integer {
push arg[1];
push arg[0];
sub;
push arg[2];
add;
push arg[3];
mul;
ret;
}
function main() {
calloc plus 0;
call f;
@ -53,6 +64,12 @@ function main() {
call f;
trace; -- 10
pop;
push 2;
push 3;
calloc g 2;
call f;
trace; -- 11
pop;
push void;
ret;
}

1
tests/Casm/Compilation/positive/out/test001.out Normal file
View File

@ -0,0 +1 @@
11

1
tests/Casm/Compilation/positive/out/test002.out Normal file
View File

@ -0,0 +1 @@
11

1
tests/Casm/Compilation/positive/out/test003.out Normal file
View File

@ -0,0 +1 @@
11

1
tests/Casm/Compilation/positive/out/test005.out Normal file
View File

@ -0,0 +1 @@
6

1
tests/Casm/Compilation/positive/out/test006.out Normal file
View File

@ -0,0 +1 @@
3

1
tests/Casm/Compilation/positive/out/test007.out Normal file
View File

@ -0,0 +1 @@
6

1
tests/Casm/Compilation/positive/out/test008.out Normal file
View File

@ -0,0 +1 @@
50005000

1
tests/Casm/Compilation/positive/out/test009.out Normal file
View File

@ -0,0 +1 @@
532635520

1
tests/Casm/Compilation/positive/out/test010.out Normal file
View File

@ -0,0 +1 @@
32

1
tests/Casm/Compilation/positive/out/test013.out Normal file
View File

@ -0,0 +1 @@
8

1
tests/Casm/Compilation/positive/out/test014.out Normal file
View File

@ -0,0 +1 @@
92

1
tests/Casm/Compilation/positive/out/test015.out Normal file
View File

@ -0,0 +1 @@
771

1
tests/Casm/Compilation/positive/out/test016.out Normal file
View File

@ -0,0 +1 @@
55

1
tests/Casm/Compilation/positive/out/test017.out Normal file
View File

@ -0,0 +1 @@
50005000

1
tests/Casm/Compilation/positive/out/test018.out Normal file
View File

@ -0,0 +1 @@
11

1
tests/Casm/Compilation/positive/out/test019.out Normal file
View File

@ -0,0 +1 @@
7

1
tests/Casm/Compilation/positive/out/test020.out Normal file
View File

@ -0,0 +1 @@
4876

1
tests/Casm/Compilation/positive/out/test021.out Normal file
View File

@ -0,0 +1 @@
48830320

1
tests/Casm/Compilation/positive/out/test022.out Normal file
View File

@ -0,0 +1 @@
100010000

1
tests/Casm/Compilation/positive/out/test023.out Normal file
View File

@ -0,0 +1 @@
6386010

1
tests/Casm/Compilation/positive/out/test024.out Normal file
View File

@ -0,0 +1 @@
6688

1
tests/Casm/Compilation/positive/out/test025.out Normal file
View File

@ -0,0 +1 @@
87

1
tests/Casm/Compilation/positive/out/test026.out Normal file
View File

@ -0,0 +1 @@
5050

1
tests/Casm/Compilation/positive/out/test028.out Normal file
View File

@ -0,0 +1 @@
2040

1
tests/Casm/Compilation/positive/out/test029.out Normal file
View File

@ -0,0 +1 @@
78

1
tests/Casm/Compilation/positive/out/test030.out Normal file
View File

@ -0,0 +1 @@
2247

1
tests/Casm/Compilation/positive/out/test032.out Normal file
View File

@ -0,0 +1 @@
195

1
tests/Casm/Compilation/positive/out/test033.out Normal file
View File

@ -0,0 +1 @@
31

1
tests/Casm/Compilation/positive/out/test034.out Normal file
View File

@ -0,0 +1 @@
50006027

1
tests/Casm/Compilation/positive/out/test035.out Normal file
View File

@ -0,0 +1 @@
34422

1
tests/Casm/Compilation/positive/out/test036.out Normal file
View File

@ -0,0 +1 @@
18

1
tests/Casm/Compilation/positive/out/test037.out Normal file
View File

@ -0,0 +1 @@
9

1
tests/Casm/Compilation/positive/out/test038.out Normal file
View File

@ -0,0 +1 @@
1

1
tests/Casm/Compilation/positive/out/test039.out Normal file
View File

@ -0,0 +1 @@
1

1
tests/Casm/Compilation/positive/out/test040.out Normal file
View File

@ -0,0 +1 @@
1

1
tests/Casm/Compilation/positive/out/test045.out Normal file
View File

@ -0,0 +1 @@
4

1
tests/Casm/Compilation/positive/out/test046.out Normal file
View File

@ -0,0 +1 @@
7

1
tests/Casm/Compilation/positive/out/test047.out Normal file
View File

@ -0,0 +1 @@
660

1
tests/Casm/Compilation/positive/out/test050.out Normal file
View File

@ -0,0 +1 @@
11

1
tests/Casm/Compilation/positive/out/test053.out Normal file
View File

@ -0,0 +1 @@
21

1
tests/Casm/Compilation/positive/out/test054.out Normal file
View File

@ -0,0 +1 @@
189

Some files were not shown because too many files have changed in this diff Show More