anoma/juvix
1
1
Fork 0
mirror of https://github.com/anoma/juvix.git synced 2024-11-30 14:13:27 +03:00
Code Issues Projects Releases Wiki Activity

JuvixReg parser and pretty printer (#2617)

Browse Source 
* Closes #2578 
* Implements JuvixReg parser and pretty printer.
* Adds the `juvix dev reg read file.jvr` command.
* Adds the `reg` target to the `compile` commands.
* Adds tests for the JuvixReg parser.
This commit is contained in:
Łukasz Czajka 2024-02-09 12:19:29 +01:00 committed by GitHub
parent 5dfafe00d2
commit ed15e57d8a
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
128 changed files with 5433 additions and 387 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
app/Commands/Compile.hs
View File

@ -26,6 +26,7 @@ runCommand opts@CompileOptions {..} = do
TargetCore -> writeCoreFile arg
TargetTree -> Compile.runTreePipeline arg
TargetAsm -> Compile.runAsmPipeline arg
TargetReg -> Compile.runRegPipeline arg
TargetNockma -> Compile.runNockmaPipeline arg
writeCoreFile :: (Members '[Embed IO, App, TaggedLock] r) => Compile.PipelineArg -> Sem r ()

2
app/Commands/Dev.hs
View File

@ -16,6 +16,7 @@ import Commands.Dev.MigrateJuvixYaml qualified as MigrateJuvixYaml
import Commands.Dev.Nockma qualified as Nockma
import Commands.Dev.Options
import Commands.Dev.Parse qualified as Parse
import Commands.Dev.Reg qualified as Reg
import Commands.Dev.Runtime qualified as Runtime
import Commands.Dev.Scope qualified as Scope
import Commands.Dev.Termination qualified as Termination
@ -32,6 +33,7 @@ runCommand = \case
Core opts -> Core.runCommand opts
Geb opts -> Geb.runCommand opts
Asm opts -> Asm.runCommand opts
Reg opts -> Reg.runCommand opts
Tree opts -> Tree.runCommand opts
Casm opts -> Casm.runCommand opts
Runtime opts -> Runtime.runCommand opts

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

@ -6,6 +6,7 @@ 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.Reg.Pretty qualified as Reg
runCommand :: forall r. (Members '[Embed IO, App, TaggedLock] r) => AsmCompileOptions -> Sem r ()
runCommand opts = do
@ -22,19 +23,31 @@ runCommand opts = do
{ _entryPointTarget = tgt,
_entryPointDebug = opts ^. compileDebug
}
case run $ runReader entryPoint $ runError $ asmToMiniC tab of
Left err -> exitJuvixError err
Right C.MiniCResult {..} -> do
buildDir <- askBuildDir
ensureDir buildDir
cFile <- inputCFile file
embed @IO $ writeFileEnsureLn cFile _resultCCode
outfile <- Compile.outputFile opts file
Compile.runCommand
opts
{ _compileInputFile = Just (AppPath (preFileFromAbs cFile) False),
_compileOutputFile = Just (AppPath (preFileFromAbs outfile) False)
}
case opts ^. compileTarget of
TargetReg -> do
regFile <- Compile.outputFile opts file
r <-
runReader entryPoint
. runError @JuvixError
. asmToReg
$ tab
tab' <- getRight r
let code = Reg.ppPrint tab' tab'
embed @IO $ writeFileEnsureLn regFile code
_ ->
case run $ runReader entryPoint $ runError $ asmToMiniC tab of
Left err -> exitJuvixError err
Right C.MiniCResult {..} -> do
buildDir <- askBuildDir
ensureDir buildDir
cFile <- inputCFile file
embed @IO $ 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)
@ -43,6 +56,7 @@ runCommand opts = do
getTarget = \case
TargetWasm32Wasi -> return Backend.TargetCWasm32Wasi
TargetNative64 -> return Backend.TargetCNative64
TargetReg -> return Backend.TargetReg
TargetNockma -> err "Nockma"
TargetTree -> err "JuvixTree"
TargetGeb -> err "GEB"

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

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

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

@ -19,6 +19,7 @@ runCommand opts = do
TargetVampIR -> runVampIRPipeline arg
TargetCore -> return ()
TargetAsm -> runAsmPipeline arg
TargetReg -> runRegPipeline arg
TargetTree -> runTreePipeline arg
TargetNockma -> runNockmaPipeline arg
where

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

@ -10,6 +10,7 @@ import Juvix.Compiler.Backend.Geb qualified as Geb
import Juvix.Compiler.Backend.VampIR.Translation qualified as VampIR
import Juvix.Compiler.Core.Data.Module 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 System.FilePath (takeBaseName)
@ -39,6 +40,7 @@ getEntry PipelineArg {..} = do
TargetVampIR -> Backend.TargetVampIR
TargetCore -> Backend.TargetCore
TargetAsm -> Backend.TargetAsm
TargetReg -> Backend.TargetReg
TargetTree -> Backend.TargetTree
TargetNockma -> Backend.TargetNockma
@ -113,6 +115,19 @@ runAsmPipeline pa@PipelineArg {..} = do
let code = Asm.ppPrint tab' tab'
embed @IO $ writeFileEnsureLn asmFile code
runRegPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
runRegPipeline pa@PipelineArg {..} = do
entryPoint <- getEntry pa
regFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
r <-
runReader entryPoint
. runError @JuvixError
. coreToReg
$ _pipelineArgModule
tab' <- getRight r
let code = Reg.ppPrint tab' tab'
embed @IO $ writeFileEnsureLn regFile code
runTreePipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
runTreePipeline pa@PipelineArg {..} = do
entryPoint <- getEntry pa

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

@ -17,8 +17,9 @@ coreSupportedTargets =
TargetNative64,
TargetGeb,
TargetVampIR,
TargetTree,
TargetAsm,
TargetTree
TargetReg
]
parseCoreCompileOptions :: Parser CoreCompileOptions

10
app/Commands/Dev/Options.hs
View File

@ -22,6 +22,7 @@ import Commands.Dev.Internal.Options
import Commands.Dev.MigrateJuvixYaml.Options
import Commands.Dev.Nockma.Options
import Commands.Dev.Parse.Options
import Commands.Dev.Reg.Options
import Commands.Dev.Repl.Options
import Commands.Dev.Runtime.Options
import Commands.Dev.Scope.Options
@ -37,6 +38,7 @@ data DevCommand
| Core CoreCommand
| Geb GebCommand
| Asm AsmCommand
| Reg RegCommand
| Tree TreeCommand
| Casm CasmCommand
| Runtime RuntimeCommand
@ -57,6 +59,7 @@ parseDevCommand =
commandCore,
commandGeb,
commandAsm,
commandReg,
commandTree,
commandCasm,
commandRuntime,
@ -105,6 +108,13 @@ commandAsm =
(Asm <$> parseAsmCommand)
(progDesc "Subcommands related to JuvixAsm")
commandReg :: Mod CommandFields DevCommand
commandReg =
command "reg" $
info
(Reg <$> parseRegCommand)
(progDesc "Subcommands related to JuvixReg")
commandTree :: Mod CommandFields DevCommand
commandTree =
command "tree" $

9
app/Commands/Dev/Reg.hs Normal file
View File

@ -0,0 +1,9 @@
module Commands.Dev.Reg where
import Commands.Base
import Commands.Dev.Reg.Options
import Commands.Dev.Reg.Read as Read
runCommand :: forall r. (Members '[Embed IO, App, TaggedLock] r) => RegCommand -> Sem r ()
runCommand = \case
Read opts -> Read.runCommand opts

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

@ -0,0 +1,24 @@
module Commands.Dev.Reg.Options where
import Commands.Dev.Reg.Read.Options
import CommonOptions
newtype RegCommand
= Read RegReadOptions
deriving stock (Data)
parseRegCommand :: Parser RegCommand
parseRegCommand =
hsubparser $
mconcat
[ commandRead
]
where
commandRead :: Mod CommandFields RegCommand
commandRead = command "read" readInfo
readInfo :: ParserInfo RegCommand
readInfo =
info
(Read <$> parseRegReadOptions)
(progDesc "Parse a JuvixReg file and pretty print it")

19
app/Commands/Dev/Reg/Read.hs Normal file
View File

@ -0,0 +1,19 @@
module Commands.Dev.Reg.Read where
import Commands.Base
import Commands.Dev.Reg.Read.Options
import Juvix.Compiler.Reg.Pretty qualified as Reg
import Juvix.Compiler.Reg.Translation.FromSource qualified as Reg
runCommand :: forall r. (Members '[Embed IO, App] r) => RegReadOptions -> Sem r ()
runCommand opts = do
afile :: Path Abs File <- fromAppPathFile file
s <- readFile (toFilePath afile)
case Reg.runParser (toFilePath afile) s of
Left err ->
exitJuvixError (JuvixError err)
Right tab ->
renderStdOut (Reg.ppOutDefault tab tab)
where
file :: AppPath File
file = opts ^. regReadInputFile

15
app/Commands/Dev/Reg/Read/Options.hs Normal file
View File

@ -0,0 +1,15 @@
module Commands.Dev.Reg.Read.Options where
import CommonOptions
newtype RegReadOptions = RegReadOptions
{ _regReadInputFile :: AppPath File
}
deriving stock (Data)
makeLenses ''RegReadOptions
parseRegReadOptions :: Parser RegReadOptions
parseRegReadOptions = do
_regReadInputFile <- parseInputFile FileExtJuvixAsm
pure RegReadOptions {..}

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

@ -18,6 +18,7 @@ runCommand opts = do
TargetVampIR -> return ()
TargetCore -> return ()
TargetAsm -> runAsmPipeline arg
TargetReg -> runRegPipeline arg
TargetTree -> return ()
TargetNockma -> runNockmaPipeline arg
where

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

@ -7,6 +7,7 @@ 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.Reg.Pretty qualified as Reg
import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree
data PipelineArg = PipelineArg
@ -35,6 +36,7 @@ getEntry PipelineArg {..} = do
TargetVampIR -> Backend.TargetVampIR
TargetCore -> Backend.TargetCore
TargetAsm -> Backend.TargetAsm
TargetReg -> Backend.TargetReg
TargetTree -> Backend.TargetTree
TargetNockma -> Backend.TargetNockma
@ -84,6 +86,19 @@ runAsmPipeline pa@PipelineArg {..} = do
let code = Asm.ppPrint tab' tab'
embed @IO $ writeFileEnsureLn asmFile code
runRegPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
runRegPipeline pa@PipelineArg {..} = do
entryPoint <- getEntry pa
regFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
r <-
runReader entryPoint
. runError @JuvixError
. treeToReg
$ _pipelineArgTable
tab' <- getRight r
let code = Reg.ppPrint tab' tab'
embed @IO $ writeFileEnsureLn regFile code
runNockmaPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
runNockmaPipeline pa@PipelineArg {..} = do
entryPoint <- getEntry pa

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

@ -13,6 +13,7 @@ treeSupportedTargets =
[ TargetWasm32Wasi,
TargetNative64,
TargetAsm,
TargetReg,
TargetNockma
]

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

@ -33,6 +33,7 @@ runCompile inputFile o = do
TargetVampIR -> return (Right ())
TargetCore -> return (Right ())
TargetAsm -> return (Right ())
TargetReg -> return (Right ())
TargetTree -> return (Right ())
TargetNockma -> return (Right ())
@ -50,6 +51,7 @@ prepareRuntime buildDir o = do
TargetVampIR -> return ()
TargetCore -> return ()
TargetAsm -> return ()
TargetReg -> return ()
TargetTree -> return ()
TargetNockma -> return ()
where
@ -109,6 +111,8 @@ outputFile opts inputFile =
replaceExtension' juvixCoreFileExt baseOutputFile
TargetAsm ->
replaceExtension' juvixAsmFileExt baseOutputFile
TargetReg ->
replaceExtension' juvixRegFileExt baseOutputFile
TargetTree ->
replaceExtension' juvixTreeFileExt baseOutputFile
TargetNockma ->

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

@ -11,6 +11,7 @@ data CompileTarget
| TargetVampIR
| TargetCore
| TargetAsm
| TargetReg
| TargetTree
| TargetNockma
deriving stock (Eq, Data, Bounded, Enum)
@ -23,6 +24,7 @@ instance Show CompileTarget where
TargetVampIR -> "vampir"
TargetCore -> "core"
TargetAsm -> "asm"
TargetReg -> "reg"
TargetTree -> "tree"
TargetNockma -> "nockma"

47
src/Juvix/Compiler/Asm/Pretty/Base.hs
View File

@ -11,6 +11,7 @@ import Juvix.Compiler.Asm.Interpreter.RuntimeState
import Juvix.Compiler.Asm.Pretty.Options
import Juvix.Compiler.Internal.Data.Name
import Juvix.Compiler.Tree.Pretty.Base qualified as Tree
import Juvix.Compiler.Tree.Pretty.Extra
import Juvix.Data.CodeAnn
import Juvix.Extra.Strings qualified as Str
@ -135,7 +136,7 @@ instance PrettyCode CaseBranch where
ppCode CaseBranch {..} = do
name <- Tree.ppConstrName _caseBranchTag
br <- ppCodeCode _caseBranchCode
return $ name <> colon <+> braces' br
return $ name <> colon <+> braces' br <> semi
instance PrettyCode Command where
ppCode :: (Member (Reader Options) r) => Command -> Sem r (Doc Ann)
@ -149,10 +150,11 @@ instance PrettyCode Command where
<+> braces'
( constr Str.true_ <> colon
<+> braces' br1
<> semi
<> line
<> constr Str.false_
<> colon
<+> braces' br2
<+> braces' br2 <> semi
)
Case CmdCase {..} -> do
name <- Tree.ppIndName _cmdCaseInductive
@ -161,7 +163,7 @@ instance PrettyCode Command where
Just def -> do
d <-
( ppCodeCode
>=> (\x -> return $ primitive Str.default_ <> colon <+> braces' x)
>=> (\x -> return $ primitive Str.default_ <> colon <+> braces' x <> semi)
)
def
return $ brs ++ [d]
@ -185,42 +187,3 @@ instance PrettyCode ConstructorInfo where
instance PrettyCode InfoTable where
ppCode = Tree.ppInfoTable ppCodeCode
{--------------------------------------------------------------------------------}
{- helper functions -}
braces' :: Doc Ann -> Doc Ann
braces' d = braces (line <> indent' d <> line)
integer :: (Pretty a) => a -> Doc Ann
integer i = annotate AnnLiteralInteger (pretty i)
constr :: Text -> Doc Ann
constr a = annotate (AnnKind KNameConstructor) (pretty a)
variable :: Text -> Doc Ann
variable a = annotate (AnnKind KNameLocal) (pretty a)
ppRightExpression ::
(PrettyCode a, HasAtomicity a, Member (Reader Options) r) =>
Fixity ->
a ->
Sem r (Doc Ann)
ppRightExpression = ppLRExpression isRightAssoc
ppLeftExpression ::
(PrettyCode a, HasAtomicity a, Member (Reader Options) r) =>
Fixity ->
a ->
Sem r (Doc Ann)
ppLeftExpression = ppLRExpression isLeftAssoc
ppLRExpression ::
(HasAtomicity a, PrettyCode a, Member (Reader Options) r) =>
(Fixity -> Bool) ->
Fixity ->
a ->
Sem r (Doc Ann)
ppLRExpression associates fixlr e =
parensIf (atomParens associates (atomicity e) fixlr)
<$> ppCode e

21
src/Juvix/Compiler/Asm/Translation/FromSource.hs
View File

@ -17,13 +17,16 @@ import Juvix.Compiler.Tree.Translation.FromSource.Sig qualified as S
import Juvix.Parser.Error
import Text.Megaparsec qualified as P
type ParserSig = S.ParserSig Code (Maybe FunctionInfoExtra)
type ParserSig = S.ParserSig Code (Maybe FunctionInfoExtra) DirectRef
type LocalParams = LocalParams' DirectRef
parseAsmSig :: ParserSig
parseAsmSig =
S.ParserSig
{ _parserSigBareIdentifier = bareIdentifier,
_parserSigParseCode = parseCode,
_parserSigArgRef = \x y -> ArgRef (OffsetRef x y),
_parserSigEmptyCode = [],
_parserSigEmptyExtra = mempty
}
@ -88,7 +91,7 @@ command = do
"argsnum" ->
return $ mkInstr' loc ArgsNum
"alloc" ->
mkInstr' loc . AllocConstr <$> constrTag @Code @(Maybe FunctionInfoExtra)
mkInstr' loc . AllocConstr <$> constrTag @Code @(Maybe FunctionInfoExtra) @DirectRef
"calloc" ->
mkInstr' loc . AllocClosure <$> instrAllocClosure
"cextend" ->
@ -110,7 +113,7 @@ command = do
rbrace
return $ Branch $ CmdBranch (CommandInfo loc) br1 br2
"case" -> do
sym <- indSymbol @Code @(Maybe FunctionInfoExtra)
sym <- indSymbol @Code @(Maybe FunctionInfoExtra) @DirectRef
lbrace
brs <- P.many caseBranch
def <- optional defaultBranch
@ -130,10 +133,10 @@ parseSave ::
ParsecS r Command
parseSave loc isTail = do
mn <- optional identifier
tmpNum <- lift $ gets (^. localParamsTempIndex)
let updateNames :: LocalNameMap -> LocalNameMap
tmpNum <- lift $ gets @LocalParams (^. localParamsTempIndex)
let updateNames :: LocalNameMap DirectRef -> LocalNameMap DirectRef
updateNames mp = maybe mp (\n -> HashMap.insert n (mkTempRef (OffsetRef tmpNum (Just n))) mp) mn
c <- braces (localS (over localParamsTempIndex (+ 1)) $ localS (over localParamsNameMap updateNames) parseCode)
c <- braces (localS @LocalParams (over localParamsTempIndex (+ 1)) $ localS @LocalParams (over localParamsNameMap updateNames) parseCode)
return $
Save
( CmdSave
@ -153,7 +156,7 @@ instrAllocClosure ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r InstrAllocClosure
instrAllocClosure = do
sym <- funSymbol @Code @(Maybe FunctionInfoExtra)
sym <- funSymbol @Code @(Maybe FunctionInfoExtra) @DirectRef
(argsNum, _) <- integer
return $ InstrAllocClosure sym (fromInteger argsNum)
@ -179,7 +182,7 @@ instrCall = do
parseCallType ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r CallType
parseCallType = (kw kwDollar $> CallClosure) <|> (CallFun <$> funSymbol @Code @(Maybe FunctionInfoExtra))
parseCallType = (kw kwDollar $> CallClosure) <|> (CallFun <$> funSymbol @Code @(Maybe FunctionInfoExtra) @DirectRef)
instrCallClosures :: ParsecS r InstrCallClosures
instrCallClosures = do
@ -213,7 +216,7 @@ caseBranch ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r CaseBranch
caseBranch = do
tag <- P.try $ constrTag @Code @(Maybe FunctionInfoExtra)
tag <- P.try $ constrTag @Code @(Maybe FunctionInfoExtra) @DirectRef
kw kwColon
c <- CaseBranch tag <$> branchCode
kw delimSemicolon

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

@ -10,6 +10,7 @@ data Target
| TargetVampIR
| TargetCore
| TargetAsm
| TargetReg
| TargetTree
| TargetNockma
deriving stock (Data, Eq, Show)
@ -74,6 +75,21 @@ getLimits tgt debug = case tgt of
defaultLimits
TargetAsm ->
defaultLimits
TargetReg ->
Limits
{ _limitsMaxConstrs = 1048568,
_limitsMaxConstrArgs = 255,
_limitsMaxFunctionArgs = 253,
_limitsMaxLocalVars = 2048,
_limitsMaxClosureSize = 253 + 3,
_limitsClosureHeadSize = 2,
_limitsMaxStringSize = 255 + 1,
_limitsMaxStackDelta = 16368,
_limitsMaxFunctionAlloc = 16368,
_limitsDispatchStackSize = 4,
_limitsBuiltinUIDsNum = 8,
_limitsSpecialisedApply = 3
}
TargetTree ->
defaultLimits
TargetNockma ->

2
src/Juvix/Compiler/Backend/C/Language.hs
View File

@ -14,7 +14,7 @@ data CCode
| Verbatim Text
--------------------------------------------------------------------------------
-- Prepreocessor Directives
-- Preprocessor Directives
--------------------------------------------------------------------------------
data Cpp

59
src/Juvix/Compiler/Backend/C/Translation/FromReg.hs
View File

@ -171,7 +171,7 @@ fromReg lims tab =
fromRegFunction :: (Member CBuilder r) => Reg.ExtraInfo -> Reg.FunctionInfo -> Sem r [Statement]
fromRegFunction info funInfo = do
body <- fromRegCode bNoStack info (funInfo ^. Reg.functionCode)
let tmpDecls = mkDecls "DECL_TMP" (funInfo ^. Reg.functionLocalVarsNum)
let tmpDecls = mkDecls "DECL_TMP" localVarsNum
return
[closureDecl, functionDecl, StatementCompound (tmpDecls ++ body)]
where
@ -184,6 +184,9 @@ fromRegFunction info funInfo = do
maxStackHeight :: Int
maxStackHeight = getMaxStackHeight info sym
localVarsNum :: Int
localVarsNum = getLocalVarsNum info sym
bNoStack :: Bool
bNoStack = maxStackHeight == 0
@ -240,14 +243,12 @@ fromRegInstr bNoStack info = \case
return $ fromAllocClosure x
Reg.ExtendClosure x ->
return $ fromExtendClosure x
Reg.Call x@Reg.InstrCall {..}
| _instrCallIsTail ->
return $ fromTailCall x
Reg.TailCall x ->
return $ fromTailCall x
Reg.Call x ->
fromCall x
Reg.CallClosures x@Reg.InstrCallClosures {..}
| _instrCallClosuresIsTail ->
return $ fromTailCallClosures x
Reg.TailCallClosures x ->
return $ fromTailCallClosures x
Reg.CallClosures x ->
fromCallClosures x
Reg.Return x ->
@ -292,12 +293,7 @@ fromRegInstr bNoStack info = \case
fromValue :: Reg.Value -> Expression
fromValue = \case
Reg.ConstInt x -> macroCall "make_smallint" [integer x]
Reg.ConstBool True -> macroVar "BOOL_TRUE"
Reg.ConstBool False -> macroVar "BOOL_FALSE"
Reg.ConstString x -> macroCall "GET_CONST_CSTRING" [integer (getStringId info x)]
Reg.ConstUnit -> macroVar "OBJ_UNIT"
Reg.ConstVoid -> macroVar "OBJ_VOID"
Reg.Const c -> fromConst c
Reg.CRef Reg.ConstrField {..} ->
case _constrFieldMemRep of
Reg.MemRepConstr ->
@ -312,6 +308,15 @@ fromRegInstr bNoStack info = \case
fromVarRef _constrFieldRef
Reg.VRef x -> fromVarRef x
fromConst :: Reg.Constant -> Expression
fromConst = \case
Reg.ConstInt x -> macroCall "make_smallint" [integer x]
Reg.ConstBool True -> macroVar "BOOL_TRUE"
Reg.ConstBool False -> macroVar "BOOL_FALSE"
Reg.ConstString x -> macroCall "GET_CONST_CSTRING" [integer (getStringId info x)]
Reg.ConstUnit -> macroVar "OBJ_UNIT"
Reg.ConstVoid -> macroVar "OBJ_VOID"
fromPrealloc :: Reg.InstrPrealloc -> Statement
fromPrealloc Reg.InstrPrealloc {..} =
StatementExpr $
@ -382,18 +387,18 @@ fromRegInstr bNoStack info = \case
)
: stmtsAssign (fromVarRef _instrExtendClosureResult) (ExpressionVar "juvix_temp_var")
fromTailCall :: Reg.InstrCall -> [Statement]
fromTailCall Reg.InstrCall {..} =
case _instrCallType of
fromTailCall :: Reg.InstrTailCall -> [Statement]
fromTailCall Reg.InstrTailCall {..} =
case _instrTailCallType of
Reg.CallFun sym ->
stmtsAssignFunArgs _instrCallArgs
stmtsAssignFunArgs _instrTailCallArgs
++ [ StatementExpr $
macroCall
(if bNoStack then "TAIL_CALL_NS" else "TAIL_CALL")
[integer (getFUID info sym), exprLabel info sym]
]
Reg.CallClosure vr ->
stmtsAssignCArgs vr _instrCallArgs
stmtsAssignCArgs vr _instrTailCallArgs
++ [ StatementExpr $
macroCall
(if bNoStack then "TAIL_CALL_CLOSURE_NS" else "TAIL_CALL_CLOSURE")
@ -426,26 +431,26 @@ fromRegInstr bNoStack info = \case
]
++ stmtsPopVars _instrCallLiveVars
fromTailCallClosures :: Reg.InstrCallClosures -> [Statement]
fromTailCallClosures Reg.InstrCallClosures {..}
| argsNum <= 3 =
stmtsAssignCArgs _instrCallClosuresValue _instrCallClosuresArgs
fromTailCallClosures :: Reg.InstrTailCallClosures -> [Statement]
fromTailCallClosures Reg.InstrTailCallClosures {..}
| argsNum <= info ^. Reg.extraInfoSpecialisedApply =
stmtsAssignCArgs _instrTailCallClosuresValue _instrTailCallClosuresArgs
++ [ StatementExpr $
macroCall
("TAIL_APPLY_" <> show argsNum)
[fromVarRef _instrCallClosuresValue]
[fromVarRef _instrTailCallClosuresValue]
]
| otherwise =
stmtsAssignCArgs _instrCallClosuresValue _instrCallClosuresArgs
stmtsAssignCArgs _instrTailCallClosuresValue _instrTailCallClosuresArgs
++ [ StatementExpr $
macroCall
"TAIL_APPLY"
[ fromVarRef _instrCallClosuresValue,
[ fromVarRef _instrTailCallClosuresValue,
integer argsNum
]
]
where
argsNum = length _instrCallClosuresArgs
argsNum = length _instrTailCallClosuresArgs
fromCallClosures :: Reg.InstrCallClosures -> Sem r [Statement]
fromCallClosures Reg.InstrCallClosures {..} = do
@ -461,7 +466,7 @@ fromRegInstr bNoStack info = \case
argsNum = length _instrCallClosuresArgs
call lab =
if
| argsNum <= 3 ->
| argsNum <= info ^. Reg.extraInfoSpecialisedApply ->
StatementExpr $
macroCall
("APPLY_" <> show argsNum)

3
src/Juvix/Compiler/Backend/C/Translation/FromReg/Base.hs
View File

@ -38,6 +38,9 @@ getStringId info txt = fromJust $ HashMap.lookup txt (info ^. Reg.extraInfoStrin
getMaxStackHeight :: Reg.ExtraInfo -> Reg.Symbol -> Int
getMaxStackHeight info sym = fromJust $ HashMap.lookup sym (info ^. Reg.extraInfoMaxStackHeight)
getLocalVarsNum :: Reg.ExtraInfo -> Reg.Symbol -> Int
getLocalVarsNum info sym = fromJust $ HashMap.lookup sym (info ^. Reg.extraInfoLocalVarsNum)
getLabel :: Reg.ExtraInfo -> Reg.Symbol -> Text
getLabel info sym = mkCIdent $ "juvix_function_" <> getFunctionName info sym <> "_" <> show (getFUID info sym)

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

@ -135,6 +135,9 @@ storedCoreToTree = Core.toStripped >=> return . Tree.fromCore . Stripped.fromCor
storedCoreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Asm.InfoTable
storedCoreToAsm = storedCoreToTree >=> treeToAsm
storedCoreToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Reg.InfoTable
storedCoreToReg = storedCoreToAsm >=> asmToReg
storedCoreToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r C.MiniCResult
storedCoreToMiniC = storedCoreToAsm >=> asmToMiniC
@ -157,6 +160,9 @@ coreToTree = Core.toStored >=> storedCoreToTree
coreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Asm.InfoTable
coreToAsm = Core.toStored >=> storedCoreToAsm
coreToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Reg.InfoTable
coreToReg = Core.toStored >=> storedCoreToReg
coreToNockma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r (Nockma.Cell Natural)
coreToNockma = coreToTree >=> treeToNockma
@ -179,14 +185,20 @@ coreToVampIR' = Core.toStored' >=> storedCoreToVampIR'
treeToAsm :: (Member (Error JuvixError) r) => Tree.InfoTable -> Sem r Asm.InfoTable
treeToAsm = Tree.toAsm >=> return . Asm.fromTree
treeToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r Reg.InfoTable
treeToReg = treeToAsm >=> asmToReg
treeToNockma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r (Nockma.Cell Natural)
treeToNockma = Tree.toNockma >=> mapReader NockmaTree.fromEntryPoint . NockmaTree.fromTreeTable
treeToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r C.MiniCResult
treeToMiniC = treeToAsm >=> asmToMiniC
asmToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r Reg.InfoTable
asmToReg = Asm.toReg >=> return . Reg.fromAsm
asmToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r C.MiniCResult
asmToMiniC = Asm.toReg >=> regToMiniC . Reg.fromAsm
asmToMiniC = asmToReg >=> regToMiniC
regToMiniC :: (Member (Reader EntryPoint) r) => Reg.InfoTable -> Sem r C.MiniCResult
regToMiniC tab = do

55
src/Juvix/Compiler/Reg/Data/InfoTable.hs
View File

@ -1,51 +1,12 @@
module Juvix.Compiler.Reg.Data.InfoTable where
module Juvix.Compiler.Reg.Data.InfoTable
( module Juvix.Compiler.Reg.Data.InfoTable,
module Juvix.Compiler.Tree.Data.InfoTable.Base,
)
where
import Juvix.Compiler.Reg.Language
import Juvix.Compiler.Tree.Data.InfoTable.Base
data InfoTable = InfoTable
{ _infoFunctions :: HashMap Symbol FunctionInfo,
_infoConstrs :: HashMap Tag ConstructorInfo,
_infoInductives :: HashMap Symbol InductiveInfo,
_infoMainFunction :: Maybe Symbol
}
type InfoTable = InfoTable' Code ()
data FunctionInfo = FunctionInfo
{ _functionName :: Text,
_functionLocation :: Maybe Location,
_functionSymbol :: Symbol,
_functionArgsNum :: Int,
_functionLocalVarsNum :: Int,
_functionCode :: Code
}
data ConstructorInfo = ConstructorInfo
{ _constructorName :: Text,
_constructorLocation :: Maybe Location,
_constructorTag :: Tag,
_constructorArgsNum :: Int,
_constructorInductive :: Symbol,
_constructorRepresentation :: MemRep,
_constructorFixity :: Maybe Fixity
}
data InductiveInfo = InductiveInfo
{ _inductiveName :: Text,
_inductiveLocation :: Maybe Location,
_inductiveSymbol :: Symbol,
_inductiveConstructors :: [Tag],
_inductiveRepresentation :: IndRep
}
makeLenses ''InfoTable
makeLenses ''FunctionInfo
makeLenses ''ConstructorInfo
makeLenses ''InductiveInfo
emptyInfoTable :: InfoTable
emptyInfoTable =
InfoTable
{ _infoFunctions = mempty,
_infoConstrs = mempty,
_infoInductives = mempty,
_infoMainFunction = Nothing
}
type FunctionInfo = FunctionInfo' Code ()

43
src/Juvix/Compiler/Reg/Data/InfoTableBuilder.hs Normal file
View File

@ -0,0 +1,43 @@
module Juvix.Compiler.Reg.Data.InfoTableBuilder
( module Juvix.Compiler.Reg.Data.InfoTableBuilder,
module Juvix.Compiler.Tree.Data.InfoTableBuilder.Base,
)
where
import Juvix.Compiler.Reg.Data.InfoTable
import Juvix.Compiler.Reg.Language
import Juvix.Compiler.Tree.Data.InfoTableBuilder.Base
type InfoTableBuilder = InfoTableBuilder' Code ()
type BuilderState = BuilderState' Code ()
freshSymbol :: (Member InfoTableBuilder r) => Sem r Symbol
freshSymbol = freshSymbol' @Code @()
freshTag :: (Member InfoTableBuilder r) => Sem r Tag
freshTag = freshTag' @Code @()
registerFunction :: (Member InfoTableBuilder r) => FunctionInfo -> Sem r ()
registerFunction = registerFunction' @Code @()
registerConstr :: (Member InfoTableBuilder r) => ConstructorInfo -> Sem r ()
registerConstr = registerConstr' @Code @()
registerInductive :: (Member InfoTableBuilder r) => InductiveInfo -> Sem r ()
registerInductive = registerInductive' @Code @()
registerForward :: (Member InfoTableBuilder r) => Text -> Symbol -> Sem r ()
registerForward = registerForward' @Code @()
registerMain :: (Member InfoTableBuilder r) => Symbol -> Sem r ()
registerMain = registerMain' @Code @()
getIdent :: (Member InfoTableBuilder r) => Text -> Sem r (Maybe IdentKind)
getIdent = getIdent' @Code @()
getFunctionInfo :: (Member InfoTableBuilder r) => Symbol -> Sem r FunctionInfo
getFunctionInfo = getFunctionInfo' @Code @()
getConstructorInfo :: (Member InfoTableBuilder r) => Tag -> Sem r ConstructorInfo
getConstructorInfo = getConstructorInfo' @Code @()

79
src/Juvix/Compiler/Reg/Extra.hs
View File

@ -30,15 +30,14 @@ computeMaxStackHeight lims = maximum . map go
Alloc {} -> 0
AllocClosure {} -> 0
ExtendClosure {} -> 0
Call InstrCall {..} | _instrCallIsTail -> 0
TailCall {} -> 0
Call InstrCall {..} ->
length _instrCallLiveVars + 1
CallClosures InstrCallClosures {..}
| _instrCallClosuresIsTail ->
length _instrCallClosuresArgs
+ 1
+ lims
^. limitsDispatchStackSize
TailCallClosures InstrTailCallClosures {..} ->
length _instrTailCallClosuresArgs
+ 1
+ lims
^. limitsDispatchStackSize
CallClosures InstrCallClosures {..} ->
length _instrCallClosuresLiveVars
+ length _instrCallClosuresArgs
@ -80,9 +79,12 @@ computeMaxCallClosuresArgsNum = maximum . map go
Alloc {} -> 0
AllocClosure {} -> 0
ExtendClosure {} -> 0
Call InstrCall {} -> 0
Call {} -> 0
TailCall {} -> 0
CallClosures InstrCallClosures {..} ->
length _instrCallClosuresArgs
TailCallClosures InstrTailCallClosures {..} ->
length _instrTailCallClosuresArgs
Return {} -> 0
Branch InstrBranch {..} ->
max
@ -131,8 +133,12 @@ computeStringMap strs = snd . run . execState (HashMap.size strs, strs) . mapM g
mapM_ goVal _instrExtendClosureArgs
Call InstrCall {..} ->
mapM_ goVal _instrCallArgs
TailCall InstrTailCall {..} ->
mapM_ goVal _instrTailCallArgs
CallClosures InstrCallClosures {..} ->
mapM_ goVal _instrCallClosuresArgs
TailCallClosures InstrTailCallClosures {..} ->
mapM_ goVal _instrTailCallClosuresArgs
Return InstrReturn {..} ->
goVal _instrReturnValue
Branch InstrBranch {..} -> do
@ -148,7 +154,7 @@ computeStringMap strs = snd . run . execState (HashMap.size strs, strs) . mapM g
goVal :: (Member (State (Int, HashMap Text Int)) r) => Value -> Sem r ()
goVal = \case
ConstString str ->
Const (ConstString str) ->
modify'
( \(sid :: Int, sstrs) ->
if
@ -157,16 +163,62 @@ computeStringMap strs = snd . run . execState (HashMap.size strs, strs) . mapM g
)
_ -> return ()
computeLocalVarsNum :: Code -> Int
computeLocalVarsNum = maximum . map go
where
go :: Instruction -> Int
go = \case
Nop -> 0
Binop BinaryOp {..} -> goVarRef _binaryOpResult
Show InstrShow {..} -> goVarRef _instrShowResult
StrToInt InstrStrToInt {..} -> goVarRef _instrStrToIntResult
Assign InstrAssign {..} -> goVarRef _instrAssignResult
Trace {} -> 0
Dump -> 0
Failure {} -> 0
ArgsNum InstrArgsNum {..} -> goVarRef _instrArgsNumResult
Prealloc InstrPrealloc {} -> 0
Alloc InstrAlloc {..} -> goVarRef _instrAllocResult
AllocClosure InstrAllocClosure {..} -> goVarRef _instrAllocClosureResult
ExtendClosure InstrExtendClosure {..} -> goVarRef _instrExtendClosureResult
Call InstrCall {..} -> goVarRef _instrCallResult
TailCall {} -> 0
CallClosures InstrCallClosures {..} -> goVarRef _instrCallClosuresResult
TailCallClosures {} -> 0
Return {} -> 0
Branch InstrBranch {..} ->
max
(computeLocalVarsNum _instrBranchTrue)
(computeLocalVarsNum _instrBranchFalse)
Case InstrCase {..} ->
max
( maximum
( map
(computeLocalVarsNum . (^. caseBranchCode))
_instrCaseBranches
)
)
(maybe 0 computeLocalVarsNum _instrCaseDefault)
Block InstrBlock {..} ->
computeLocalVarsNum _instrBlockCode
goVarRef :: VarRef -> Int
goVarRef VarRef {..} = case _varRefGroup of
VarGroupArgs -> 0
VarGroupLocal -> _varRefIndex + 1
data ExtraInfo = ExtraInfo
{ _extraInfoTable :: InfoTable,
_extraInfoUIDs :: HashMap Tag Int,
_extraInfoFUIDs :: HashMap Symbol Int,
_extraInfoStringMap :: HashMap Text Int,
_extraInfoMaxStackHeight :: HashMap Symbol Int,
_extraInfoLocalVarsNum :: HashMap Symbol Int,
_extraInfoMaxArgsNum :: Int,
_extraInfoMaxCallClosuresArgsNum :: Int,
_extraInfoConstrsNum :: Int,
_extraInfoFunctionsNum :: Int
_extraInfoFunctionsNum :: Int,
_extraInfoSpecialisedApply :: Int
}
makeLenses ''ExtraInfo
@ -202,6 +254,10 @@ computeExtraInfo lims tab =
HashMap.map
(computeMaxStackHeight lims . (^. functionCode))
(tab ^. infoFunctions),
_extraInfoLocalVarsNum =
HashMap.map
(computeLocalVarsNum . (^. functionCode))
(tab ^. infoFunctions),
_extraInfoMaxArgsNum =
maximum (map (^. functionArgsNum) (HashMap.elems (tab ^. infoFunctions))),
_extraInfoMaxCallClosuresArgsNum =
@ -212,5 +268,6 @@ computeExtraInfo lims tab =
_extraInfoConstrsNum =
length (userConstrs tab) + lims ^. limitsBuiltinUIDsNum,
_extraInfoFunctionsNum =
HashMap.size (tab ^. infoFunctions)
HashMap.size (tab ^. infoFunctions),
_extraInfoSpecialisedApply = lims ^. limitsSpecialisedApply
}

47
src/Juvix/Compiler/Reg/Keywords.hs Normal file
View File

@ -0,0 +1,47 @@
module Juvix.Compiler.Reg.Keywords
( module Juvix.Compiler.Reg.Keywords,
module Juvix.Compiler.Tree.Keywords.Base,
module Juvix.Data.Keyword.All,
)
where
import Juvix.Compiler.Tree.Keywords.Base
import Juvix.Data.Keyword.All (kwAdd_, kwAlloc, kwArgsNum, kwAtoi, kwBr, kwCAlloc, kwCCall, kwCCallTail, kwCExtend, kwCall, kwCallTail, kwCase, kwDefault, kwDiv_, kwDollar, kwDump, kwEq, kwEq_, kwFail, kwLe_, kwLive, kwLt_, kwMod_, kwMul_, kwNop, kwPrealloc, kwRet, kwShow, kwStrcat, kwSub_, kwTrace)
import Juvix.Prelude
allKeywordStrings :: HashSet Text
allKeywordStrings = keywordsStrings allKeywords
allKeywords :: [Keyword]
allKeywords =
baseKeywords
++ [ kwNop,
kwAdd_,
kwSub_,
kwMul_,
kwDiv_,
kwMod_,
kwLt_,
kwLe_,
kwEq_,
kwStrcat,
kwEq,
kwShow,
kwAtoi,
kwTrace,
kwDump,
kwPrealloc,
kwAlloc,
kwCAlloc,
kwCExtend,
kwCall,
kwCallTail,
kwLive,
kwCCall,
kwCCallTail,
kwRet,
kwBr,
kwCase,
kwFail,
kwArgsNum
]

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

@ -7,13 +7,10 @@ where
import Juvix.Compiler.Reg.Language.Base
data Value
= ConstInt Integer
| ConstBool Bool
| ConstString Text
| ConstUnit
| ConstVoid
= Const Constant
| CRef ConstrField
| VRef VarRef
deriving stock (Eq)
type Index = Int
@ -27,13 +24,19 @@ data ConstrField = ConstrField
_constrFieldRef :: VarRef,
_constrFieldIndex :: Index
}
deriving stock (Eq)
data VarGroup = VarGroupArgs | VarGroupLocal
data VarGroup
= VarGroupArgs
| VarGroupLocal
deriving stock (Eq)
data VarRef = VarRef
{ _varRefGroup :: VarGroup,
_varRefIndex :: Index
_varRefIndex :: Index,
_varRefName :: Maybe Text
}
deriving stock (Eq)
data Instruction
= Nop -- no operation
@ -50,11 +53,14 @@ data Instruction
| AllocClosure InstrAllocClosure
| ExtendClosure InstrExtendClosure
| Call InstrCall
| TailCall InstrTailCall
| CallClosures InstrCallClosures
| TailCallClosures InstrTailCallClosures
| Return InstrReturn
| Branch InstrBranch
| Case InstrCase
| Block InstrBlock
deriving stock (Eq)
type Code = [Instruction]
@ -64,6 +70,7 @@ data BinaryOp = BinaryOp
_binaryOpArg1 :: Value,
_binaryOpArg2 :: Value
}
deriving stock (Eq)
data Opcode
= OpIntAdd
@ -75,39 +82,47 @@ data Opcode
| OpIntLe
| OpEq
| OpStrConcat
deriving stock (Eq)
data InstrShow = InstrShow
{ _instrShowResult :: VarRef,
_instrShowValue :: Value
}
deriving stock (Eq)
data InstrStrToInt = InstrStrToInt
{ _instrStrToIntResult :: VarRef,
_instrStrToIntValue :: Value
}
deriving stock (Eq)
data InstrAssign = InstrAssign
{ _instrAssignResult :: VarRef,
_instrAssignValue :: Value
}
deriving stock (Eq)
newtype InstrTrace = InstrTrace
{ _instrTraceValue :: Value
}
deriving stock (Eq)
newtype InstrFailure = InstrFailure
{ _instrFailureValue :: Value
}
deriving stock (Eq)
data InstrArgsNum = InstrArgsNum
{ _instrArgsNumResult :: VarRef,
_instrArgsNumValue :: Value
}
deriving stock (Eq)
data InstrPrealloc = InstrPrealloc
{ _instrPreallocWordsNum :: Int,
_instrPreallocLiveVars :: [VarRef]
}
deriving stock (Eq)
data InstrAlloc = InstrAlloc
{ _instrAllocResult :: VarRef,
@ -115,6 +130,7 @@ data InstrAlloc = InstrAlloc
_instrAllocMemRep :: MemRep,
_instrAllocArgs :: [Value]
}
deriving stock (Eq)
data InstrAllocClosure = InstrAllocClosure
{ _instrAllocClosureResult :: VarRef,
@ -122,43 +138,61 @@ data InstrAllocClosure = InstrAllocClosure
_instrAllocClosureExpectedArgsNum :: Int,
_instrAllocClosureArgs :: [Value]
}
deriving stock (Eq)
data InstrExtendClosure = InstrExtendClosure
{ _instrExtendClosureResult :: VarRef,
_instrExtendClosureValue :: VarRef,
_instrExtendClosureArgs :: [Value]
}
deriving stock (Eq)
data CallType = CallFun Symbol | CallClosure VarRef
data CallType
= CallFun Symbol
| CallClosure VarRef
deriving stock (Eq)
data InstrCall = InstrCall
{ _instrCallResult :: VarRef,
_instrCallType :: CallType,
_instrCallIsTail :: Bool,
_instrCallArgs :: [Value],
-- | Variables live at the point of the call. If the call is not
-- tail-recursive, live variables need to be saved before the call and
-- restored after it.
-- | Variables live at the point of the call. Live variables need to be
-- saved before the call and restored after it.
_instrCallLiveVars :: [VarRef]
}
deriving stock (Eq)
data InstrTailCall = InstrTailCall
{ _instrTailCallType :: CallType,
_instrTailCallArgs :: [Value]
}
deriving stock (Eq)
data InstrCallClosures = InstrCallClosures
{ _instrCallClosuresResult :: VarRef,
_instrCallClosuresIsTail :: Bool,
_instrCallClosuresValue :: VarRef,
_instrCallClosuresArgs :: [Value],
_instrCallClosuresLiveVars :: [VarRef]
}
deriving stock (Eq)
data InstrTailCallClosures = InstrTailCallClosures
{ _instrTailCallClosuresValue :: VarRef,
_instrTailCallClosuresArgs :: [Value]
}
deriving stock (Eq)
newtype InstrReturn = InstrReturn
{ _instrReturnValue :: Value
}
deriving stock (Eq)
data InstrBranch = InstrBranch
{ _instrBranchValue :: Value,
_instrBranchTrue :: Code,
_instrBranchFalse :: Code
}
deriving stock (Eq)
data InstrCase = InstrCase
{ _instrCaseValue :: Value,
@ -167,6 +201,7 @@ data InstrCase = InstrCase
_instrCaseBranches :: [CaseBranch],
_instrCaseDefault :: Maybe Code
}
deriving stock (Eq)
data CaseBranch = CaseBranch
{ _caseBranchTag :: Tag,
@ -175,10 +210,12 @@ data CaseBranch = CaseBranch
_caseBranchArgsNum :: Int,
_caseBranchCode :: Code
}
deriving stock (Eq)
newtype InstrBlock = InstrBlock
{ _instrBlockCode :: Code
}
deriving stock (Eq)
makeLenses ''ConstrField
makeLenses ''BinaryOp
@ -195,3 +232,11 @@ makeLenses ''InstrBranch
makeLenses ''InstrCase
makeLenses ''CaseBranch
makeLenses ''InstrReturn
mkVarRef :: VarGroup -> Index -> VarRef
mkVarRef g i =
VarRef
{ _varRefGroup = g,
_varRefIndex = i,
_varRefName = Nothing
}

2
src/Juvix/Compiler/Reg/Language/Base.hs
View File

@ -1,8 +1,10 @@
module Juvix.Compiler.Reg.Language.Base
( module Juvix.Compiler.Core.Language.Base,
module Juvix.Compiler.Tree.Language.Base,
module Juvix.Compiler.Tree.Language.Rep,
)
where
import Juvix.Compiler.Core.Language.Base hiding (Index)
import Juvix.Compiler.Tree.Language.Base (Constant (..))
import Juvix.Compiler.Tree.Language.Rep

28
src/Juvix/Compiler/Reg/Pretty.hs Normal file
View File

@ -0,0 +1,28 @@
module Juvix.Compiler.Reg.Pretty
( module Juvix.Compiler.Reg.Pretty,
module Juvix.Compiler.Reg.Pretty.Base,
module Juvix.Compiler.Reg.Pretty.Options,
)
where
import Juvix.Compiler.Reg.Data.InfoTable
import Juvix.Compiler.Reg.Pretty.Base
import Juvix.Compiler.Reg.Pretty.Options
import Juvix.Data.PPOutput
import Juvix.Prelude
import Prettyprinter.Render.Terminal qualified as Ansi
ppOutDefault :: (PrettyCode c) => InfoTable -> c -> AnsiText
ppOutDefault tab = mkAnsiText . PPOutput . doc (defaultOptions tab)
ppOut :: (PrettyCode c) => Options -> c -> AnsiText
ppOut o = mkAnsiText . PPOutput . doc o
ppTrace' :: (PrettyCode c) => Options -> c -> Text
ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc opts
ppTrace :: (PrettyCode c) => InfoTable -> c -> Text
ppTrace tab = ppTrace' (defaultOptions tab)
ppPrint :: (PrettyCode c) => InfoTable -> c -> Text
ppPrint tab = show . ppOutDefault tab

285
src/Juvix/Compiler/Reg/Pretty/Base.hs Normal file
View File

@ -0,0 +1,285 @@
module Juvix.Compiler.Reg.Pretty.Base
( module Juvix.Compiler.Reg.Pretty.Base,
module Juvix.Compiler.Reg.Pretty.Options,
)
where
import Data.Foldable
import Juvix.Compiler.Reg.Data.InfoTable
import Juvix.Compiler.Reg.Language
import Juvix.Compiler.Reg.Pretty.Options
import Juvix.Compiler.Tree.Pretty.Base qualified as Tree
import Juvix.Compiler.Tree.Pretty.Extra
import Juvix.Data.CodeAnn
import Juvix.Extra.Strings qualified as Str
doc :: (PrettyCode c) => Options -> c -> Doc Ann
doc opts =
run
. runReader opts
. ppCode
class PrettyCode c where
ppCode :: (Member (Reader Options) r) => c -> Sem r (Doc Ann)
instance PrettyCode VarRef where
ppCode VarRef {..} = case _varRefName of
Just n -> return $ variable (quoteName n)
Nothing -> case _varRefGroup of
VarGroupArgs -> return $ ppRef Str.arg _varRefIndex
VarGroupLocal -> return $ ppRef Str.tmp _varRefIndex
where
ppRef :: Text -> Index -> Doc Ann
ppRef str off = variable str <> brackets (integer off)
instance PrettyCode ConstrField where
ppCode ConstrField {..} = do
dr <- ppCode _constrFieldRef
ctr <- Tree.ppConstrName _constrFieldTag
return $ dr <> dot <> ctr <> brackets (integer _constrFieldIndex)
instance PrettyCode Value where
ppCode = \case
Const x -> Tree.ppCode x
CRef x -> ppCode x
VRef x -> ppCode x
instance PrettyCode Opcode where
ppCode = \case
OpIntAdd -> return $ primitive Str.add_
OpIntSub -> return $ primitive Str.sub_
OpIntMul -> return $ primitive Str.mul_
OpIntDiv -> return $ primitive Str.div_
OpIntMod -> return $ primitive Str.mod_
OpIntLt -> return $ primitive Str.lt_
OpIntLe -> return $ primitive Str.le_
OpEq -> return $ primitive Str.eq
OpStrConcat -> return $ primitive Str.instrStrConcat
instance PrettyCode BinaryOp where
ppCode BinaryOp {..} = do
res <- ppCode _binaryOpResult
arg1 <- ppCode _binaryOpArg1
arg2 <- ppCode _binaryOpArg2
op <- ppCode _binaryOpCode
return $ res <+> primitive Str.equal <+> op <+> arg1 <+> arg2
instance PrettyCode InstrShow where
ppCode InstrShow {..} = do
res <- ppCode _instrShowResult
val <- ppCode _instrShowValue
return $ res <+> primitive Str.equal <+> primitive Str.show_ <+> val
instance PrettyCode InstrStrToInt where
ppCode InstrStrToInt {..} = do
res <- ppCode _instrStrToIntResult
val <- ppCode _instrStrToIntValue
return $ res <+> primitive Str.equal <+> primitive Str.instrStrToInt <+> val
instance PrettyCode InstrAssign where
ppCode InstrAssign {..} = do
res <- ppCode _instrAssignResult
val <- ppCode _instrAssignValue
return $ res <+> primitive Str.equal <+> val
instance PrettyCode InstrTrace where
ppCode InstrTrace {..} = do
val <- ppCode _instrTraceValue
return $ primitive Str.trace_ <+> val
instance PrettyCode InstrFailure where
ppCode InstrFailure {..} = do
val <- ppCode _instrFailureValue
return $ primitive Str.fail_ <+> val
instance PrettyCode InstrArgsNum where
ppCode InstrArgsNum {..} = do
res <- ppCode _instrArgsNumResult
val <- ppCode _instrArgsNumValue
return $ res <+> primitive Str.equal <+> primitive Str.argsnum <+> val
ppLiveVars :: (Member (Reader Options) r) => [VarRef] -> Sem r (Doc Ann)
ppLiveVars vars
| null vars = return mempty
| otherwise = do
vars' <- mapM ppCode vars
return $ comma <+> primitive "live:" <+> arglist vars'
instance PrettyCode InstrPrealloc where
ppCode InstrPrealloc {..} = do
vars <- ppLiveVars _instrPreallocLiveVars
return $ primitive Str.prealloc <+> integer _instrPreallocWordsNum <> vars
instance PrettyCode InstrAlloc where
ppCode InstrAlloc {..} = do
res <- ppCode _instrAllocResult
tag <- Tree.ppConstrName _instrAllocTag
args <- mapM ppCode _instrAllocArgs
return $
res
<+> primitive Str.equal
<+> primitive Str.alloc
<+> tag
<+> arglist args
instance PrettyCode InstrAllocClosure where
ppCode InstrAllocClosure {..} = do
res <- ppCode _instrAllocClosureResult
fn <- Tree.ppFunName _instrAllocClosureSymbol
args <- mapM ppCode _instrAllocClosureArgs
return $
res
<+> primitive Str.equal
<+> primitive Str.calloc
<+> fn
<+> arglist args
instance PrettyCode InstrExtendClosure where
ppCode InstrExtendClosure {..} = do
res <- ppCode _instrExtendClosureResult
fn <- ppCode _instrExtendClosureValue
args <- mapM ppCode _instrExtendClosureArgs
return $
res
<+> primitive Str.equal
<+> primitive Str.cextend
<+> fn
<+> arglist args
instance PrettyCode CallType where
ppCode = \case
CallFun sym -> Tree.ppFunName sym
CallClosure cl -> ppCode cl
instance PrettyCode InstrCall where
ppCode InstrCall {..} = do
res <- ppCode _instrCallResult
fn <- ppCode _instrCallType
args <- mapM ppCode _instrCallArgs
vars <- ppLiveVars _instrCallLiveVars
return $
res
<+> primitive Str.equal
<+> primitive Str.call
<+> fn
<+> arglist args
<> vars
instance PrettyCode InstrTailCall where
ppCode InstrTailCall {..} = do
fn <- ppCode _instrTailCallType
args <- mapM ppCode _instrTailCallArgs
return $
primitive Str.tcall
<+> fn
<+> arglist args
instance PrettyCode InstrCallClosures where
ppCode InstrCallClosures {..} = do
res <- ppCode _instrCallClosuresResult
fn <- ppCode _instrCallClosuresValue
args <- mapM ppCode _instrCallClosuresArgs
vars <- ppLiveVars _instrCallClosuresLiveVars
return $
res
<+> primitive Str.equal
<+> primitive Str.ccall
<+> fn
<+> arglist args
<> vars
instance PrettyCode InstrTailCallClosures where
ppCode InstrTailCallClosures {..} = do
fn <- ppCode _instrTailCallClosuresValue
args <- mapM ppCode _instrTailCallClosuresArgs
return $
primitive Str.instrTccall
<+> fn
<+> arglist args
instance PrettyCode InstrReturn where
ppCode InstrReturn {..} = do
val <- ppCode _instrReturnValue
return $ primitive Str.ret <+> val
instance PrettyCode InstrBranch where
ppCode InstrBranch {..} = do
val <- ppCode _instrBranchValue
br1 <- ppCodeCode _instrBranchTrue
br2 <- ppCodeCode _instrBranchFalse
return $
primitive Str.br
<+> val
<+> braces'
( constr Str.true_ <> colon
<+> braces' br1
<> semi
<> line
<> constr Str.false_
<> colon
<+> braces' br2 <> semi
)
instance PrettyCode CaseBranch where
ppCode CaseBranch {..} = do
tag <- Tree.ppConstrName _caseBranchTag
body <- ppCodeCode _caseBranchCode
return $ tag <> colon <+> braces' body <> semi
ppDefaultBranch :: (Member (Reader Options) r) => Code -> Sem r (Doc Ann)
ppDefaultBranch cs = do
body <- ppCodeCode cs
return $ constr Str.default_ <> colon <+> braces' body <> semi
instance PrettyCode InstrCase where
ppCode InstrCase {..} = do
ind <- Tree.ppIndName _instrCaseInductive
val <- ppCode _instrCaseValue
brs <- mapM ppCode _instrCaseBranches
def <- maybe (return Nothing) (fmap Just . ppDefaultBranch) _instrCaseDefault
let brs' = brs ++ catMaybes [def]
return $ primitive Str.case_ <> brackets ind <+> val <+> braces' (vsep brs')
instance PrettyCode InstrBlock where
ppCode InstrBlock {..} = braces' <$> ppCodeCode _instrBlockCode
instance PrettyCode Instruction where
ppCode = \case
Nop -> return $ primitive Str.nop
Binop x -> ppCode x
Show x -> ppCode x
StrToInt x -> ppCode x
Assign x -> ppCode x
Trace x -> ppCode x
Dump -> return $ primitive Str.dump
Failure x -> ppCode x
ArgsNum x -> ppCode x
Prealloc x -> ppCode x
Alloc x -> ppCode x
AllocClosure x -> ppCode x
ExtendClosure x -> ppCode x
Call x -> ppCode x
TailCall x -> ppCode x
CallClosures x -> ppCode x
TailCallClosures x -> ppCode x
Return x -> ppCode x
Branch x -> ppCode x
Case x -> ppCode x
Block x -> ppCode x
ppCodeCode :: (Member (Reader Options) r) => Code -> Sem r (Doc Ann)
ppCodeCode x = do
cs <- mapM ppCode x
return $ vcat $ map (<> semi) cs
instance PrettyCode FunctionInfo where
ppCode = Tree.ppFunInfo ppCodeCode
instance PrettyCode ConstructorInfo where
ppCode = Tree.ppCode
instance PrettyCode InfoTable where
ppCode = Tree.ppInfoTable ppCodeCode
arglist :: [Doc Ann] -> Doc Ann
arglist args = parens (hsep (punctuate comma args))

6
src/Juvix/Compiler/Reg/Pretty/Options.hs Normal file
View File

@ -0,0 +1,6 @@
module Juvix.Compiler.Reg.Pretty.Options
( module Juvix.Compiler.Tree.Pretty.Options,
)
where
import Juvix.Compiler.Tree.Pretty.Options

132
src/Juvix/Compiler/Reg/Translation/FromAsm.hs
View File

@ -24,33 +24,17 @@ fromAsm tab =
_functionLocation = fi ^. Asm.functionLocation,
_functionSymbol = fi ^. Asm.functionSymbol,
_functionArgsNum = fi ^. Asm.functionArgsNum,
_functionLocalVarsNum = extra ^. Asm.functionMaxTempStackHeight + extra ^. Asm.functionMaxValueStackHeight,
_functionArgNames = fi ^. Asm.functionArgNames,
_functionType = fi ^. Asm.functionType,
_functionExtra = (),
_functionCode = fromAsmFun tab fi
}
where
extra = fromJust (fi ^. Asm.functionExtra)
convertConstr :: Asm.ConstructorInfo -> ConstructorInfo
convertConstr ci =
ConstructorInfo
{ _constructorName = ci ^. Asm.constructorName,
_constructorLocation = ci ^. Asm.constructorLocation,
_constructorTag = ci ^. Asm.constructorTag,
_constructorArgsNum = ci ^. Asm.constructorArgsNum,
_constructorInductive = ci ^. Asm.constructorInductive,
_constructorRepresentation = ci ^. Asm.constructorRepresentation,
_constructorFixity = ci ^. Asm.constructorFixity
}
convertConstr ci = ci
convertInductive :: Asm.InductiveInfo -> InductiveInfo
convertInductive ii =
InductiveInfo
{ _inductiveName = ii ^. Asm.inductiveName,
_inductiveLocation = ii ^. Asm.inductiveLocation,
_inductiveSymbol = ii ^. Asm.inductiveSymbol,
_inductiveConstructors = ii ^. Asm.inductiveConstructors,
_inductiveRepresentation = ii ^. Asm.inductiveRepresentation
}
convertInductive ii = ii
fromAsmFun ::
Asm.InfoTable ->
@ -80,14 +64,14 @@ fromAsmInstr ::
fromAsmInstr funInfo tab si Asm.CmdInstr {..} =
case _cmdInstrInstruction of
Asm.Binop op -> return $ mkBinop (mkOpcode op)
Asm.ValShow -> return $ mkShow (VarRef VarGroupLocal (ntmps + n)) (VRef $ VarRef VarGroupLocal (ntmps + n))
Asm.StrToInt -> return $ mkStrToInt (VarRef VarGroupLocal (ntmps + n)) (VRef $ VarRef VarGroupLocal (ntmps + n))
Asm.Push val -> return $ mkAssign (VarRef VarGroupLocal (ntmps + n + 1)) (mkValue val)
Asm.ValShow -> return $ mkShow (mkVarRef VarGroupLocal (ntmps + n)) (VRef $ mkVarRef VarGroupLocal (ntmps + n))
Asm.StrToInt -> return $ mkStrToInt (mkVarRef VarGroupLocal (ntmps + n)) (VRef $ mkVarRef VarGroupLocal (ntmps + n))
Asm.Push val -> return $ mkAssign (mkVarRef VarGroupLocal (ntmps + n + 1)) (mkValue val)
Asm.Pop -> return Nop
Asm.Trace -> return $ Trace $ InstrTrace (VRef $ VarRef VarGroupLocal (ntmps + n))
Asm.Trace -> return $ Trace $ InstrTrace (VRef $ mkVarRef VarGroupLocal (ntmps + n))
Asm.Dump -> return Dump
Asm.Failure -> return $ Failure $ InstrFailure (VRef $ VarRef VarGroupLocal (ntmps + n))
Asm.ArgsNum -> return $ mkArgsNum (VarRef VarGroupLocal (ntmps + n)) (VRef $ VarRef VarGroupLocal (ntmps + n))
Asm.Failure -> return $ Failure $ InstrFailure (VRef $ mkVarRef VarGroupLocal (ntmps + n))
Asm.ArgsNum -> return $ mkArgsNum (mkVarRef VarGroupLocal (ntmps + n)) (VRef $ mkVarRef VarGroupLocal (ntmps + n))
Asm.Prealloc x -> return $ mkPrealloc x
Asm.AllocConstr tag -> return $ mkAlloc tag
Asm.AllocClosure x -> return $ mkAllocClosure x
@ -97,7 +81,7 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} =
Asm.CallClosures x -> return $ mkCallClosures False x
Asm.TailCallClosures x -> return $ mkCallClosures True x
Asm.Return ->
return $ Return InstrReturn {_instrReturnValue = VRef $ VarRef VarGroupLocal ntmps}
return $ Return InstrReturn {_instrReturnValue = VRef $ mkVarRef VarGroupLocal ntmps}
where
extraInfo :: Asm.FunctionInfoExtra
extraInfo = fromJust (funInfo ^. Asm.functionExtra)
@ -116,21 +100,21 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} =
-- liveness analysis in JuvixAsm.
liveVars :: Int -> [VarRef]
liveVars k =
map (VarRef VarGroupLocal) [0 .. si ^. Asm.stackInfoTempStackHeight - 1]
++ map (VarRef VarGroupLocal) [ntmps .. ntmps + n - k]
++ map (VarRef VarGroupArgs) [0 .. funInfo ^. Asm.functionArgsNum - 1]
map (mkVarRef VarGroupLocal) [0 .. si ^. Asm.stackInfoTempStackHeight - 1]
++ map (mkVarRef VarGroupLocal) [ntmps .. ntmps + n - k]
++ map (mkVarRef VarGroupArgs) [0 .. funInfo ^. Asm.functionArgsNum - 1]
getArgs :: Int -> Int -> [Value]
getArgs s k = map (\i -> VRef $ VarRef VarGroupLocal (ntmps + n - i)) [s .. (s + k - 1)]
getArgs s k = map (\i -> VRef $ mkVarRef VarGroupLocal (ntmps + n - i)) [s .. (s + k - 1)]
mkBinop :: Opcode -> Instruction
mkBinop op =
Binop
( BinaryOp
{ _binaryOpCode = op,
_binaryOpResult = VarRef VarGroupLocal (ntmps + n - 1),
_binaryOpArg1 = VRef $ VarRef VarGroupLocal (ntmps + n),
_binaryOpArg2 = VRef $ VarRef VarGroupLocal (ntmps + n - 1)
_binaryOpResult = mkVarRef VarGroupLocal (ntmps + n - 1),
_binaryOpArg1 = VRef $ mkVarRef VarGroupLocal (ntmps + n),
_binaryOpArg2 = VRef $ mkVarRef VarGroupLocal (ntmps + n - 1)
}
)
@ -160,11 +144,7 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} =
mkValue :: Asm.Value -> Value
mkValue = \case
Asm.Constant (Asm.ConstInt v) -> ConstInt v
Asm.Constant (Asm.ConstBool v) -> ConstBool v
Asm.Constant (Asm.ConstString v) -> ConstString v
Asm.Constant Asm.ConstUnit -> ConstUnit
Asm.Constant Asm.ConstVoid -> ConstVoid
Asm.Constant c -> Const c
Asm.Ref mv -> case mv of
Asm.DRef dref -> VRef $ mkVar dref
Asm.ConstrRef Asm.Field {..} ->
@ -180,8 +160,8 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} =
mkVar :: Asm.DirectRef -> VarRef
mkVar = \case
Asm.ArgRef Asm.OffsetRef {..} -> VarRef VarGroupArgs _offsetRefOffset
Asm.TempRef Asm.RefTemp {..} -> VarRef VarGroupLocal (_refTempOffsetRef ^. Asm.offsetRefOffset)
Asm.ArgRef Asm.OffsetRef {..} -> VarRef VarGroupArgs _offsetRefOffset _offsetRefName
Asm.TempRef Asm.RefTemp {..} -> VarRef VarGroupLocal (_refTempOffsetRef ^. Asm.offsetRefOffset) (_refTempOffsetRef ^. Asm.offsetRefName)
mkPrealloc :: Asm.InstrPrealloc -> Instruction
mkPrealloc Asm.InstrPrealloc {..} =
@ -196,7 +176,7 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} =
Alloc $
InstrAlloc
{ _instrAllocTag = tag,
_instrAllocResult = VarRef VarGroupLocal (ntmps + m),
_instrAllocResult = mkVarRef VarGroupLocal (ntmps + m),
_instrAllocArgs = getArgs 0 (ci ^. Asm.constructorArgsNum),
_instrAllocMemRep = ci ^. Asm.constructorRepresentation
}
@ -209,7 +189,7 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} =
AllocClosure $
InstrAllocClosure
{ _instrAllocClosureSymbol = fi ^. Asm.functionSymbol,
_instrAllocClosureResult = VarRef VarGroupLocal (ntmps + m),
_instrAllocClosureResult = mkVarRef VarGroupLocal (ntmps + m),
_instrAllocClosureExpectedArgsNum = fi ^. Asm.functionArgsNum,
_instrAllocClosureArgs = getArgs 0 _allocClosureArgsNum
}
@ -221,42 +201,54 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} =
mkExtendClosure Asm.InstrExtendClosure {..} =
ExtendClosure $
InstrExtendClosure
{ _instrExtendClosureResult = VarRef VarGroupLocal (ntmps + m),
_instrExtendClosureValue = VarRef VarGroupLocal (ntmps + n),
{ _instrExtendClosureResult = mkVarRef VarGroupLocal (ntmps + m),
_instrExtendClosureValue = mkVarRef VarGroupLocal (ntmps + n),
_instrExtendClosureArgs = getArgs 1 _extendClosureArgsNum
}
where
m = n - _extendClosureArgsNum
mkCall :: Bool -> Asm.InstrCall -> Instruction
mkCall isTail Asm.InstrCall {..} =
Call $
InstrCall
{ _instrCallResult = VarRef VarGroupLocal (ntmps + m),
_instrCallType = ct,
_instrCallIsTail = isTail,
_instrCallArgs = getArgs s _callArgsNum,
_instrCallLiveVars = liveVars (_callArgsNum + s)
}
mkCall isTail Asm.InstrCall {..}
| not isTail =
Call $
InstrCall
{ _instrCallResult = mkVarRef VarGroupLocal (ntmps + m),
_instrCallType = ct,
_instrCallArgs = getArgs s _callArgsNum,
_instrCallLiveVars = liveVars (_callArgsNum + s)
}
| otherwise =
TailCall $
InstrTailCall
{ _instrTailCallType = ct,
_instrTailCallArgs = getArgs s _callArgsNum
}
where
m = n - _callArgsNum - s + 1
ct = case _callType of
Asm.CallFun f -> CallFun f
Asm.CallClosure -> CallClosure (VarRef VarGroupLocal (ntmps + n))
Asm.CallClosure -> CallClosure (mkVarRef VarGroupLocal (ntmps + n))
s = case _callType of
Asm.CallFun {} -> 0
Asm.CallClosure -> 1
mkCallClosures :: Bool -> Asm.InstrCallClosures -> Instruction
mkCallClosures isTail Asm.InstrCallClosures {..} =
CallClosures $
InstrCallClosures
{ _instrCallClosuresResult = VarRef VarGroupLocal (ntmps + m),
_instrCallClosuresValue = VarRef VarGroupLocal (ntmps + n),
_instrCallClosuresIsTail = isTail,
_instrCallClosuresArgs = getArgs 1 _callClosuresArgsNum,
_instrCallClosuresLiveVars = liveVars (_callClosuresArgsNum + 1)
}
mkCallClosures isTail Asm.InstrCallClosures {..}
| not isTail =
CallClosures $
InstrCallClosures
{ _instrCallClosuresResult = mkVarRef VarGroupLocal (ntmps + m),
_instrCallClosuresValue = mkVarRef VarGroupLocal (ntmps + n),
_instrCallClosuresArgs = getArgs 1 _callClosuresArgsNum,
_instrCallClosuresLiveVars = liveVars (_callClosuresArgsNum + 1)
}
| otherwise =
TailCallClosures $
InstrTailCallClosures
{ _instrTailCallClosuresValue = mkVarRef VarGroupLocal (ntmps + n),
_instrTailCallClosuresArgs = getArgs 1 _callClosuresArgsNum
}
where
-- note: the value (closure) is also on the stack
m = n - _callClosuresArgsNum
@ -272,7 +264,7 @@ fromAsmBranch fi si Asm.CmdBranch {} codeTrue codeFalse =
return $
Branch $
InstrBranch
{ _instrBranchValue = VRef $ VarRef VarGroupLocal (fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1),
{ _instrBranchValue = VRef $ mkVarRef VarGroupLocal (fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1),
_instrBranchTrue = codeTrue,
_instrBranchFalse = codeFalse
}
@ -289,7 +281,7 @@ fromAsmCase fi tab si Asm.CmdCase {..} brs def =
return $
Case $
InstrCase
{ _instrCaseValue = VRef $ VarRef VarGroupLocal (fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1),
{ _instrCaseValue = VRef $ mkVarRef VarGroupLocal (fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1),
_instrCaseInductive = _cmdCaseInductive,
_instrCaseIndRep = ii ^. Asm.inductiveRepresentation,
_instrCaseBranches =
@ -321,15 +313,15 @@ fromAsmSave ::
Asm.CmdSave ->
Code ->
Sem r Instruction
fromAsmSave fi si Asm.CmdSave {} block =
fromAsmSave fi si Asm.CmdSave {..} block =
return $
Block $
InstrBlock
{ _instrBlockCode =
Assign
( InstrAssign
(VarRef VarGroupLocal (si ^. Asm.stackInfoTempStackHeight))
(VRef $ VarRef VarGroupLocal (fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1))
(VarRef VarGroupLocal (si ^. Asm.stackInfoTempStackHeight) _cmdSaveName)
(VRef $ mkVarRef VarGroupLocal (fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1))
)
: block
}

489
src/Juvix/Compiler/Reg/Translation/FromSource.hs Normal file
View File

@ -0,0 +1,489 @@
module Juvix.Compiler.Reg.Translation.FromSource
( module Juvix.Compiler.Reg.Translation.FromSource,
module Juvix.Parser.Error,
BuilderState,
)
where
import Control.Monad.Trans.Class (lift)
import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Reg.Data.InfoTable
import Juvix.Compiler.Reg.Data.InfoTableBuilder
import Juvix.Compiler.Reg.Language
import Juvix.Compiler.Reg.Translation.FromSource.Lexer
import Juvix.Compiler.Tree.Translation.FromSource.Base
import Juvix.Compiler.Tree.Translation.FromSource.Sig qualified as S
import Juvix.Parser.Error
import Text.Megaparsec qualified as P
type ParserSig = S.ParserSig Code () VarRef
type LocalParams = LocalParams' VarRef
parseRegSig :: ParserSig
parseRegSig =
S.ParserSig
{ _parserSigBareIdentifier = bareIdentifier,
_parserSigParseCode = parseCode,
_parserSigArgRef = VarRef VarGroupArgs,
_parserSigEmptyCode = [],
_parserSigEmptyExtra = ()
}
parseText :: Text -> Either MegaparsecError InfoTable
parseText = runParser ""
parseText' :: BuilderState -> Text -> Either MegaparsecError BuilderState
parseText' bs = runParser' bs ""
runParser :: FilePath -> Text -> Either MegaparsecError InfoTable
runParser = runParserS parseRegSig
runParser' :: BuilderState -> FilePath -> Text -> Either MegaparsecError BuilderState
runParser' = runParserS' parseRegSig
parseCode ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r Code
parseCode = P.sepEndBy instruction (kw delimSemicolon)
instruction ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r Instruction
instruction =
(instrNop >> return Nop)
<|> (Trace <$> instrTrace)
<|> (instrDump >> return Dump)
<|> (Failure <$> instrFailure)
<|> (Prealloc <$> instrPrealloc)
<|> (TailCall <$> instrTailCall)
<|> (TailCallClosures <$> instrTailCallClosures)
<|> (Return <$> instrReturn)
<|> (Branch <$> instrBranch)
<|> (Case <$> instrCase)
<|> (Block <$> instrBlock)
<|> instrWithResult
instrWithResult ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r Instruction
instrWithResult = do
vref <- declVarRef
kw kwEq
(Binop <$> instrBinop vref)
<|> (Show <$> instrShow vref)
<|> (StrToInt <$> instrStrToInt vref)
<|> (ArgsNum <$> instrArgsNum vref)
<|> (Alloc <$> instrAlloc vref)
<|> (AllocClosure <$> instrAllocClosure vref)
<|> (ExtendClosure <$> instrExtendClosure vref)
<|> (Call <$> instrCall vref)
<|> (CallClosures <$> instrCallClosures vref)
<|> (Assign <$> instrAssign vref)
instrNop :: ParsecS r ()
instrNop = kw kwNop
instrBinop ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
VarRef ->
ParsecS r BinaryOp
instrBinop vref =
parseBinaryOp kwAdd_ OpIntAdd vref
<|> parseBinaryOp kwSub_ OpIntSub vref
<|> parseBinaryOp kwMul_ OpIntMul vref
<|> parseBinaryOp kwDiv_ OpIntDiv vref
<|> parseBinaryOp kwMod_ OpIntMod vref
<|> parseBinaryOp kwLt_ OpIntLt vref
<|> parseBinaryOp kwLe_ OpIntLe vref
<|> parseBinaryOp kwEq_ OpEq vref
<|> parseBinaryOp kwStrcat OpStrConcat vref
parseBinaryOp ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
Keyword ->
Opcode ->
VarRef ->
ParsecS r BinaryOp
parseBinaryOp kwd op vref = do
kw kwd
arg1 <- value
arg2 <- value
return $
BinaryOp
{ _binaryOpCode = op,
_binaryOpResult = vref,
_binaryOpArg1 = arg1,
_binaryOpArg2 = arg2
}
instrShow ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
VarRef ->
ParsecS r InstrShow
instrShow vref = do
kw kwShow
val <- value
return
InstrShow
{ _instrShowResult = vref,
_instrShowValue = val
}
instrStrToInt ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
VarRef ->
ParsecS r InstrStrToInt
instrStrToInt vref = do
kw kwAtoi
val <- value
return
InstrStrToInt
{ _instrStrToIntResult = vref,
_instrStrToIntValue = val
}
instrAssign ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
VarRef ->
ParsecS r InstrAssign
instrAssign vref = do
val <- value
return
InstrAssign
{ _instrAssignResult = vref,
_instrAssignValue = val
}
instrTrace ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r InstrTrace
instrTrace = do
kw kwTrace
val <- value
return
InstrTrace
{ _instrTraceValue = val
}
instrDump :: ParsecS r ()
instrDump = kw kwDump
instrFailure ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r InstrFailure
instrFailure = do
kw kwFail
val <- value
return
InstrFailure
{ _instrFailureValue = val
}
instrArgsNum ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
VarRef ->
ParsecS r InstrArgsNum
instrArgsNum vref = do
kw kwArgsNum
val <- value
return
InstrArgsNum
{ _instrArgsNumResult = vref,
_instrArgsNumValue = val
}
instrPrealloc ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r InstrPrealloc
instrPrealloc = do
kw kwPrealloc
n <- int
vars <- fromMaybe [] <$> optional liveVars
return
InstrPrealloc
{ _instrPreallocWordsNum = n,
_instrPreallocLiveVars = vars
}
instrAlloc ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
VarRef ->
ParsecS r InstrAlloc
instrAlloc vref = do
kw kwAlloc
tag <- constrTag @Code @() @VarRef
args <- parseArgs
return
InstrAlloc
{ _instrAllocResult = vref,
_instrAllocTag = tag,
_instrAllocArgs = args,
_instrAllocMemRep = MemRepConstr
}
instrAllocClosure ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
VarRef ->
ParsecS r InstrAllocClosure
instrAllocClosure vref = do
kw kwCAlloc
sym <- funSymbol @Code @() @VarRef
args <- parseArgs
fi <- lift $ getFunctionInfo sym
return
InstrAllocClosure
{ _instrAllocClosureResult = vref,
_instrAllocClosureSymbol = sym,
_instrAllocClosureExpectedArgsNum = fi ^. functionArgsNum,
_instrAllocClosureArgs = args
}
instrExtendClosure ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
VarRef ->
ParsecS r InstrExtendClosure
instrExtendClosure vref = do
kw kwCExtend
cl <- varRef
args <- parseArgs
return
InstrExtendClosure
{ _instrExtendClosureResult = vref,
_instrExtendClosureValue = cl,
_instrExtendClosureArgs = args
}
liveVars ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r [VarRef]
liveVars = do
P.try (comma >> symbol "live:")
parens (P.sepBy varRef comma)
parseArgs ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r [Value]
parseArgs = do
parens (P.sepBy value comma)
parseCallType ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r CallType
parseCallType =
(CallFun <$> funSymbol @Code @() @VarRef)
<|> (CallClosure <$> varRef)
instrCall ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
VarRef ->
ParsecS r InstrCall
instrCall vref = do
kw kwCall
ct <- parseCallType
args <- parseArgs
vars <- fromMaybe [] <$> optional liveVars
return
InstrCall
{ _instrCallResult = vref,
_instrCallType = ct,
_instrCallArgs = args,
_instrCallLiveVars = vars
}
instrCallClosures ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
VarRef ->
ParsecS r InstrCallClosures
instrCallClosures vref = do
kw kwCCall
val <- varRef
args <- parseArgs
vars <- fromMaybe [] <$> optional liveVars
return
InstrCallClosures
{ _instrCallClosuresResult = vref,
_instrCallClosuresValue = val,
_instrCallClosuresArgs = args,
_instrCallClosuresLiveVars = vars
}
instrTailCall ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r InstrTailCall
instrTailCall = do
kw kwCallTail
ct <- parseCallType
args <- parseArgs
return
InstrTailCall
{ _instrTailCallType = ct,
_instrTailCallArgs = args
}
instrTailCallClosures ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r InstrTailCallClosures
instrTailCallClosures = do
kw kwCCallTail
val <- varRef
args <- parseArgs
return
InstrTailCallClosures
{ _instrTailCallClosuresValue = val,
_instrTailCallClosuresArgs = args
}
instrReturn ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r InstrReturn
instrReturn = do
kw kwRet
val <- value
return
InstrReturn
{ _instrReturnValue = val
}
instrBranch ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r InstrBranch
instrBranch = do
kw kwBr
val <- value
(br1, br2) <- braces $ do
symbol "true:"
br1 <- braces parseCode
kw delimSemicolon
symbol "false:"
br2 <- braces parseCode
kw delimSemicolon
return (br1, br2)
return
InstrBranch
{ _instrBranchValue = val,
_instrBranchTrue = br1,
_instrBranchFalse = br2
}
instrCase ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r InstrCase
instrCase = do
kw kwCase
sym <- brackets (indSymbol @Code @() @VarRef)
val <- value
lbrace
brs <- many caseBranch
def <- optional defaultBranch
rbrace
return
InstrCase
{ _instrCaseValue = val,
_instrCaseInductive = sym,
_instrCaseIndRep = IndRepStandard,
_instrCaseBranches = brs,
_instrCaseDefault = def
}
caseBranch ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r CaseBranch
caseBranch = do
tag <- P.try $ do
tag <- constrTag @Code @() @VarRef
kw kwColon
return tag
body <- braces parseCode
kw delimSemicolon
ci <- lift $ getConstructorInfo tag
return
CaseBranch
{ _caseBranchTag = tag,
_caseBranchArgsNum = ci ^. constructorArgsNum,
_caseBranchCode = body,
_caseBranchMemRep = MemRepConstr
}
defaultBranch ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r Code
defaultBranch = do
symbol "default:"
c <- braces parseCode
kw delimSemicolon
return c
instrBlock ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r InstrBlock
instrBlock = InstrBlock <$> braces parseCode
varRef ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r VarRef
varRef = varArg <|> varTmp <|> namedRef @Code @() @VarRef
declVarRef ::
forall r.
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r VarRef
declVarRef = varArg <|> varTmp <|> namedRef' @Code @() @VarRef decl
where
decl :: Int -> Text -> ParsecS r VarRef
decl _ txt = do
idx <- lift $ gets @LocalParams (^. localParamsTempIndex)
lift $ modify' @LocalParams (over localParamsTempIndex (+ 1))
let vref = VarRef VarGroupLocal idx (Just txt)
lift $ modify' (over localParamsNameMap (HashMap.insert txt vref))
return vref
varArg :: ParsecS r VarRef
varArg = do
kw kwArg
off <- brackets int
return
VarRef
{ _varRefGroup = VarGroupArgs,
_varRefIndex = off,
_varRefName = Nothing
}
varTmp :: ParsecS r VarRef
varTmp = do
kw kwTmp
off <- brackets int
return
VarRef
{ _varRefGroup = VarGroupLocal,
_varRefIndex = off,
_varRefName = Nothing
}
value ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r Value
value = (Const <$> constant) <|> varOrConstrRef
varOrConstrRef ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r Value
varOrConstrRef = do
r <- varRef
(CRef <$> constrField r) <|> return (VRef r)
constrField ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
VarRef ->
ParsecS r ConstrField
constrField ref = do
dot
tag <- constrTag @Code @() @VarRef
off <- brackets int
return
ConstrField
{ _constrFieldTag = tag,
_constrFieldMemRep = MemRepConstr,
_constrFieldRef = ref,
_constrFieldIndex = off
}

25
src/Juvix/Compiler/Reg/Translation/FromSource/Lexer.hs Normal file
View File

@ -0,0 +1,25 @@
module Juvix.Compiler.Reg.Translation.FromSource.Lexer
( module Juvix.Compiler.Reg.Translation.FromSource.Lexer,
module Juvix.Compiler.Tree.Translation.FromSource.Lexer.Base,
module Juvix.Compiler.Reg.Keywords,
)
where
import Juvix.Compiler.Reg.Keywords
import Juvix.Compiler.Tree.Translation.FromSource.Lexer.Base
import Juvix.Prelude
int :: ParsecS r Int
int = fst <$> number (-(2 ^ (31 :: Int))) (2 ^ (31 :: Int))
smallnat :: ParsecS r Int
smallnat = fst <$> number 0 256
identifier :: ParsecS r Text
identifier = lexeme bareIdentifier
identifierL :: ParsecS r (Text, Interval)
identifierL = lexemeInterval bareIdentifier
bareIdentifier :: ParsecS r Text
bareIdentifier = rawIdentifier' (`elem` specialSymbols) allKeywordStrings

4
src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs
View File

@ -26,6 +26,7 @@ data InfoTableBuilder' t e m a where
RegisterMain' :: Symbol -> InfoTableBuilder' t e m ()
GetIdent' :: Text -> InfoTableBuilder' t e m (Maybe IdentKind)
GetFunctionInfo' :: Symbol -> InfoTableBuilder' t e m (FunctionInfo' t e)
GetConstructorInfo' :: Tag -> InfoTableBuilder' t e m ConstructorInfo
makeSem ''InfoTableBuilder'
@ -100,3 +101,6 @@ runInfoTableBuilder' bs =
GetFunctionInfo' sym -> do
s <- get
return (lookupFunInfo (s ^. stateInfoTable) sym)
GetConstructorInfo' tag -> do
s <- get @(BuilderState' t e)
return (lookupConstrInfo (s ^. stateInfoTable) tag)

6
src/Juvix/Compiler/Tree/Language/Base.hs
View File

@ -16,6 +16,7 @@ data Constant
| ConstString Text
| ConstUnit
| ConstVoid
deriving stock (Eq)
-- | MemRefs are references to values stored in memory.
data MemRef
@ -24,11 +25,13 @@ data MemRef
| -- | ConstrRef is an indirect reference to a field (argument) of
-- a constructor: field k holds the (k+1)th argument.
ConstrRef Field
deriving stock (Eq)
data OffsetRef = OffsetRef
{ _offsetRefOffset :: Offset,
_offsetRefName :: Maybe Text
}
deriving stock (Eq)
-- | DirectRef is a direct memory reference.
data DirectRef
@ -39,6 +42,7 @@ data DirectRef
-- counted from the _bottom_ of the temporary stack). JVT/JVA code:
-- 'tmp[<offset>]'.
TempRef RefTemp
deriving stock (Eq)
mkTempRef :: OffsetRef -> DirectRef
mkTempRef o = TempRef (RefTemp o Nothing)
@ -56,6 +60,7 @@ data RefTemp = RefTemp
{ _refTempOffsetRef :: OffsetRef,
_refTempTempHeight :: Maybe Int
}
deriving stock (Eq)
-- | Constructor field reference. JVT/JVA code: '<dref>.<tag>[<offset>]'
data Field = Field
@ -66,6 +71,7 @@ data Field = Field
_fieldRef :: DirectRef,
_fieldOffset :: Offset
}
deriving stock (Eq)
makeLenses ''Field
makeLenses ''OffsetRef

5
src/Juvix/Compiler/Tree/Language/Rep.hs
View File

@ -1,5 +1,7 @@
module Juvix.Compiler.Tree.Language.Rep where
import Juvix.Prelude
-- | Memory representation of a constructor.
data MemRep
= -- | Standard representation of a constructor: [tag, field 0, .., field n]
@ -23,6 +25,7 @@ data MemRep
-- representing constructors of different inductive types because they have
-- no tag). The argument is the representation of the wrapped value.
MemRepUnpacked ValRep
deriving stock (Eq)
-- | Representation of values.
data ValRep
@ -36,6 +39,7 @@ data ValRep
ValRepWord
| -- | Constructor of an inductive type with a given representation.
ValRepInd IndRep
deriving stock (Eq)
-- | Representation of an inductive type.
data IndRep
@ -64,3 +68,4 @@ data IndRep
| -- | The constructors can have any representation as long as there is no
-- ambiguity arising from unpacking.
IndRepMixed
deriving stock (Eq)

40
src/Juvix/Compiler/Tree/Pretty/Base.hs
View File

@ -7,12 +7,12 @@ where
import Data.Foldable
import Data.HashMap.Strict qualified as HashMap
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text qualified as Text
import Juvix.Compiler.Core.Pretty.Base qualified as Core
import Juvix.Compiler.Internal.Data.Name
import Juvix.Compiler.Tree.Data.InfoTable
import Juvix.Compiler.Tree.Language
import Juvix.Compiler.Tree.Language.Value
import Juvix.Compiler.Tree.Pretty.Extra
import Juvix.Compiler.Tree.Pretty.Options
import Juvix.Data.CodeAnn
import Juvix.Extra.Strings qualified as Str
@ -36,26 +36,6 @@ wrapCore f c = do
opts <- ask
return $ run $ runReader (toCoreOptions opts) $ f c
quoteName :: Text -> Text
quoteName txt =
foldr
(uncurry Text.replace)
txt
[ ("$", "__dollar__"),
(":", "__colon__"),
("@", "__at__"),
("arg", "__arg__"),
("tmp", "__tmp__")
]
quoteFunName :: Text -> Text
quoteFunName txt =
foldr
(uncurry Text.replace)
txt
[ ("readLn", "__readLn__")
]
ppConstrName :: (Member (Reader Options) r) => Tag -> Sem r (Doc Ann)
ppConstrName tag = do
tagNames <- asks (^. optTagNames)
@ -393,9 +373,9 @@ ppInductive tab InductiveInfo {..} = do
ppInfoTable :: (Member (Reader Options) r) => (t -> Sem r (Doc Ann)) -> InfoTable' t e -> Sem r (Doc Ann)
ppInfoTable ppCode' tab@InfoTable {..} = do
inds <- mapM (ppInductive tab) (HashMap.elems (filterOutBuiltins _infoInductives))
funsigs <- mapM ppFunSig (HashMap.elems _infoFunctions)
funs <- mapM (ppFunInfo ppCode') (HashMap.elems _infoFunctions)
inds <- mapM (ppInductive tab) (sortOn (^. inductiveLocation) $ HashMap.elems (filterOutBuiltins _infoInductives))
funsigs <- mapM ppFunSig (sortOn (^. functionLocation) $ HashMap.elems _infoFunctions)
funs <- mapM (ppFunInfo ppCode') (sortOn (^. functionLocation) $ HashMap.elems _infoFunctions)
return $ vcat (map (<> line) inds) <> line <> vcat funsigs <> line <> line <> vcat (map (<> line) funs)
where
filterOutBuiltins :: HashMap Symbol InductiveInfo -> HashMap Symbol InductiveInfo
@ -413,18 +393,6 @@ instance PrettyCode InfoTable where
{--------------------------------------------------------------------------------}
{- helper functions -}
braces' :: Doc Ann -> Doc Ann
braces' d = braces (line <> indent' d <> line)
integer :: (Pretty a) => a -> Doc Ann
integer i = annotate AnnLiteralInteger (pretty i)
constr :: Text -> Doc Ann
constr a = annotate (AnnKind KNameConstructor) (pretty a)
variable :: Text -> Doc Ann
variable a = annotate (AnnKind KNameLocal) (pretty a)
ppRightExpression ::
(PrettyCode a, HasAtomicity a, Member (Reader Options) r) =>
Fixity ->

37
src/Juvix/Compiler/Tree/Pretty/Extra.hs Normal file
View File

@ -0,0 +1,37 @@
module Juvix.Compiler.Tree.Pretty.Extra where
import Data.Text qualified as Text
import Juvix.Data.CodeAnn
import Juvix.Prelude
braces' :: Doc Ann -> Doc Ann
braces' d = braces (line <> indent' d <> line)
integer :: (Pretty a) => a -> Doc Ann
integer i = annotate AnnLiteralInteger (pretty i)
constr :: Text -> Doc Ann
constr a = annotate (AnnKind KNameConstructor) (pretty a)
variable :: Text -> Doc Ann
variable a = annotate (AnnKind KNameLocal) (pretty a)
quoteName :: Text -> Text
quoteName txt =
foldr
(uncurry Text.replace)
txt
[ ("$", "__dollar__"),
(":", "__colon__"),
("@", "__at__"),
("arg", "__arg__"),
("tmp", "__tmp__")
]
quoteFunName :: Text -> Text
quoteFunName txt =
foldr
(uncurry Text.replace)
txt
[ ("readLn", "__readLn__")
]

21
src/Juvix/Compiler/Tree/Translation/FromSource.hs
View File

@ -17,13 +17,16 @@ import Juvix.Compiler.Tree.Translation.FromSource.Sig qualified as S
import Juvix.Parser.Error
import Text.Megaparsec qualified as P
type ParserSig = S.ParserSig Node ()
type ParserSig = S.ParserSig Node () DirectRef
type LocalParams = LocalParams' DirectRef
parseTreeSig :: ParserSig
parseTreeSig =
S.ParserSig
{ _parserSigBareIdentifier = bareIdentifier,
_parserSigParseCode = parseNode,
_parserSigArgRef = \x y -> ArgRef (OffsetRef x y),
_parserSigEmptyCode = mkUnop OpFail (mkConst (ConstString "fail")),
_parserSigEmptyExtra = ()
}
@ -131,7 +134,7 @@ parseAlloc ::
ParsecS r NodeAllocConstr
parseAlloc = do
loc <- onlyInterval (kw kwAlloc)
tag <- brackets (constrTag @Node @())
tag <- brackets (constrTag @Node @() @DirectRef)
args <- parseArgs
return
NodeAllocConstr
@ -145,7 +148,7 @@ parseCAlloc ::
ParsecS r NodeAllocClosure
parseCAlloc = do
loc <- onlyInterval (kw kwCAlloc)
sym <- brackets (funSymbol @Node @())
sym <- brackets (funSymbol @Node @() @DirectRef)
args <- parseArgs
return
NodeAllocClosure
@ -183,7 +186,7 @@ parseCall = do
callDirect :: Location -> ParsecS r NodeCall
callDirect loc = do
lbracket
sym <- funSymbol @Node @()
sym <- funSymbol @Node @() @DirectRef
rbracket
args <- parseArgs
return
@ -275,7 +278,7 @@ parseCase ::
ParsecS r NodeCase
parseCase = do
loc <- onlyInterval (kw kwCase)
sym <- brackets (indSymbol @Node @())
sym <- brackets (indSymbol @Node @() @DirectRef)
arg <- parens parseNode
lbrace
brs <- P.many caseBranch
@ -295,7 +298,7 @@ caseBranch ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r CaseBranch
caseBranch = do
(tag, loc) <- P.try $ interval (constrTag @Node @())
(tag, loc) <- P.try $ interval (constrTag @Node @() @DirectRef)
kw kwColon
(bSave, body) <- saveBranch <|> discardBranch
optional (kw delimSemicolon)
@ -332,10 +335,10 @@ parseSave = do
loc' <- onlyInterval (kw kwSave)
(mname, loc) <- interval $ optional (brackets identifier)
arg <- parens parseNode
tmpNum <- lift $ gets (^. localParamsTempIndex)
let updateNames :: LocalNameMap -> LocalNameMap
tmpNum <- lift $ gets @LocalParams (^. localParamsTempIndex)
let updateNames :: LocalNameMap DirectRef -> LocalNameMap DirectRef
updateNames mp = maybe mp (\n -> HashMap.insert n (mkTempRef (OffsetRef tmpNum (Just n))) mp) mname
body <- braces (localS (over localParamsTempIndex (+ 1)) $ localS (over localParamsNameMap updateNames) parseNode)
body <- braces (localS @LocalParams (over localParamsTempIndex (+ 1)) $ localS @LocalParams (over localParamsNameMap updateNames) parseNode)
return
NodeSave
{ _nodeSaveInfo = NodeInfo (Just loc'),

185
src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs
View File

@ -7,7 +7,7 @@
module Juvix.Compiler.Tree.Translation.FromSource.Base
( module Juvix.Compiler.Tree.Translation.FromSource.Base,
LocalNameMap,
LocalParams (..),
LocalParams' (..),
localParamsNameMap,
localParamsTempIndex,
)
@ -37,37 +37,30 @@ localS update a = do
lift $ put s
return a'
runParserS :: ParserSig t e -> FilePath -> Text -> Either MegaparsecError (InfoTable' t e)
runParserS :: ParserSig t e d -> FilePath -> Text -> Either MegaparsecError (InfoTable' t e)
runParserS sig fileName input_ = (^. stateInfoTable) <$> runParserS' sig emptyBuilderState fileName input_
runParserS' :: forall t e. ParserSig t e -> BuilderState' t e -> FilePath -> Text -> Either MegaparsecError (BuilderState' t e)
runParserS' sig bs fileName input_ = case runParserS'' (parseToplevel @t @e) sig bs fileName input_ of
runParserS' :: forall t e d. ParserSig t e d -> BuilderState' t e -> FilePath -> Text -> Either MegaparsecError (BuilderState' t e)
runParserS' sig bs fileName input_ = case runParserS'' (parseToplevel @t @e @d) sig bs fileName input_ of
Left e -> Left e
Right (bs', ()) -> Right bs'
runParserS'' ::
forall t e a.
ParsecS '[NameIdGen, InfoTableBuilder' t e, Reader (ParserSig t e), State LocalParams] a ->
ParserSig t e ->
forall t e d a.
ParsecS '[Reader (ParserSig t e d), InfoTableBuilder' t e, State (LocalParams' d)] a ->
ParserSig t e d ->
BuilderState' t e ->
FilePath ->
Text ->
Either MegaparsecError (BuilderState' t e, a)
runParserS'' parser sig bs fileName input_ =
case run $
evalState params $
runReader sig $
runInfoTableBuilder' bs $
evalTopNameIdGen defaultModuleId $
P.runParserT parser fileName input_ of
evalState emptyLocalParams $
runInfoTableBuilder' bs $
runReader sig $
P.runParserT parser fileName input_ of
(_, Left err) -> Left (MegaparsecError err)
(bs', Right x) -> Right (bs', x)
where
params =
LocalParams
{ _localParamsNameMap = mempty,
_localParamsTempIndex = 0
}
createBuiltinConstr ::
Symbol ->
@ -116,29 +109,28 @@ declareBuiltins = do
lift $ mapM_ (registerConstr' @t @e) constrs
parseToplevel ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e, State LocalParams] r) =>
ParsecS r ()
forall t e d.
ParsecS '[Reader (ParserSig t e d), InfoTableBuilder' t e, State (LocalParams' d)] ()
parseToplevel = do
declareBuiltins @t @e
space
P.many $ statement @t @e
P.many $ statement @t @e @d
P.eof
statement ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e, State LocalParams] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e, State (LocalParams' d)] r) =>
ParsecS r ()
statement = statementFunction @t @e <|> statementInductive @t @e
statement = statementFunction @t @e @d <|> statementInductive @t @e @d
statementFunction ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e, State LocalParams] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e, State (LocalParams' d)] r) =>
ParsecS r ()
statementFunction = do
kw kwFun
off <- P.getOffset
(txt, i) <- identifierL @t @e
(txt, i) <- identifierL @t @e @d
idt <- lift $ getIdent' @t @e txt
sym <- case idt of
Nothing -> lift $ freshSymbol' @t @e
@ -146,14 +138,14 @@ statementFunction = do
_ -> parseFailure off ("duplicate identifier: " ++ fromText txt)
when (txt == "main") $
lift (registerMain' @t @e sym)
args <- functionArguments @t @e
args <- functionArguments @t @e @d
let argtys = map snd args
argnames = map fst args
when (txt == "main" && not (null argtys)) $
parseFailure off "the 'main' function must take zero arguments"
mrty <- optional $ typeAnnotation @t @e
ec <- lift $ emptyCode @t @e
ee <- lift $ emptyExtra @t @e
mrty <- optional $ typeAnnotation @t @e @d
ec <- lift $ emptyCode @t @e @d
ee <- lift $ emptyExtra @t @e @d
let fi0 =
FunctionInfo
{ _functionName = txt,
@ -166,15 +158,9 @@ statementFunction = do
_functionExtra = ee
}
lift $ registerFunction' @t @e fi0
let updateNames :: LocalNameMap -> LocalNameMap
updateNames names =
foldr
(\(mn, idx) h -> maybe h (\n -> HashMap.insert n (ArgRef (OffsetRef idx (Just n))) h) mn)
names
(zip argnames [0 ..])
mcode <-
(kw delimSemicolon $> Nothing)
<|> optional (braces (localS (over localParamsNameMap updateNames) $ parseCode @t @e))
<|> optional (braces (functionBody @t @e @d (parseCode @t @e @d) argnames))
let fi = fi0 {_functionCode = fromMaybe ec mcode}
case idt of
Just (IdentFwd _) -> do
@ -193,13 +179,13 @@ statementFunction = do
lift (registerForward' @t @e txt sym)
statementInductive ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
ParsecS r ()
statementInductive = do
kw kwInductive
off <- P.getOffset
(txt, i) <- identifierL @t @e
(txt, i) <- identifierL @t @e @d
idt <- lift $ getIdent' @t @e txt
when (isJust idt) $
parseFailure off ("duplicate identifier: " ++ fromText txt)
@ -214,32 +200,32 @@ statementInductive = do
_inductiveRepresentation = IndRepStandard
}
lift $ registerInductive' @t @e ii
ctrs <- braces $ P.sepEndBy (constrDecl @t @e sym) (kw delimSemicolon)
ctrs <- braces $ P.sepEndBy (constrDecl @t @e @d sym) (kw delimSemicolon)
lift $ registerInductive' @t @e ii {_inductiveConstructors = map (^. constructorTag) ctrs}
functionArguments ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
ParsecS r [(Maybe Text, Type)]
functionArguments = do
lparen
args <- P.sepBy (parseArgument @t @e) comma
args <- P.sepBy (parseArgument @t @e @d) comma
rparen
return args
constrDecl ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
Symbol ->
ParsecS r ConstructorInfo
constrDecl symInd = do
off <- P.getOffset
(txt, i) <- identifierL @t @e
(txt, i) <- identifierL @t @e @d
idt <- lift $ getIdent' @t @e txt
when (isJust idt) $
parseFailure off ("duplicate identifier: " ++ fromText txt)
tag <- lift $ freshTag' @t @e
ty <- typeAnnotation @t @e
ty <- typeAnnotation @t @e @d
let ty' = uncurryType ty
argsNum = length (typeArgs ty')
ci =
@ -258,66 +244,66 @@ constrDecl symInd = do
return ci
typeAnnotation ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
ParsecS r Type
typeAnnotation = do
kw kwColon
parseType @t @e
parseType @t @e @d
parseArgument ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
ParsecS r (Maybe Text, Type)
parseArgument = do
n <- optional $ P.try $ do
txt <- identifier @t @e
txt <- identifier @t @e @d
kw kwColon
return txt
ty <- parseType @t @e
ty <- parseType @t @e @d
return (n, ty)
parseType ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
ParsecS r Type
parseType = do
tys <- typeArguments @t @e
tys <- typeArguments @t @e @d
off <- P.getOffset
typeFun' @t @e tys
typeFun' @t @e @d tys
<|> do
unless (null (NonEmpty.tail tys)) $
parseFailure off "expected \"->\""
return (head tys)
typeFun' ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
NonEmpty Type ->
ParsecS r Type
typeFun' tyargs = do
kw kwRightArrow
TyFun . TypeFun tyargs <$> parseType @t @e
TyFun . TypeFun tyargs <$> parseType @t @e @d
typeArguments ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
ParsecS r (NonEmpty Type)
typeArguments = do
parens (P.sepBy1 (parseType @t @e) comma <&> NonEmpty.fromList)
parens (P.sepBy1 (parseType @t @e @d) comma <&> NonEmpty.fromList)
<|> (typeDynamic <&> NonEmpty.singleton)
<|> (typeNamed @t @e <&> NonEmpty.singleton)
<|> (typeNamed @t @e @d <&> NonEmpty.singleton)
typeDynamic :: ParsecS r Type
typeDynamic = kw kwStar $> TyDynamic
typeNamed ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
ParsecS r Type
typeNamed = do
off <- P.getOffset
txt <- identifier @t @e
txt <- identifier @t @e @d
case txt of
"integer" -> return mkTypeInteger
"bool" -> return mkTypeBool
@ -353,15 +339,31 @@ unitValue = kw kwUnit $> ConstUnit
voidValue :: ParsecS r Constant
voidValue = kw kwVoid $> ConstVoid
functionBody ::
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e, State (LocalParams' d)] r) =>
ParsecS r t ->
[Maybe Text] ->
ParsecS r t
functionBody parseCode' argnames = do
sig <- lift $ ask @(ParserSig t e d)
let updateNames :: LocalNameMap d -> LocalNameMap d
updateNames names =
foldr
(\(mn, idx) h -> maybe h (\n -> HashMap.insert n ((sig ^. parserSigArgRef) idx (Just n)) h) mn)
names
(zip argnames [0 ..])
localS (over localParamsNameMap updateNames) parseCode'
memRef ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e, State LocalParams] r) =>
(Members '[Reader (ParserSig t e DirectRef), InfoTableBuilder' t e, State (LocalParams' DirectRef)] r) =>
ParsecS r MemRef
memRef = do
r <- directRef @t @e
parseField @t @e r <|> return (DRef r)
parseField @t @e @DirectRef r <|> return (DRef r)
directRef :: forall t e r. (Members '[Reader (ParserSig t e), State LocalParams] r) => ParsecS r DirectRef
directRef :: forall t e r. (Members '[Reader (ParserSig t e DirectRef), State (LocalParams' DirectRef)] r) => ParsecS r DirectRef
directRef = argRef <|> tempRef <|> namedRef @t @e
argRef :: ParsecS r DirectRef
@ -376,57 +378,60 @@ tempRef = do
(off, _) <- brackets integer
return $ mkTempRef (OffsetRef (fromInteger off) Nothing)
namedRef :: forall t e r. (Members '[Reader (ParserSig t e), State LocalParams] r) => ParsecS r DirectRef
namedRef = do
namedRef' :: forall t e d r. (Members '[Reader (ParserSig t e d), State (LocalParams' d)] r) => (Int -> Text -> ParsecS r d) -> ParsecS r d
namedRef' f = do
off <- P.getOffset
txt <- identifier @t @e
txt <- identifier @t @e @d
mr <- lift $ gets (HashMap.lookup txt . (^. localParamsNameMap))
case mr of
Just r -> return r
Nothing -> parseFailure off "undeclared identifier"
Nothing -> f off txt
namedRef :: forall t e d r. (Members '[Reader (ParserSig t e d), State (LocalParams' d)] r) => ParsecS r d
namedRef = namedRef' @t @e @d (\off _ -> parseFailure off "undeclared identifier")
parseField ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
DirectRef ->
ParsecS r MemRef
parseField dref = do
dot
tag <- constrTag @t @e
tag <- constrTag @t @e @d
(off, _) <- brackets integer
return $ ConstrRef (Field Nothing tag dref (fromInteger off))
constrTag ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
ParsecS r Tag
constrTag = do
off <- P.getOffset
txt <- identifier @t @e
txt <- identifier @t @e @d
idt <- lift $ getIdent' @t @e txt
case idt of
Just (IdentConstr tag) -> return tag
_ -> parseFailure off "expected a constructor"
indSymbol ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
ParsecS r Symbol
indSymbol = do
off <- P.getOffset
txt <- identifier @t @e
txt <- identifier @t @e @d
idt <- lift $ getIdent' @t @e txt
case idt of
Just (IdentInd sym) -> return sym
_ -> parseFailure off "expected an inductive type"
funSymbol ::
forall t e r.
(Members '[Reader (ParserSig t e), InfoTableBuilder' t e] r) =>
forall t e d r.
(Members '[Reader (ParserSig t e d), InfoTableBuilder' t e] r) =>
ParsecS r Symbol
funSymbol = do
off <- P.getOffset
txt <- identifier @t @e
txt <- identifier @t @e @d
idt <- lift $ getIdent' @t @e txt
case idt of
Just (IdentFwd sym) -> return sym

40
src/Juvix/Compiler/Tree/Translation/FromSource/Sig.hs
View File

@ -10,44 +10,52 @@ import Juvix.Compiler.Tree.Data.InfoTableBuilder.Base
import Juvix.Compiler.Tree.Language.Base
import Juvix.Compiler.Tree.Translation.FromSource.Lexer.Base
type LocalNameMap = HashMap Text DirectRef
type LocalNameMap d = HashMap Text d
data LocalParams = LocalParams
{ _localParamsNameMap :: LocalNameMap,
data LocalParams' d = LocalParams
{ _localParamsNameMap :: LocalNameMap d,
_localParamsTempIndex :: Index
}
data ParserSig t e = ParserSig
emptyLocalParams :: LocalParams' d
emptyLocalParams =
LocalParams
{ _localParamsNameMap = mempty,
_localParamsTempIndex = 0
}
data ParserSig t e d = ParserSig
{ _parserSigBareIdentifier :: forall r. ParsecS r Text,
_parserSigParseCode :: forall r. (Members '[Reader (ParserSig t e), InfoTableBuilder' t e, State LocalParams] r) => ParsecS r t,
_parserSigParseCode :: forall r. (Members '[Reader (ParserSig t e d), InfoTableBuilder' t e, State (LocalParams' d)] r) => ParsecS r t,
_parserSigArgRef :: Index -> Maybe Text -> d,
_parserSigEmptyCode :: t,
_parserSigEmptyExtra :: e
}
makeLenses ''ParserSig
makeLenses ''LocalParams
makeLenses ''LocalParams'
identifier :: forall t e r. (Member (Reader (ParserSig t e)) r) => ParsecS r Text
identifier :: forall t e d r. (Member (Reader (ParserSig t e d)) r) => ParsecS r Text
identifier = do
sig <- lift $ ask @(ParserSig t e)
sig <- lift $ ask @(ParserSig t e d)
lexeme (sig ^. parserSigBareIdentifier)
identifierL :: forall t e r. (Member (Reader (ParserSig t e)) r) => ParsecS r (Text, Interval)
identifierL :: forall t e d r. (Member (Reader (ParserSig t e d)) r) => ParsecS r (Text, Interval)
identifierL = do
sig <- lift $ ask @(ParserSig t e)
sig <- lift $ ask @(ParserSig t e d)
lexemeInterval (sig ^. parserSigBareIdentifier)
parseCode :: forall t e r. (Members '[Reader (ParserSig t e), InfoTableBuilder' t e, State LocalParams] r) => ParsecS r t
parseCode :: forall t e d r. (Members '[Reader (ParserSig t e d), InfoTableBuilder' t e, State (LocalParams' d)] r) => ParsecS r t
parseCode = do
sig <- lift $ ask @(ParserSig t e)
sig <- lift $ ask @(ParserSig t e d)
sig ^. parserSigParseCode
emptyCode :: forall t e r. (Member (Reader (ParserSig t e)) r) => Sem r t
emptyCode :: forall t e d r. (Member (Reader (ParserSig t e d)) r) => Sem r t
emptyCode = do
sig <- ask @(ParserSig t e)
sig <- ask @(ParserSig t e d)
return $ sig ^. parserSigEmptyCode
emptyExtra :: forall t e r. (Member (Reader (ParserSig t e)) r) => Sem r e
emptyExtra :: forall t e d r. (Member (Reader (ParserSig t e d)) r) => Sem r e
emptyExtra = do
sig <- ask @(ParserSig t e)
sig <- ask @(ParserSig t e d)
return $ sig ^. parserSigEmptyExtra

14
src/Juvix/Data/FileExt.hs
View File

@ -13,6 +13,7 @@ data FileExt
| FileExtJuvixGeb
| FileExtJuvixCore
| FileExtJuvixAsm
| FileExtJuvixReg
| FileExtJuvixTree
| FileExtCasm
| FileExtVampIR
@ -42,6 +43,9 @@ juvixCoreFileExt = ".jvc"
juvixAsmFileExt :: (IsString a) => a
juvixAsmFileExt = ".jva"
juvixRegFileExt :: (IsString a) => a
juvixRegFileExt = ".jvr"
juvixTreeFileExt :: (IsString a) => a
juvixTreeFileExt = ".jvt"
@ -85,6 +89,7 @@ fileExtToText = \case
FileExtJuvixGeb -> juvixGebFileExt
FileExtJuvixCore -> juvixCoreFileExt
FileExtJuvixAsm -> juvixAsmFileExt
FileExtJuvixReg -> juvixRegFileExt
FileExtJuvixTree -> juvixTreeFileExt
FileExtCasm -> casmFileExt
FileExtVampIR -> vampIRFileExt
@ -105,6 +110,7 @@ toMetavar = \case
FileExtJuvixGeb -> "JUVIX_GEB_FILE"
FileExtJuvixCore -> "JUVIX_CORE_FILE"
FileExtJuvixAsm -> "JUVIX_ASM_FILE"
FileExtJuvixReg -> "JUVIX_REG_FILE"
FileExtJuvixTree -> "JUVIX_TREE_FILE"
FileExtCasm -> "CASM_FILE"
FileExtVampIR -> "VAMPIR_FILE"
@ -153,6 +159,12 @@ isHaloFile = (== Just haloFileExt) . fileExtension
isJuvixAsmFile :: Path b File -> Bool
isJuvixAsmFile = (== Just juvixAsmFileExt) . fileExtension
isJuvixRegFile :: Path b File -> Bool
isJuvixRegFile = (== Just juvixRegFileExt) . fileExtension
isJuvixTreeFile :: Path b File -> Bool
isJuvixTreeFile = (== Just juvixTreeFileExt) . fileExtension
isCasmFile :: Path b File -> Bool
isCasmFile = (== Just casmFileExt) . fileExtension
@ -181,6 +193,8 @@ toFileExt p
| isJuvixGebFile p = Just FileExtJuvixGeb
| isJuvixCoreFile p = Just FileExtJuvixCore
| isJuvixAsmFile p = Just FileExtJuvixAsm
| isJuvixRegFile p = Just FileExtJuvixReg
| isJuvixTreeFile p = Just FileExtJuvixTree
| isCasmFile p = Just FileExtCasm
| isVampIRFile p = Just FileExtVampIR
| isVampIRParamsFile p = Just FileExtVampIRParams

21
src/Juvix/Data/Keyword/All.hs
View File

@ -103,6 +103,9 @@ kwAssoc = asciiKw Str.assoc
kwNone :: Keyword
kwNone = asciiKw Str.none
kwNop :: Keyword
kwNop = asciiKw Str.nop
kwRight :: Keyword
kwRight = asciiKw Str.right
@ -265,6 +268,12 @@ kwTrace = asciiKw Str.trace_
kwFail :: Keyword
kwFail = asciiKw Str.fail_
kwDump :: Keyword
kwDump = asciiKw Str.dump
kwPrealloc :: Keyword
kwPrealloc = asciiKw Str.prealloc
kwArgsNum :: Keyword
kwArgsNum = asciiKw Str.instrArgsNum
@ -280,12 +289,18 @@ kwCExtend = asciiKw Str.instrCextend
kwCCall :: Keyword
kwCCall = asciiKw Str.instrCcall
kwCCallTail :: Keyword
kwCCallTail = asciiKw Str.instrTccall
kwBr :: Keyword
kwBr = asciiKw Str.instrBr
kwSave :: Keyword
kwSave = asciiKw Str.save
kwDefault :: Keyword
kwDefault = asciiKw Str.default_
kwIntAdd :: Keyword
kwIntAdd = asciiKw Str.iadd
@ -397,9 +412,15 @@ kwJmp = asciiKw Str.jmp
kwCall :: Keyword
kwCall = asciiKw Str.call
kwCallTail :: Keyword
kwCallTail = asciiKw Str.tcall
kwRet :: Keyword
kwRet = asciiKw Str.ret
kwLive :: Keyword
kwLive = asciiKw Str.live
delimBraceL :: Keyword
delimBraceL = mkDelim Str.braceL

15
src/Juvix/Extra/Strings.hs
View File

@ -362,6 +362,12 @@ trace_ = "trace"
fail_ :: (IsString s) => s
fail_ = "fail"
dump :: (IsString s) => s
dump = "dump"
prealloc :: (IsString s) => s
prealloc = "prealloc"
argsnum :: (IsString s) => s
argsnum = "argsnum"
@ -374,6 +380,9 @@ jmp = "jmp"
call :: (IsString s) => s
call = "call"
tcall :: (IsString s) => s
tcall = "tcall"
rel :: (IsString s) => s
rel = "rel"
@ -536,6 +545,9 @@ le_ = "le"
ret :: (IsString s) => s
ret = "ret"
live :: (IsString s) => s
live = "live"
dollar :: (IsString s) => s
dollar = "$"
@ -896,6 +908,9 @@ same = "same"
none :: (IsString s) => s
none = "none"
nop :: (IsString s) => s
nop = "nop"
init :: (IsString s) => s
init = "init"

2
test/Main.hs
View File

@ -14,6 +14,7 @@ import Internal qualified
import Nockma qualified
import Package qualified
import Parsing qualified
import Reg qualified
import Resolver qualified
import Runtime qualified
import Scope qualified
@ -28,6 +29,7 @@ slowTests =
"Juvix slow tests"
[ BackendGeb.allTests,
Runtime.allTests,
Reg.allTests,
Asm.allTests,
Tree.allTests,
Core.allTests,

7
test/Reg.hs Normal file
View File

@ -0,0 +1,7 @@
module Reg where
import Base
import Reg.Parse qualified as Parse
allTests :: TestTree
allTests = testGroup "JuvixReg tests" [Parse.allTests]

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

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

32
test/Reg/Parse/Base.hs Normal file
View File

@ -0,0 +1,32 @@
module Reg.Parse.Base where
import Base
import Juvix.Compiler.Reg.Data.InfoTable
import Juvix.Compiler.Reg.Pretty
import Juvix.Compiler.Reg.Translation.FromSource
import Juvix.Data.PPOutput
regParseAssertion :: Path Abs File -> (String -> IO ()) -> Assertion
regParseAssertion mainFile step = do
step "Parse"
r <- parseFile mainFile
case r of
Left err -> assertFailure (show (pretty err))
Right tab -> do
withTempDir'
( \dirPath -> do
let outputFile = dirPath <//> $(mkRelFile "out.out")
step "Print"
writeFileEnsureLn outputFile (ppPrint tab tab)
step "Parse printed"
r' <- parseFile outputFile
case r' of
Left err -> assertFailure (show (pretty err))
Right tab' -> do
assertBool ("Check: print . parse = print . parse . print . parse") (ppPrint tab tab == ppPrint tab' tab')
)
parseFile :: Path Abs File -> IO (Either MegaparsecError InfoTable)
parseFile f = do
s <- readFile (toFilePath f)
return $ runParser (toFilePath f) s

227
test/Reg/Parse/Positive.hs Normal file
View File

@ -0,0 +1,227 @@
module Reg.Parse.Positive where
import Base
import Reg.Parse.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/Reg/positive")
testDescr :: PosTest -> TestDescr
testDescr PosTest {..} =
let tRoot = root <//> _relDir
file' = tRoot <//> _file
in TestDescr
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Steps $ regParseAssertion file'
}
filterTests :: [String] -> [PosTest] -> [PosTest]
filterTests incl = filter (\PosTest {..} -> _name `elem` incl)
allTests :: TestTree
allTests =
testGroup
"JuvixReg parsing 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
"Test005: Tracing IO"
$(mkRelDir ".")
$(mkRelFile "test005.jvr")
$(mkRelFile "out/test005.out"),
PosTest
"Test006: IO builtins"
$(mkRelDir ".")
$(mkRelFile "test006.jvr")
$(mkRelFile "out/test006.out"),
PosTest
"Test007: Higher-order functions"
$(mkRelDir ".")
$(mkRelFile "test007.jvr")
$(mkRelFile "out/test007.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
"Test022: Self-application"
$(mkRelDir ".")
$(mkRelFile "test022.jvr")
$(mkRelFile "out/test022.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
"Test025: Dynamic closure extension"
$(mkRelDir ".")
$(mkRelFile "test025.jvr")
$(mkRelFile "out/test025.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
"Test029: Structural equality"
$(mkRelDir ".")
$(mkRelFile "test029.jvr")
$(mkRelFile "out/test029.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
"Test032: Church numerals"
$(mkRelDir ".")
$(mkRelFile "test032.jvr")
$(mkRelFile "out/test032.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
"Test035: Nested lists"
$(mkRelDir ".")
$(mkRelFile "test035.jvr")
$(mkRelFile "out/test035.out"),
PosTest
"Test036: Streams without memoization"
$(mkRelDir ".")
$(mkRelFile "test036.jvr")
$(mkRelFile "out/test036.out"),
PosTest
"Test037: String instructions"
$(mkRelDir ".")
$(mkRelFile "test037.jvr")
$(mkRelFile "out/test037.out"),
PosTest
"Test038: Apply & argsnum"
$(mkRelDir ".")
$(mkRelFile "test038.jvr")
$(mkRelFile "out/test038.out")
]

1
tests/Reg/positive/out/test001.out Normal file
View File

@ -0,0 +1 @@
11

1
tests/Reg/positive/out/test002.out Normal file
View File

@ -0,0 +1 @@
11

1
tests/Reg/positive/out/test003.out Normal file
View File

@ -0,0 +1 @@
11

1
tests/Reg/positive/out/test004.out Normal file
View File

@ -0,0 +1 @@
11

6
tests/Reg/positive/out/test005.out Normal file
View File

@ -0,0 +1,6 @@
1
2
2
seven
unit
void

2
tests/Reg/positive/out/test006.out Normal file
View File

@ -0,0 +1,2 @@
12
12345

1
tests/Reg/positive/out/test007.out Normal file
View File

@ -0,0 +1 @@
4

1
tests/Reg/positive/out/test008.out Normal file
View File

@ -0,0 +1 @@
2

7
tests/Reg/positive/out/test009.out Normal file
View File

@ -0,0 +1,7 @@
false
true
0
cons 1 nil
1
cons 1 (cons 2 nil)
cons 1 (cons 2 nil)

1
tests/Reg/positive/out/test010.out Normal file
View File

@ -0,0 +1 @@
500500

4
tests/Reg/positive/out/test011.out Normal file
View File

@ -0,0 +1,4 @@
500500
120
3628800
479001600

1
tests/Reg/positive/out/test012.out Normal file
View File

@ -0,0 +1 @@
40

3
tests/Reg/positive/out/test013.out Normal file
View File

@ -0,0 +1,3 @@
55
9748419
12607563

155
tests/Reg/positive/out/test014.out Normal file
View File

@ -0,0 +1,155 @@
1
3
2
0
0
2
0
0
2
0
0
X
2
1
3
2
1
3
2
0
0
2
0
0
2
0
0
1
3
2
0
0
2
0
0
2
0
0
2
1
3
2
0
0
2
0
0
2
0
0
1
3
2
0
0
2
0
0
2
0
0
2
1
3
2
0
0
2
0
0
2
0
0
1
3
2
0
0
2
0
0
2
0
0
1
3
2
1
3
2
0
0
2
0
0
2
0
0
1
3
2
0
0
2
0
0
2
0
0
2
1
3
2
0
0
2
0
0
2
0
0
1
3
2
0
0
2
0
0
2
0
0
2
1
3
2
0
0
2
0
0
2
0
0
1
3
2
0
0
2
0
0
2
0
0

4
tests/Reg/positive/out/test015.out Normal file
View File

@ -0,0 +1,4 @@
1
0
2
5

5
tests/Reg/positive/out/test016.out Normal file
View File

@ -0,0 +1,5 @@
7
17
37
-29
-29

6
tests/Reg/positive/out/test017.out Normal file
View File

@ -0,0 +1,6 @@
600
25
30
45
55
16

3
tests/Reg/positive/out/test018.out Normal file
View File

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

1
tests/Reg/positive/out/test019.out Normal file
View File

@ -0,0 +1 @@
55

1
tests/Reg/positive/out/test020.out Normal file
View File

@ -0,0 +1 @@
500500

1
tests/Reg/positive/out/test021.out Normal file
View File

@ -0,0 +1 @@
11

1
tests/Reg/positive/out/test022.out Normal file
View File

@ -0,0 +1 @@
7

4
tests/Reg/positive/out/test023.out Normal file
View File

@ -0,0 +1,4 @@
91
91
91
91

24
tests/Reg/positive/out/test024.out Normal file
View File

@ -0,0 +1,24 @@
6
4
7
9
40
6
3
7
9
30
6
2
7
9
20
6
1
7
9
10
6
0
7
end

3
tests/Reg/positive/out/test025.out Normal file
View File

@ -0,0 +1,3 @@
36
22
8

3
tests/Reg/positive/out/test026.out Normal file
View File

@ -0,0 +1,3 @@
6
5
8

3
tests/Reg/positive/out/test027.out Normal file
View File

@ -0,0 +1,3 @@
8
2187
48828125

7
tests/Reg/positive/out/test028.out Normal file
View File

@ -0,0 +1,7 @@
cons 10 (cons 9 (cons 8 (cons 7 (cons 6 (cons 5 (cons 4 (cons 3 (cons 2 (cons 1 nil)))))))))
cons 1 (cons 2 (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 (cons 10 nil)))))))))
cons 10 (cons 9 (cons 8 (cons 7 (cons 6 nil))))
cons 0 (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 nil)))))))))
500500
500500
500500

7
tests/Reg/positive/out/test029.out Normal file
View File

@ -0,0 +1,7 @@
true
false
true
false
false
false
true

3
tests/Reg/positive/out/test030.out Normal file
View File

@ -0,0 +1,3 @@
32
869
151635589

4
tests/Reg/positive/out/test031.out Normal file
View File

@ -0,0 +1,4 @@
-12096
-9744
5181
26932

7
tests/Reg/positive/out/test032.out Normal file
View File

@ -0,0 +1,7 @@
7
21
6
5
8
13
21

6
tests/Reg/positive/out/test033.out Normal file
View File

@ -0,0 +1,6 @@
8
9
15
17
29
125

3
tests/Reg/positive/out/test034.out Normal file
View File

@ -0,0 +1,3 @@
10
21
2187

2
tests/Reg/positive/out/test035.out Normal file
View File

@ -0,0 +1,2 @@
cons (cons 4 (cons 3 (cons 2 (cons 1 nil)))) (cons (cons 3 (cons 2 (cons 1 nil))) (cons (cons 2 (cons 1 nil)) (cons (cons 1 nil) nil)))
cons 4 (cons 3 (cons 2 (cons 1 (cons 3 (cons 2 (cons 1 (cons 2 (cons 1 (cons 1 nil)))))))))

2
tests/Reg/positive/out/test036.out Normal file
View File

@ -0,0 +1,2 @@
31
233

1
tests/Reg/positive/out/test037.out Normal file
View File

@ -0,0 +1 @@
143.

1
tests/Reg/positive/out/test038.out Normal file
View File

@ -0,0 +1 @@
5

21
tests/Reg/positive/test001.jvr Normal file
View File

@ -0,0 +1,21 @@
function main() : *;
function main() : * {
tmp[0] = 12;
tmp[1] = 5;
tmp[2] = 3;
tmp[3] = 2;
tmp[2] = mul tmp[3] tmp[2];
tmp[1] = add tmp[2] tmp[1];
tmp[2] = 15;
tmp[1] = sub tmp[2] tmp[1];
tmp[2] = 9;
tmp[1] = div tmp[2] tmp[1];
tmp[2] = 7;
tmp[1] = mul tmp[2] tmp[1];
tmp[2] = 25;
tmp[1] = sub tmp[2] tmp[1];
tmp[0] = mod tmp[1] tmp[0];
ret tmp[0];
}

20
tests/Reg/positive/test002.jvr Normal file
View File

@ -0,0 +1,20 @@
function calculate(integer, integer, integer) : integer;
function main() : *;
function calculate(integer, integer, integer) : integer {
tmp[0] = arg[0];
tmp[1] = arg[1];
tmp[2] = arg[2];
tmp[1] = mul tmp[2] tmp[1];
tmp[0] = add tmp[1] tmp[0];
ret tmp[0];
}
function main() : * {
tmp[0] = 2;
tmp[1] = 3;
tmp[2] = 5;
tmp[0] = call calculate (tmp[2], tmp[1], tmp[0]);
ret tmp[0];
}

22
tests/Reg/positive/test003.jvr Normal file
View File

@ -0,0 +1,22 @@
function calculate(integer, integer, integer) : integer;
function main() : *;
function calculate(integer, integer, integer) : integer {
tmp[0] = arg[0];
tmp[1] = arg[1];
tmp[2] = arg[2];
tmp[1] = mul tmp[2] tmp[1];
tmp[0] = add tmp[1] tmp[0];
ret tmp[0];
}
function main() : * {
prealloc 4;
tmp[0] = 2;
tmp[1] = 3;
tmp[2] = 5;
tmp[1] = calloc calculate (tmp[2], tmp[1]);
tmp[0] = call tmp[1] (tmp[0]);
ret tmp[0];
}

36
tests/Reg/positive/test004.jvr Normal file
View File

@ -0,0 +1,36 @@
function multiply(integer, integer) : integer;
function plus(integer, integer) : integer;
function calculate(integer, integer, integer) : integer;
function main() : *;
function multiply(integer, integer) : integer {
tmp[0] = arg[0];
tmp[1] = arg[1];
tmp[0] = mul tmp[1] tmp[0];
ret tmp[0];
}
function plus(integer, integer) : integer {
tmp[0] = arg[0];
tmp[1] = arg[1];
tmp[0] = add tmp[1] tmp[0];
ret tmp[0];
}
function calculate(integer, integer, integer) : integer {
tmp[0] = arg[0];
tmp[1] = arg[1];
tmp[2] = arg[2];
tmp[1] = call multiply (tmp[2], tmp[1]), live: (tmp[0], arg[0], arg[1], arg[2]);
tcall plus (tmp[1], tmp[0]);
}
function main() : * {
prealloc 4;
tmp[0] = 2;
tmp[1] = 3;
tmp[2] = 5;
tmp[1] = calloc calculate (tmp[2], tmp[1]);
tcall tmp[1] (tmp[0]);
}

21
tests/Reg/positive/test005.jvr Normal file
View File

@ -0,0 +1,21 @@
function main() : *;
function main() : * {
tmp[0] = 1;
trace tmp[0];
tmp[1] = 2;
trace tmp[1];
trace tmp[1];
tmp[2] = "seven";
trace tmp[2];
nop;
nop;
nop;
tmp[0] = unit;
trace tmp[0];
nop;
tmp[0] = void;
trace tmp[0];
ret tmp[0];
}

65
tests/Reg/positive/test006.jvr Normal file
View File

@ -0,0 +1,65 @@
function const(*, *) : *;
function print(*) : IO;
function sequence(IO, IO) : IO;
function main() : *;
function const(*, *) : * {
tmp[0] = arg[0];
ret tmp[0];
}
function print(*) : IO {
prealloc 2, live: (arg[0]);
tmp[0] = arg[0];
tmp[0] = alloc write (tmp[0]);
ret tmp[0];
}
function sequence(IO, IO) : IO {
prealloc 6, live: (arg[0], arg[1]);
tmp[0] = arg[1];
tmp[0] = calloc const (tmp[0]);
tmp[1] = arg[0];
tmp[0] = alloc bind (tmp[1], tmp[0]);
ret tmp[0];
}
function main() : * {
prealloc 6;
tmp[0] = "\n";
tmp[0] = alloc write (tmp[0]);
tmp[1] = 5;
tmp[1] = alloc write (tmp[1]);
tmp[2] = 4;
tmp[2] = alloc write (tmp[2]);
tmp[1] = call sequence (tmp[2], tmp[1]), live: (tmp[0]);
prealloc 6, live: (tmp[0], tmp[1]);
tmp[2] = 3;
tmp[2] = alloc write (tmp[2]);
tmp[3] = 2;
tmp[3] = alloc write (tmp[3]);
tmp[4] = 1;
tmp[4] = alloc write (tmp[4]);
tmp[3] = call sequence (tmp[4], tmp[3]), live: (tmp[0], tmp[1], tmp[2]);
tmp[2] = call sequence (tmp[3], tmp[2]), live: (tmp[0], tmp[1]);
tmp[1] = call sequence (tmp[2], tmp[1]), live: (tmp[0]);
tmp[0] = call sequence (tmp[1], tmp[0]);
prealloc 14, live: (tmp[0]);
tmp[1] = calloc print ();
tmp[2] = "\n";
tmp[2] = alloc return (tmp[2]);
tmp[1] = alloc bind (tmp[2], tmp[1]);
tmp[2] = calloc print ();
tmp[3] = 2;
tmp[3] = alloc return (tmp[3]);
tmp[2] = alloc bind (tmp[3], tmp[2]);
tmp[1] = call sequence (tmp[2], tmp[1]), live: (tmp[0]);
prealloc 7, live: (tmp[0], tmp[1]);
tmp[2] = calloc print ();
tmp[3] = 1;
tmp[3] = alloc return (tmp[3]);
tmp[2] = alloc bind (tmp[3], tmp[2]);
tmp[1] = call sequence (tmp[2], tmp[1]), live: (tmp[0]);
tcall sequence (tmp[1], tmp[0]);
}

65
tests/Reg/positive/test007.jvr Normal file
View File

@ -0,0 +1,65 @@
function S(*, *, *) : *;
function K(*, *) : *;
function I(*) : *;
function main() : *;
function S(*, *, *) : * {
tmp[0] = arg[2];
tmp[1] = arg[1];
tmp[0] = ccall tmp[1] (tmp[0]), live: (arg[0], arg[1], arg[2]);
tmp[1] = arg[2];
tmp[2] = arg[0];
tccall tmp[2] (tmp[1], tmp[0]);
}
function K(*, *) : * {
tmp[0] = arg[0];
ret tmp[0];
}
function I(*) : * {
prealloc 4, live: (arg[0]);
tmp[0] = arg[0];
tmp[1] = calloc K ();
tmp[2] = calloc K ();
tcall S (tmp[2], tmp[1], tmp[0]);
}
function main() : * {
tmp[0] = 1;
tmp[0] = call I (tmp[0]);
prealloc 2, live: (tmp[0]);
tmp[1] = 1;
tmp[2] = calloc I ();
tmp[2] = call I (tmp[2]), live: (tmp[0], tmp[1]);
tmp[1] = call tmp[2] (tmp[1]), live: (tmp[0]);
prealloc 8, live: (tmp[0], tmp[1]);
tmp[0] = add tmp[1] tmp[0];
tmp[1] = 1;
tmp[2] = calloc I ();
tmp[3] = calloc I ();
tmp[4] = calloc I ();
tmp[5] = calloc I ();
tmp[5] = call I (tmp[5]), live: (tmp[0], tmp[1], tmp[2], tmp[3], tmp[4]);
tmp[4] = call tmp[5] (tmp[4]), live: (tmp[0], tmp[1], tmp[2], tmp[3]);
tmp[3] = call tmp[4] (tmp[3]), live: (tmp[0], tmp[1], tmp[2]);
tmp[2] = call tmp[3] (tmp[2]), live: (tmp[0], tmp[1]);
tmp[1] = call tmp[2] (tmp[1]), live: (tmp[0]);
prealloc 18, live: (tmp[0], tmp[1]);
tmp[0] = add tmp[1] tmp[0];
tmp[1] = 1;
tmp[2] = calloc I ();
tmp[3] = calloc I ();
tmp[4] = calloc I ();
tmp[5] = calloc I ();
tmp[6] = calloc I ();
tmp[7] = calloc I ();
tmp[8] = calloc I ();
tmp[9] = calloc I ();
tmp[10] = calloc I ();
tmp[10] = call I (tmp[10]), live: (tmp[0], tmp[1], tmp[2], tmp[3], tmp[4], tmp[5], tmp[6], tmp[7], tmp[8], tmp[9]);
tmp[1] = ccall tmp[10] (tmp[9], tmp[8], tmp[7], tmp[6], tmp[5], tmp[4], tmp[3], tmp[2], tmp[1]), live: (tmp[0]);
tmp[0] = add tmp[1] tmp[0];
ret tmp[0];
}

44
tests/Reg/positive/test008.jvr Normal file
View File

@ -0,0 +1,44 @@
function loop() : *;
function main() : *;
function loop() : * {
tcall loop ();
}
function main() : * {
tmp[0] = 3;
tmp[1] = 0;
tmp[0] = lt tmp[1] tmp[0];
br tmp[0] {
true: {
tmp[0] = 1;
};
false: {
tmp[0] = call loop ();
};
};
tmp[1] = 1;
tmp[2] = 2;
tmp[1] = le tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = call loop (), live: (tmp[0]);
};
false: {
tmp[1] = 7;
tmp[2] = 8;
tmp[1] = le tmp[2] tmp[1];
br tmp[1] {
true: {
tmp[1] = call loop (), live: (tmp[0]);
};
false: {
tmp[1] = 1;
};
};
};
};
tmp[0] = add tmp[1] tmp[0];
ret tmp[0];
}

138
tests/Reg/positive/test009.jvr Normal file
View File

@ -0,0 +1,138 @@
type list {
nil : list;
cons : (*, list) → list;
}
function hd(list) : *;
function tl(list) : list;
function null(list) : bool;
function map(* → *, list) : list;
function map'(* → *, list) : list;
function add_one(integer) : integer;
function main() : *;
function hd(list) : * {
tmp[0] = arg[0].cons[0];
ret tmp[0];
}
function tl(list) : list {
tmp[0] = arg[0].cons[1];
ret tmp[0];
}
function null(list) : bool {
tmp[0] = arg[0];
case[list] tmp[0] {
nil: {
nop;
tmp[0] = true;
ret tmp[0];
};
default: {
nop;
tmp[0] = false;
ret tmp[0];
};
};
}
function map(* → *, list) : list {
tmp[1] = arg[1];
case[list] tmp[1] {
nil: {
ret tmp[1];
};
cons: {
{
tmp[0] = tmp[1];
tmp[1] = tmp[0].cons[1];
tmp[2] = arg[0];
tmp[1] = call map (tmp[2], tmp[1]), live: (tmp[0], arg[0], arg[1]);
tmp[2] = tmp[0].cons[0];
tmp[3] = arg[0];
tmp[2] = call tmp[3] (tmp[2]), live: (tmp[0], tmp[1], arg[0], arg[1]);
prealloc 3, live: (tmp[0], tmp[1], tmp[2], arg[0], arg[1]);
tmp[1] = alloc cons (tmp[2], tmp[1]);
ret tmp[1];
};
};
};
}
function map'(* → *, list) : list {
tmp[0] = arg[1];
tmp[0] = call null (tmp[0]), live: (arg[0], arg[1]);
br tmp[0] {
true: {
prealloc 1, live: (arg[0], arg[1]);
tmp[0] = alloc nil ();
ret tmp[0];
};
false: {
tmp[0] = arg[1];
tmp[0] = call tl (tmp[0]), live: (arg[0], arg[1]);
tmp[1] = arg[0];
tmp[0] = call map' (tmp[1], tmp[0]), live: (arg[0], arg[1]);
tmp[1] = arg[1];
tmp[1] = call hd (tmp[1]), live: (tmp[0], arg[0], arg[1]);
tmp[2] = arg[0];
tmp[1] = call tmp[2] (tmp[1]), live: (tmp[0], arg[0], arg[1]);
prealloc 3, live: (tmp[0], tmp[1], arg[0], arg[1]);
tmp[0] = alloc cons (tmp[1], tmp[0]);
ret tmp[0];
};
};
}
function add_one(integer) : integer {
tmp[0] = arg[0];
tmp[1] = 1;
tmp[0] = add tmp[1] tmp[0];
ret tmp[0];
}
function main() : * {
prealloc 7;
tmp[1] = alloc nil ();
tmp[2] = 1;
tmp[1] = alloc cons (tmp[2], tmp[1]);
tmp[2] = 0;
tmp[1] = alloc cons (tmp[2], tmp[1]);
{
tmp[0] = tmp[1];
tmp[1] = tmp[0];
tmp[1] = call null (tmp[1]), live: (tmp[0]);
prealloc 1, live: (tmp[0], tmp[1]);
trace tmp[1];
nop;
tmp[1] = alloc nil ();
tmp[1] = call null (tmp[1]), live: (tmp[0]);
trace tmp[1];
nop;
tmp[1] = tmp[0];
tmp[1] = call hd (tmp[1]), live: (tmp[0]);
trace tmp[1];
nop;
tmp[1] = tmp[0];
tmp[1] = call tl (tmp[1]), live: (tmp[0]);
trace tmp[1];
nop;
tmp[1] = tmp[0];
tmp[1] = call tl (tmp[1]), live: (tmp[0]);
tmp[1] = call hd (tmp[1]), live: (tmp[0]);
prealloc 2, live: (tmp[0], tmp[1]);
trace tmp[1];
nop;
tmp[1] = tmp[0];
tmp[2] = calloc add_one ();
tmp[1] = call map (tmp[2], tmp[1]), live: (tmp[0]);
prealloc 2, live: (tmp[0], tmp[1]);
trace tmp[1];
nop;
tmp[1] = tmp[0];
tmp[2] = calloc add_one ();
tmp[1] = call map' (tmp[2], tmp[1]), live: (tmp[0]);
};
ret tmp[1];
}

28
tests/Reg/positive/test010.jvr Normal file
View File

@ -0,0 +1,28 @@
function sum(integer) : integer;
function main() : *;
function sum(integer) : integer {
tmp[0] = arg[0];
tmp[1] = 0;
tmp[0] = eq tmp[1] tmp[0];
br tmp[0] {
true: {
tmp[0] = 0;
};
false: {
tmp[0] = 1;
tmp[1] = arg[0];
tmp[0] = sub tmp[1] tmp[0];
tmp[0] = call sum (tmp[0]), live: (arg[0]);
tmp[1] = arg[0];
tmp[0] = add tmp[1] tmp[0];
};
};
ret tmp[0];
}
function main() : * {
tmp[0] = 1000;
tcall sum (tmp[0]);
}

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