mirror of
https://github.com/anoma/juvix.git
synced 2024-11-30 14:13:27 +03:00
JuvixReg parser and pretty printer (#2617)
* 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
GitHub
parent
5dfafe00d2
commit
ed15e57d8a
@ -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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,6 +23,18 @@ runCommand opts = do
|
||||
{ _entryPointTarget = tgt,
|
||||
_entryPointDebug = opts ^. compileDebug
|
||||
}
|
||||
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
|
||||
@ -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"
|
||||
|
||||
@ -15,7 +15,7 @@ asmSupportedTargets =
|
||||
NonEmpty.fromList
|
||||
[ TargetWasm32Wasi,
|
||||
TargetNative64,
|
||||
TargetNockma
|
||||
TargetReg
|
||||
]
|
||||
|
||||
parseAsmCompileOptions :: Parser AsmCompileOptions
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -17,8 +17,9 @@ coreSupportedTargets =
|
||||
TargetNative64,
|
||||
TargetGeb,
|
||||
TargetVampIR,
|
||||
TargetTree,
|
||||
TargetAsm,
|
||||
TargetTree
|
||||
TargetReg
|
||||
]
|
||||
|
||||
parseCoreCompileOptions :: Parser CoreCompileOptions
|
||||
|
||||
@ -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
9
app/Commands/Dev/Reg.hs
Normal 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
24
app/Commands/Dev/Reg/Options.hs
Normal 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
19
app/Commands/Dev/Reg/Read.hs
Normal 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
15
app/Commands/Dev/Reg/Read/Options.hs
Normal 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 {..}
|
||||
@ -18,6 +18,7 @@ runCommand opts = do
|
||||
TargetVampIR -> return ()
|
||||
TargetCore -> return ()
|
||||
TargetAsm -> runAsmPipeline arg
|
||||
TargetReg -> runRegPipeline arg
|
||||
TargetTree -> return ()
|
||||
TargetNockma -> runNockmaPipeline arg
|
||||
where
|
||||
|
||||
@ -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
|
||||
|
||||
@ -13,6 +13,7 @@ treeSupportedTargets =
|
||||
[ TargetWasm32Wasi,
|
||||
TargetNative64,
|
||||
TargetAsm,
|
||||
TargetReg,
|
||||
TargetNockma
|
||||
]
|
||||
|
||||
|
||||
@ -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 ->
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ->
|
||||
|
||||
@ -14,7 +14,7 @@ data CCode
|
||||
| Verbatim Text
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Prepreocessor Directives
|
||||
-- Preprocessor Directives
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Cpp
|
||||
|
||||
@ -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,13 +243,11 @@ fromRegInstr bNoStack info = \case
|
||||
return $ fromAllocClosure x
|
||||
Reg.ExtendClosure x ->
|
||||
return $ fromExtendClosure x
|
||||
Reg.Call x@Reg.InstrCall {..}
|
||||
| _instrCallIsTail ->
|
||||
Reg.TailCall x ->
|
||||
return $ fromTailCall x
|
||||
Reg.Call x ->
|
||||
fromCall x
|
||||
Reg.CallClosures x@Reg.InstrCallClosures {..}
|
||||
| _instrCallClosuresIsTail ->
|
||||
Reg.TailCallClosures x ->
|
||||
return $ fromTailCallClosures x
|
||||
Reg.CallClosures x ->
|
||||
fromCallClosures 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)
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
43
src/Juvix/Compiler/Reg/Data/InfoTableBuilder.hs
Normal 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 @()
|
||||
@ -30,12 +30,11 @@ 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
|
||||
TailCallClosures InstrTailCallClosures {..} ->
|
||||
length _instrTailCallClosuresArgs
|
||||
+ 1
|
||||
+ lims
|
||||
^. limitsDispatchStackSize
|
||||
@ -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
47
src/Juvix/Compiler/Reg/Keywords.hs
Normal 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
|
||||
]
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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
28
src/Juvix/Compiler/Reg/Pretty.hs
Normal 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
285
src/Juvix/Compiler/Reg/Pretty/Base.hs
Normal 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
6
src/Juvix/Compiler/Reg/Pretty/Options.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Juvix.Compiler.Reg.Pretty.Options
|
||||
( module Juvix.Compiler.Tree.Pretty.Options,
|
||||
)
|
||||
where
|
||||
|
||||
import Juvix.Compiler.Tree.Pretty.Options
|
||||
@ -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 {..} =
|
||||
mkCall isTail Asm.InstrCall {..}
|
||||
| not isTail =
|
||||
Call $
|
||||
InstrCall
|
||||
{ _instrCallResult = VarRef VarGroupLocal (ntmps + m),
|
||||
{ _instrCallResult = mkVarRef VarGroupLocal (ntmps + m),
|
||||
_instrCallType = ct,
|
||||
_instrCallIsTail = isTail,
|
||||
_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 {..} =
|
||||
mkCallClosures isTail Asm.InstrCallClosures {..}
|
||||
| not isTail =
|
||||
CallClosures $
|
||||
InstrCallClosures
|
||||
{ _instrCallClosuresResult = VarRef VarGroupLocal (ntmps + m),
|
||||
_instrCallClosuresValue = VarRef VarGroupLocal (ntmps + n),
|
||||
_instrCallClosuresIsTail = isTail,
|
||||
{ _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
489
src/Juvix/Compiler/Reg/Translation/FromSource.hs
Normal 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
25
src/Juvix/Compiler/Reg/Translation/FromSource/Lexer.hs
Normal 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
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
37
src/Juvix/Compiler/Tree/Pretty/Extra.hs
Normal 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__")
|
||||
]
|
||||
@ -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'),
|
||||
|
||||
@ -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 $
|
||||
evalState emptyLocalParams $
|
||||
runInfoTableBuilder' bs $
|
||||
evalTopNameIdGen defaultModuleId $
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
@ -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
7
test/Reg.hs
Normal 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
7
test/Reg/Parse.hs
Normal 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
32
test/Reg/Parse/Base.hs
Normal 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
227
test/Reg/Parse/Positive.hs
Normal 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
1
tests/Reg/positive/out/test001.out
Normal file
@ -0,0 +1 @@
|
||||
11
|
||||
1
tests/Reg/positive/out/test002.out
Normal file
1
tests/Reg/positive/out/test002.out
Normal file
@ -0,0 +1 @@
|
||||
11
|
||||
1
tests/Reg/positive/out/test003.out
Normal file
1
tests/Reg/positive/out/test003.out
Normal file
@ -0,0 +1 @@
|
||||
11
|
||||
1
tests/Reg/positive/out/test004.out
Normal file
1
tests/Reg/positive/out/test004.out
Normal file
@ -0,0 +1 @@
|
||||
11
|
||||
6
tests/Reg/positive/out/test005.out
Normal file
6
tests/Reg/positive/out/test005.out
Normal file
@ -0,0 +1,6 @@
|
||||
1
|
||||
2
|
||||
2
|
||||
seven
|
||||
unit
|
||||
void
|
||||
2
tests/Reg/positive/out/test006.out
Normal file
2
tests/Reg/positive/out/test006.out
Normal file
@ -0,0 +1,2 @@
|
||||
12
|
||||
12345
|
||||
1
tests/Reg/positive/out/test007.out
Normal file
1
tests/Reg/positive/out/test007.out
Normal file
@ -0,0 +1 @@
|
||||
4
|
||||
1
tests/Reg/positive/out/test008.out
Normal file
1
tests/Reg/positive/out/test008.out
Normal file
@ -0,0 +1 @@
|
||||
2
|
||||
7
tests/Reg/positive/out/test009.out
Normal file
7
tests/Reg/positive/out/test009.out
Normal 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
1
tests/Reg/positive/out/test010.out
Normal file
@ -0,0 +1 @@
|
||||
500500
|
||||
4
tests/Reg/positive/out/test011.out
Normal file
4
tests/Reg/positive/out/test011.out
Normal file
@ -0,0 +1,4 @@
|
||||
500500
|
||||
120
|
||||
3628800
|
||||
479001600
|
||||
1
tests/Reg/positive/out/test012.out
Normal file
1
tests/Reg/positive/out/test012.out
Normal file
@ -0,0 +1 @@
|
||||
40
|
||||
3
tests/Reg/positive/out/test013.out
Normal file
3
tests/Reg/positive/out/test013.out
Normal file
@ -0,0 +1,3 @@
|
||||
55
|
||||
9748419
|
||||
12607563
|
||||
155
tests/Reg/positive/out/test014.out
Normal file
155
tests/Reg/positive/out/test014.out
Normal 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
4
tests/Reg/positive/out/test015.out
Normal file
@ -0,0 +1,4 @@
|
||||
1
|
||||
0
|
||||
2
|
||||
5
|
||||
5
tests/Reg/positive/out/test016.out
Normal file
5
tests/Reg/positive/out/test016.out
Normal file
@ -0,0 +1,5 @@
|
||||
7
|
||||
17
|
||||
37
|
||||
-29
|
||||
-29
|
||||
6
tests/Reg/positive/out/test017.out
Normal file
6
tests/Reg/positive/out/test017.out
Normal file
@ -0,0 +1,6 @@
|
||||
600
|
||||
25
|
||||
30
|
||||
45
|
||||
55
|
||||
16
|
||||
3
tests/Reg/positive/out/test018.out
Normal file
3
tests/Reg/positive/out/test018.out
Normal file
@ -0,0 +1,3 @@
|
||||
11
|
||||
9
|
||||
10
|
||||
1
tests/Reg/positive/out/test019.out
Normal file
1
tests/Reg/positive/out/test019.out
Normal file
@ -0,0 +1 @@
|
||||
55
|
||||
1
tests/Reg/positive/out/test020.out
Normal file
1
tests/Reg/positive/out/test020.out
Normal file
@ -0,0 +1 @@
|
||||
500500
|
||||
1
tests/Reg/positive/out/test021.out
Normal file
1
tests/Reg/positive/out/test021.out
Normal file
@ -0,0 +1 @@
|
||||
11
|
||||
1
tests/Reg/positive/out/test022.out
Normal file
1
tests/Reg/positive/out/test022.out
Normal file
@ -0,0 +1 @@
|
||||
7
|
||||
4
tests/Reg/positive/out/test023.out
Normal file
4
tests/Reg/positive/out/test023.out
Normal file
@ -0,0 +1,4 @@
|
||||
91
|
||||
91
|
||||
91
|
||||
91
|
||||
24
tests/Reg/positive/out/test024.out
Normal file
24
tests/Reg/positive/out/test024.out
Normal 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
3
tests/Reg/positive/out/test025.out
Normal file
@ -0,0 +1,3 @@
|
||||
36
|
||||
22
|
||||
8
|
||||
3
tests/Reg/positive/out/test026.out
Normal file
3
tests/Reg/positive/out/test026.out
Normal file
@ -0,0 +1,3 @@
|
||||
6
|
||||
5
|
||||
8
|
||||
3
tests/Reg/positive/out/test027.out
Normal file
3
tests/Reg/positive/out/test027.out
Normal file
@ -0,0 +1,3 @@
|
||||
8
|
||||
2187
|
||||
48828125
|
||||
7
tests/Reg/positive/out/test028.out
Normal file
7
tests/Reg/positive/out/test028.out
Normal 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
7
tests/Reg/positive/out/test029.out
Normal file
@ -0,0 +1,7 @@
|
||||
true
|
||||
false
|
||||
true
|
||||
false
|
||||
false
|
||||
false
|
||||
true
|
||||
3
tests/Reg/positive/out/test030.out
Normal file
3
tests/Reg/positive/out/test030.out
Normal file
@ -0,0 +1,3 @@
|
||||
32
|
||||
869
|
||||
151635589
|
||||
4
tests/Reg/positive/out/test031.out
Normal file
4
tests/Reg/positive/out/test031.out
Normal file
@ -0,0 +1,4 @@
|
||||
-12096
|
||||
-9744
|
||||
5181
|
||||
26932
|
||||
7
tests/Reg/positive/out/test032.out
Normal file
7
tests/Reg/positive/out/test032.out
Normal file
@ -0,0 +1,7 @@
|
||||
7
|
||||
21
|
||||
6
|
||||
5
|
||||
8
|
||||
13
|
||||
21
|
||||
6
tests/Reg/positive/out/test033.out
Normal file
6
tests/Reg/positive/out/test033.out
Normal file
@ -0,0 +1,6 @@
|
||||
8
|
||||
9
|
||||
15
|
||||
17
|
||||
29
|
||||
125
|
||||
3
tests/Reg/positive/out/test034.out
Normal file
3
tests/Reg/positive/out/test034.out
Normal file
@ -0,0 +1,3 @@
|
||||
10
|
||||
21
|
||||
2187
|
||||
2
tests/Reg/positive/out/test035.out
Normal file
2
tests/Reg/positive/out/test035.out
Normal 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
2
tests/Reg/positive/out/test036.out
Normal file
@ -0,0 +1,2 @@
|
||||
31
|
||||
233
|
||||
1
tests/Reg/positive/out/test037.out
Normal file
1
tests/Reg/positive/out/test037.out
Normal file
@ -0,0 +1 @@
|
||||
143.
|
||||
1
tests/Reg/positive/out/test038.out
Normal file
1
tests/Reg/positive/out/test038.out
Normal file
@ -0,0 +1 @@
|
||||
5
|
||||
21
tests/Reg/positive/test001.jvr
Normal file
21
tests/Reg/positive/test001.jvr
Normal 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
20
tests/Reg/positive/test002.jvr
Normal 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
22
tests/Reg/positive/test003.jvr
Normal 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
36
tests/Reg/positive/test004.jvr
Normal 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
21
tests/Reg/positive/test005.jvr
Normal 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
65
tests/Reg/positive/test006.jvr
Normal 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
65
tests/Reg/positive/test007.jvr
Normal 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
44
tests/Reg/positive/test008.jvr
Normal 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
138
tests/Reg/positive/test009.jvr
Normal 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
28
tests/Reg/positive/test010.jvr
Normal 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
Loading…
Reference in New Issue
Block a user