anoma/juvix
1
1
Fork 0
mirror of https://github.com/anoma/juvix.git synced 2024-09-11 16:26:33 +03:00
Code Issues Projects Releases Wiki Activity

Fast nockma eval (#2580)

Browse Source 
Adds annotations to cells to indicate that it is a call to the stdlib
and might be evaluated faster in the Haskell evaluator.

The syntax for stdlib calls is as follows:
```
[stdlib@add args@<args-term> <left-term> <right-term>]
```
where `add` is the name of the function being called, `<args-term>` is a
nockma term that points to the position of the arguments, and
`<left-term>` and `<right-term>` are the actual components of the cell.
This commit is contained in:
Jan Mas Rovira 2024-01-19 12:01:58 +01:00 committed by GitHub
parent 91ba586336
commit 39d176e643
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
18 changed files with 387 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.github/workflows/ci.yml vendored
View File

@ -45,9 +45,13 @@ jobs:
with:
version: 0.5.3.0
extra-args: >-
--ghc-opt -XDerivingStrategies --ghc-opt -XImportQualifiedPost
--ghc-opt -XMultiParamTypeClasses --ghc-opt -XStandaloneDeriving
--ghc-opt -XTemplateHaskell --ghc-opt -XUnicodeSyntax
--ghc-opt -XDerivingStrategies
--ghc-opt -XImportQualifiedPost
--ghc-opt -XMultiParamTypeClasses
--ghc-opt -XPatternSynonyms
--ghc-opt -XStandaloneDeriving
--ghc-opt -XTemplateHaskell
--ghc-opt -XUnicodeSyntax
build-and-test-linux:
runs-on: ubuntu-22.04

1
Makefile
View File

@ -93,6 +93,7 @@ ormolu:
--ghc-opt -XStandaloneDeriving \
--ghc-opt -XUnicodeSyntax \
--ghc-opt -XDerivingStrategies \
--ghc-opt -XPatternSynonyms \
--ghc-opt -XMultiParamTypeClasses \
--ghc-opt -XTemplateHaskell \
--ghc-opt -XImportQualifiedPost \

6
app/Commands/Dev/Nockma/Eval.hs
View File

@ -2,6 +2,7 @@ module Commands.Dev.Nockma.Eval where
import Commands.Base hiding (Atom)
import Commands.Dev.Nockma.Eval.Options
import Juvix.Compiler.Nockma.Evaluator.Options
import Juvix.Compiler.Nockma.Pretty
import Juvix.Compiler.Nockma.Translation.FromAsm
import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma
@ -13,7 +14,10 @@ runCommand opts = do
case parsedTerm of
Left err -> exitJuvixError (JuvixError err)
Right (TermCell c) -> do
res <- runOutputSem @(Term Natural) (say . ppTrace) (evalCompiledNock' (c ^. cellLeft) (c ^. cellRight))
res <-
runReader defaultEvalOptions
. runOutputSem @(Term Natural) (say . ppTrace)
$ evalCompiledNock' (c ^. cellLeft) (c ^. cellRight)
ret <- getReturn res
putStrLn (ppPrint ret)
Right TermAtom {} -> exitFailMsg "Expected nockma input to be a cell"

8
app/Commands/Dev/Nockma/Repl.hs
View File

@ -8,6 +8,7 @@ import Control.Exception (throwIO)
import Control.Monad.State.Strict qualified as State
import Data.String.Interpolate (__i)
import Juvix.Compiler.Nockma.Evaluator (NockEvalError, evalRepl, fromReplTerm, programAssignments)
import Juvix.Compiler.Nockma.Evaluator.Options
import Juvix.Compiler.Nockma.Language
import Juvix.Compiler.Nockma.Pretty (ppPrint)
import Juvix.Compiler.Nockma.Pretty qualified as Nockma
@ -133,9 +134,10 @@ evalStatement = \case
prog <- getProgram
et <-
liftIO
$ runM
. runError @(ErrNockNatural Natural)
. runError @NockEvalError
. runM
. runReader defaultEvalOptions
. runError @(ErrNockNatural Natural)
. runError @NockEvalError
$ evalRepl (putStrLn . Nockma.ppTrace) prog s t
case et of
Left e -> error (show e)

1
package.yaml
View File

@ -143,6 +143,7 @@ default-extensions:
- NoFieldSelectors
- NoImplicitPrelude
- OverloadedStrings
- PatternSynonyms
- QuasiQuotes
- RecordWildCards
- TemplateHaskell

85
src/Juvix/Compiler/Nockma/Evaluator.hs
View File

@ -1,10 +1,12 @@
module Juvix.Compiler.Nockma.Evaluator
( module Juvix.Compiler.Nockma.Evaluator,
module Juvix.Compiler.Nockma.Evaluator.Error,
module Juvix.Compiler.Nockma.Evaluator.Options,
)
where
import Juvix.Compiler.Nockma.Evaluator.Error
import Juvix.Compiler.Nockma.Evaluator.Options
import Juvix.Compiler.Nockma.Language
import Juvix.Compiler.Nockma.Pretty
import Juvix.Prelude hiding (Atom, Path)
@ -45,7 +47,7 @@ subTermT = go
subTerm :: (Member (Error NockEvalError) r) => Term a -> Path -> Sem r (Term a)
subTerm term pos = do
case term ^? subTermT pos of
Nothing -> throw @NockEvalError (error "")
Nothing -> throw (InvalidPath "subterm")
Just t -> return t
setSubTerm :: (Member (Error NockEvalError) r) => Term a -> Path -> Term a -> Sem r (Term a)
@ -55,11 +57,25 @@ setSubTerm term pos repTerm =
| isNothing (getFirst old) -> throw @NockEvalError (error "")
| otherwise -> return new
parseCell :: forall r a. (Members '[Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) => Cell a -> Sem r (ParsedCell a)
parseCell ::
forall r a.
(Members '[Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) =>
Cell a ->
Sem r (ParsedCell a)
parseCell c = case c ^. cellLeft of
TermAtom a -> ParsedOperatorCell <$> parseOperatorCell a (c ^. cellRight)
TermAtom a -> operatorOrStdlibCall a (c ^. cellRight) (c ^. cellInfo . unIrrelevant)
TermCell l -> return (ParsedAutoConsCell (AutoConsCell l (c ^. cellRight)))
where
operatorOrStdlibCall :: Atom a -> Term a -> Maybe (StdlibCall a) -> Sem r (ParsedCell a)
operatorOrStdlibCall a t mcall = do
opCell <- parseOperatorCell a t
return $ case mcall of
Nothing -> ParsedOperatorCell opCell
Just call -> ParsedStdlibCallCell (parseStdlibCall opCell call)
parseStdlibCall :: OperatorCell a -> StdlibCall a -> StdlibCallCell a
parseStdlibCall op call = StdlibCallCell call op
parseOperatorCell :: Atom a -> Term a -> Sem r (OperatorCell a)
parseOperatorCell a t = do
op <- nockOp a
@ -84,7 +100,7 @@ programAssignments mprog =
-- | The stack provided in the replExpression has priority
evalRepl ::
forall r a.
(PrettyCode a, Members '[Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) =>
(PrettyCode a, Integral a, Members '[Reader EvalOptions, Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) =>
(Term a -> Sem r ()) ->
Maybe (Program a) ->
Maybe (Term a) ->
@ -105,20 +121,57 @@ evalRepl handleTrace mprog defaultStack expr = do
namedTerms :: HashMap Text (Term a)
namedTerms = programAssignments mprog
eval :: forall r a. (PrettyCode a, Members '[Output (Term a), Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) => Term a -> Term a -> Sem r (Term a)
eval ::
forall r a.
(PrettyCode a, Integral a, Members '[Reader EvalOptions, Output (Term a), Error NockEvalError, Error (ErrNockNatural a)] r, NockNatural a) =>
Term a ->
Term a ->
Sem r (Term a)
eval stack = \case
TermAtom a -> throw (ExpectedCell ("eval " <> ppTrace a))
TermCell c -> do
pc <- parseCell c
case pc of
TermCell c ->
parseCell c >>= \case
ParsedAutoConsCell a -> goAutoConsCell a
ParsedOperatorCell o -> goOperatorCell o
ParsedStdlibCallCell o -> do
ignore <- asks (^. evalIgnoreStdlibCalls)
if
| ignore -> goOperatorCell (o ^. stdlibCallRaw)
| otherwise -> goStdlibCall (o ^. stdlibCallCell)
where
goStdlibCall :: StdlibCall a -> Sem r (Term a)
goStdlibCall StdlibCall {..} = do
args' <- eval stack _stdlibCallArgs
let binArith :: (a -> a -> a) -> Sem r (Term a)
binArith f = case args' of
TCell (TAtom l) (TAtom r) -> return (TCell (TAtom (f l r)) stack)
_ -> error "expected a cell with two atoms"
unaArith :: (a -> a) -> Sem r (Term a)
unaArith f = case args' of
TAtom n -> return (TCell (TAtom (f n)) stack)
_ -> error "expected an atom"
binCmp :: (a -> a -> Bool) -> Sem r (Term a)
binCmp f = case args' of
TCell (TAtom l) (TAtom r) -> return (TCell (TermAtom (nockBool (f l r))) stack)
_ -> error "expected a cell with two atoms"
case _stdlibCallFunction of
StdlibDec -> unaArith pred
StdlibAdd -> binArith (+)
StdlibMul -> binArith (*)
StdlibSub -> binArith (-)
StdlibDiv -> binArith div
StdlibMod -> binArith mod
StdlibLt -> binCmp (<)
StdlibLe -> binCmp (<=)
goAutoConsCell :: AutoConsCell a -> Sem r (Term a)
goAutoConsCell c = do
_cellLeft <- eval stack (TermCell (c ^. autoConsCellLeft))
_cellRight <- eval stack (c ^. autoConsCellRight)
return (TermCell Cell {..})
l' <- eval stack (TermCell (c ^. autoConsCellLeft))
r' <- eval stack (c ^. autoConsCellRight)
return (TermCell (Cell l' r'))
goOperatorCell :: OperatorCell a -> Sem r (Term a)
goOperatorCell c = case c ^. operatorCellOp of
@ -149,7 +202,7 @@ eval stack = \case
goOpTrace :: Sem r (Term a)
goOpTrace = do
Cell tr a <- asCell "OpTrace" (c ^. operatorCellTerm)
Cell' tr a _ <- asCell "OpTrace" (c ^. operatorCellTerm)
tr' <- eval stack tr
output tr'
eval stack a
@ -164,13 +217,13 @@ eval stack = \case
goOpPush = do
cellTerm <- asCell "OpPush" (c ^. operatorCellTerm)
l <- eval stack (cellTerm ^. cellLeft)
let s = TermCell Cell {_cellLeft = l, _cellRight = stack}
let s = TermCell (Cell l stack)
eval s (cellTerm ^. cellRight)
goOpReplace :: Sem r (Term a)
goOpReplace = do
Cell rot1 t2 <- asCell "OpReplace 1" (c ^. operatorCellTerm)
Cell ro t1 <- asCell "OpReplace 2" rot1
Cell' rot1 t2 _ <- asCell "OpReplace 1" (c ^. operatorCellTerm)
Cell' ro t1 _ <- asCell "OpReplace 2" rot1
r <- asPath ro
t1' <- eval stack t1
t2' <- eval stack t2
@ -187,7 +240,7 @@ eval stack = \case
goOpIf = do
cellTerm <- asCell "OpIf 1" (c ^. operatorCellTerm)
let t0 = cellTerm ^. cellLeft
Cell t1 t2 <- asCell "OpIf 2" (cellTerm ^. cellRight)
Cell' t1 t2 _ <- asCell "OpIf 2" (cellTerm ^. cellRight)
cond <- eval stack t0 >>= asBool
if
| cond -> eval stack t1

12
src/Juvix/Compiler/Nockma/Evaluator/Options.hs Normal file
View File

@ -0,0 +1,12 @@
module Juvix.Compiler.Nockma.Evaluator.Options where
import Juvix.Prelude.Base
newtype EvalOptions = EvalOptions
{ _evalIgnoreStdlibCalls :: Bool
}
defaultEvalOptions :: EvalOptions
defaultEvalOptions = EvalOptions False
makeLenses ''EvalOptions

113
src/Juvix/Compiler/Nockma/Language.hs
View File

@ -45,9 +45,17 @@ data Term a
| TermCell (Cell a)
deriving stock (Show, Eq, Lift)
data Cell a = Cell
data StdlibCall a = StdlibCall
{ _stdlibCallFunction :: StdlibFunction,
_stdlibCallArgs :: Term a
}
deriving stock instance (Lift a) => Lift (StdlibCall a)
data Cell a = Cell'
{ _cellLeft :: Term a,
_cellRight :: Term a
_cellRight :: Term a,
_cellInfo :: Irrelevant (Maybe (StdlibCall a))
}
deriving stock (Show, Eq, Lift)
@ -98,9 +106,45 @@ instance Pretty NockOp where
OpHint -> "hint"
OpTrace -> "trace"
instance Pretty StdlibFunction where
pretty = \case
StdlibDec -> "dec"
StdlibAdd -> "add"
StdlibSub -> "sub"
StdlibMul -> "mul"
StdlibDiv -> "div"
StdlibMod -> "mod"
StdlibLt -> "<"
StdlibLe -> "<="
data StdlibFunction
= StdlibDec
| StdlibAdd
| StdlibSub
| StdlibMul
| StdlibDiv
| StdlibMod
| StdlibLt
| StdlibLe
deriving stock (Show, Lift, Eq, Bounded, Enum)
textToStdlibFunctionMap :: HashMap Text StdlibFunction
textToStdlibFunctionMap =
hashMap
[ (prettyText f, f) | f <- allElements
]
parseStdlibFunction :: Text -> Maybe StdlibFunction
parseStdlibFunction t = textToStdlibFunctionMap ^. at t
atomOps :: HashMap Text NockOp
atomOps = HashMap.fromList [(prettyText op, op) | op <- allElements]
data StdlibCallCell a = StdlibCallCell
{ _stdlibCallCell :: StdlibCall a,
_stdlibCallRaw :: OperatorCell a
}
data OperatorCell a = OperatorCell
{ _operatorCellOp :: NockOp,
_operatorCellTerm :: Term a
@ -114,6 +158,7 @@ data AutoConsCell a = AutoConsCell
data ParsedCell a
= ParsedOperatorCell (OperatorCell a)
| ParsedAutoConsCell (AutoConsCell a)
| ParsedStdlibCallCell (StdlibCallCell a)
newtype EncodedPath = EncodedPath
{ _encodedPath :: Natural
@ -138,6 +183,8 @@ emptyPath :: Path
emptyPath = []
makeLenses ''Cell
makeLenses ''StdlibCallCell
makeLenses ''StdlibCall
makeLenses ''Atom
makeLenses ''OperatorCell
makeLenses ''AutoConsCell
@ -223,6 +270,11 @@ class (Eq a) => NockNatural a where
nockSucc :: Atom a -> Atom a
nockNil :: Atom a
nockBool :: (NockNatural a) => Bool -> Atom a
nockBool = \case
True -> nockTrue
False -> nockFalse
data NockNaturalNaturalError
= NaturalInvalidPath (Atom Natural)
| NaturalInvalidOp (Atom Natural)
@ -264,7 +316,7 @@ instance IsNock (Cell Natural) where
toNock = TermCell
instance IsNock Natural where
toNock n = toNock (Atom n (Irrelevant Nothing))
toNock n = TermAtom (Atom n (Irrelevant Nothing))
instance IsNock NockOp where
toNock op = toNock (Atom (serializeOp op) (Irrelevant (Just AtomHintOp)))
@ -280,13 +332,58 @@ instance IsNock Path where
instance IsNock EncodedPath where
toNock = toNock . decodePath'
infixr 5 #
(#) :: (IsNock x, IsNock y) => x -> y -> Term Natural
a # b = TermCell (Cell (toNock a) (toNock b))
instance Semigroup EncodedPath where
a <> b = encodePath (decodePath' a <> decodePath' b)
instance Monoid EncodedPath where
mempty = encodePath []
infixr 5 #.
(#.) :: (IsNock x, IsNock y) => x -> y -> Cell Natural
a #. b = Cell (toNock a) (toNock b)
infixr 5 #
(#) :: (IsNock x, IsNock y) => x -> y -> Term Natural
a # b = TermCell (a #. b)
infixl 1 >>#.
(>>#.) :: (IsNock x, IsNock y) => x -> y -> Cell Natural
a >>#. b = OpSequence #. a # b
infixl 1 >>#
(>>#) :: (IsNock x, IsNock y) => x -> y -> Term Natural
a >># b = TermCell (a >>#. b)
stdlibNumArgs :: StdlibFunction -> Natural
stdlibNumArgs = \case
StdlibDec -> 1
StdlibAdd -> 2
StdlibSub -> 2
StdlibMul -> 2
StdlibMod -> 2
StdlibDiv -> 2
StdlibLe -> 2
StdlibLt -> 2
{-# COMPLETE Cell #-}
pattern Cell :: Term a -> Term a -> Cell a
pattern Cell {_cellLeft', _cellRight'} <- Cell' _cellLeft' _cellRight' _
where
Cell a b = Cell' a b (Irrelevant Nothing)
{-# COMPLETE TCell, TAtom #-}
pattern TCell :: Term a -> Term a -> Term a
pattern TCell l r <- TermCell (Cell' l r _)
where
TCell a b = TermCell (Cell' a b (Irrelevant Nothing))
pattern TAtom :: a -> Term a
pattern TAtom a <- TermAtom (Atom a _)
where
TAtom a = TermAtom (Atom a (Irrelevant Nothing))

16
src/Juvix/Compiler/Nockma/Pretty/Base.hs
View File

@ -8,6 +8,7 @@ where
import Juvix.Compiler.Nockma.Language
import Juvix.Compiler.Nockma.Pretty.Options
import Juvix.Data.CodeAnn
import Juvix.Extra.Strings qualified as Str
import Juvix.Prelude hiding (Atom, Path)
doc :: (PrettyCode c) => Options -> c -> Doc Ann
@ -55,15 +56,28 @@ instance PrettyCode NockOp where
ppCode =
return . annotate (AnnKind KNameFunction) . pretty
instance PrettyCode StdlibFunction where
ppCode = return . pretty
instance (PrettyCode a, NockNatural a) => PrettyCode (StdlibCall a) where
ppCode c = do
fun <- ppCode (c ^. stdlibCallFunction)
args <- ppCode (c ^. stdlibCallArgs)
return (Str.stdlibTag <> fun <+> Str.argsTag <> args)
instance (PrettyCode a, NockNatural a) => PrettyCode (Cell a) where
ppCode c = do
m <- asks (^. optPrettyMode)
inside <- case m of
stdlibCall <- runFail $ do
failWhenM (asks (^. optIgnoreHints))
failMaybe (c ^. cellInfo . unIrrelevant) >>= ppCode
components <- case m of
AllDelimiters -> do
l' <- ppCode (c ^. cellLeft)
r' <- ppCode (c ^. cellRight)
return (l' <+> r')
MinimizeDelimiters -> sep <$> mapM ppCode (unfoldCell c)
let inside = stdlibCall <?+> components
return (oneLineOrNextBrackets inside)
unfoldCell :: Cell a -> NonEmpty (Term a)

48
src/Juvix/Compiler/Nockma/Translation/FromAsm.hs
View File

@ -112,27 +112,6 @@ functionPath = \case
FunctionCode -> [L]
FunctionArgs -> [R]
data StdlibFunction
= StdlibDec
| StdlibAdd
| StdlibSub
| StdlibMul
| StdlibDiv
| StdlibMod
| StdlibLt
| StdlibLe
stdlibNumArgs :: StdlibFunction -> Natural
stdlibNumArgs = \case
StdlibDec -> 1
StdlibAdd -> 2
StdlibSub -> 2
StdlibMul -> 2
StdlibMod -> 2
StdlibDiv -> 2
StdlibLe -> 2
StdlibLt -> 2
-- | The stdlib paths are obtained using scripts/nockma-stdlib-parser.sh
stdlibPath :: StdlibFunction -> Path
stdlibPath =
@ -490,10 +469,7 @@ sub a b aux = do
moveTopFromTo AuxStack ValueStack
seqTerms :: [Term Natural] -> Term Natural
seqTerms = foldl' step (OpAddress # emptyPath) . reverse
where
step :: Term Natural -> Term Natural -> Term Natural
step acc t = OpSequence # t # acc
seqTerms = foldl' (flip (>>#)) (OpAddress # emptyPath) . reverse
makeEmptyList :: Term Natural
makeEmptyList = makeList []
@ -785,11 +761,19 @@ callStdlibOn' s f = do
let fNumArgs = stdlibNumArgs f
fPath = stdlibPath f
decodeFn = OpCall # (fPath # (OpAddress # stackPath StandardLibrary))
arguments = OpSequence # (OpAddress # [R]) # stdlibStackTake s fNumArgs
preargs = stdlibStackTake s fNumArgs
arguments = OpSequence # (OpAddress # [R]) # preargs
extractResult = (OpAddress # [L]) # (OpAddress # [R, R])
callFn = OpPush # (OpCall # [L] # (OpReplace # ([R, L] # arguments) # (OpAddress # [L]))) # extractResult
meta =
StdlibCall
{ _stdlibCallArgs = preargs,
_stdlibCallFunction = f
}
output (OpPush # decodeFn # callFn)
callCell = (OpPush #. (decodeFn # callFn)) {_cellInfo = Irrelevant (Just meta)}
output (toNock callCell)
output (replaceTopStackN fNumArgs s)
where
stdlibStackTake :: StackId -> Natural -> Term Natural
@ -1021,18 +1005,12 @@ pushNat = pushNatOnto ValueStack
pushNatOnto :: (Member Compiler r) => StackId -> Natural -> Sem r ()
pushNatOnto s n = pushOnto s (OpQuote # toNock n)
compileAndRunNock :: CompilerOptions -> ConstructorArities -> [CompilerFunction] -> CompilerFunction -> Term Natural
compileAndRunNock opts constrs funs = run . ignoreOutput @(Term Natural) . compileAndRunNock' opts constrs funs
compileAndRunNock' :: (Member (Output (Term Natural)) r) => CompilerOptions -> ConstructorArities -> [CompilerFunction] -> CompilerFunction -> Sem r (Term Natural)
compileAndRunNock' :: (Members '[Reader EvalOptions, Output (Term Natural)] r) => CompilerOptions -> ConstructorArities -> [CompilerFunction] -> CompilerFunction -> Sem r (Term Natural)
compileAndRunNock' opts constrs funs mainfun =
let Cell nockSubject t = runCompilerWith opts constrs funs mainfun
in evalCompiledNock' nockSubject t
evalCompiledNock :: Term Natural -> Term Natural -> Term Natural
evalCompiledNock stack = run . ignoreOutput @(Term Natural) . evalCompiledNock' stack
evalCompiledNock' :: (Member (Output (Term Natural)) r) => Term Natural -> Term Natural -> Sem r (Term Natural)
evalCompiledNock' :: (Members '[Reader EvalOptions, Output (Term Natural)] r) => Term Natural -> Term Natural -> Sem r (Term Natural)
evalCompiledNock' stack mainTerm = do
evalT <-
runError @(ErrNockNatural Natural)

30
src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs
View File

@ -4,6 +4,7 @@ import Data.HashMap.Internal.Strict qualified as HashMap
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text qualified as Text
import Juvix.Compiler.Nockma.Language qualified as N
import Juvix.Extra.Strings qualified as Str
import Juvix.Parser.Error
import Juvix.Prelude hiding (Atom, many, some)
import Juvix.Prelude.Parsing hiding (runParser)
@ -43,7 +44,9 @@ runParser :: FilePath -> Text -> Either MegaparsecError (N.Term Natural)
runParser = runParserFor term
spaceConsumer :: Parser ()
spaceConsumer = L.space space1 empty empty
spaceConsumer = L.space space1 lineComment empty
where
lineComment :: Parser () = L.skipLineComment "--"
lexeme :: Parser a -> Parser a
lexeme = L.lexeme spaceConsumer
@ -102,14 +105,37 @@ patom =
<|> atomBool
<|> atomNil
iden :: Parser Text
iden = lexeme (takeWhile1P (Just "<iden>") isAlphaNum)
cell :: Parser (N.Cell Natural)
cell = do
lsbracket
c <- optional stdlibCall
firstTerm <- term
restTerms <- some term
rsbracket
return (buildCell firstTerm restTerms)
let r = buildCell firstTerm restTerms
return (set N.cellInfo (Irrelevant c) r)
where
stdlibCall :: Parser (N.StdlibCall Natural)
stdlibCall = do
chunk Str.stdlibTag
f <- stdlibFun
chunk Str.argsTag
args <- term
return
N.StdlibCall
{ _stdlibCallArgs = args,
_stdlibCallFunction = f
}
stdlibFun :: Parser N.StdlibFunction
stdlibFun = do
i <- iden
let err = error ("invalid stdlib function identifier: " <> i)
maybe err return (N.parseStdlibFunction i)
buildCell :: N.Term Natural -> NonEmpty (N.Term Natural) -> N.Cell Natural
buildCell h = \case
x :| [] -> N.Cell h x

4
src/Juvix/Data/Effect/Fail.hs
View File

@ -45,6 +45,10 @@ failWhen :: (Member Fail r) => Bool -> Sem r ()
failWhen c = when c fail
{-# INLINE failWhen #-}
failWhenM :: (Member Fail r) => Sem r Bool -> Sem r ()
failWhenM c = whenM c fail
{-# INLINE failWhenM #-}
failUnlessM :: (Member Fail r) => Sem r Bool -> Sem r ()
failUnlessM c = unlessM c fail
{-# INLINE failUnlessM #-}

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

@ -581,6 +581,12 @@ tmp = "tmp"
instrAdd :: (IsString s) => s
instrAdd = "add"
argsTag :: (IsString s) => s
argsTag = "args@"
stdlibTag :: (IsString s) => s
stdlibTag = "stdlib@"
instrSub :: (IsString s) => s
instrSub = "sub"

21
test/Nockma/Compile/Asm/Positive.hs
View File

@ -5,6 +5,7 @@ import Asm.Run.Positive qualified as Asm
import Base
import Juvix.Compiler.Asm
import Juvix.Compiler.Asm.Options qualified as Asm
import Juvix.Compiler.Nockma.Evaluator qualified as NockmaEval
import Juvix.Compiler.Nockma.Language
import Juvix.Compiler.Nockma.Pretty qualified as Nockma
import Juvix.Compiler.Nockma.Translation.FromAsm
@ -14,13 +15,19 @@ runNockmaAssertion :: Handle -> Symbol -> InfoTable -> IO ()
runNockmaAssertion hout _main tab = do
Nockma.Cell nockSubject nockMain <-
runM
( runReader
(Asm.makeOptions TargetNockma True)
$ runReader
(Nockma.CompilerOptions {_compilerOptionsEnableTrace = True})
(runErrorIO' @JuvixError (asmToNockma' tab))
)
res <- runM $ runOutputSem @(Term Natural) (embed . hPutStrLn hout . Nockma.ppPrint) (evalCompiledNock' nockSubject nockMain)
. runReader
(Asm.makeOptions TargetNockma True)
. runReader
(Nockma.CompilerOptions {_compilerOptionsEnableTrace = True})
. runErrorIO' @JuvixError
$ asmToNockma' tab
res <-
runM
. runOutputSem @(Term Natural)
(embed . hPutStrLn hout . Nockma.ppPrint)
. runReader NockmaEval.defaultEvalOptions
. evalCompiledNock' nockSubject
$ nockMain
let ret = getReturn res
hPutStrLn hout (Nockma.ppPrint ret)
where

146
test/Nockma/Compile/Positive.hs
View File

@ -16,6 +16,7 @@ type Check = Sem '[Reader [Term Natural], Reader (Term Natural), Embed IO]
data Test = Test
{ _testName :: Text,
_testCheck :: Check (),
_testEvalOptions :: EvalOptions,
_testProgram :: Sem '[Compiler] ()
}
@ -33,8 +34,12 @@ data FunctionName
sym :: (Enum a) => a -> FunctionId
sym = UserFunction . Asm.defaultSymbol . fromIntegral . fromEnum
debugProg :: Sem '[Compiler] () -> ([Term Natural], Term Natural)
debugProg mkMain = run . runOutputList $ compileAndRunNock' opts exampleConstructors exampleFunctions mainFun
debugProg :: EvalOptions -> Sem '[Compiler] () -> ([Term Natural], Term Natural)
debugProg evalOpts mkMain =
run
. runReader evalOpts
. runOutputList
$ compileAndRunNock' opts exampleConstructors exampleFunctions mainFun
where
mainFun =
CompilerFunction
@ -122,7 +127,7 @@ allTests = testGroup "Nockma compile unit positive" (map mk tests)
where
mk :: Test -> TestTree
mk Test {..} = testCase (unpack _testName) $ do
let (traces, n) = debugProg _testProgram
let (traces, n) = debugProg _testEvalOptions _testProgram
runM (runReader n (runReader traces _testCheck))
eqSubStack :: StackId -> Path -> Term Natural -> Check ()
@ -167,7 +172,7 @@ eqStack st = eqSubStack st []
unfoldTerm :: Term Natural -> NonEmpty (Term Natural)
unfoldTerm t = case t of
TermAtom {} -> t :| []
TermCell Cell {..} -> _cellLeft NonEmpty.<| unfoldTerm _cellRight
TermCell (Cell l r) -> l NonEmpty.<| unfoldTerm r
checkStackSize :: StackId -> Natural -> Check ()
checkStackSize st stSize = subStackPred st ([] :: Path) $ \s -> do
@ -186,49 +191,94 @@ checkStackSize st stSize = subStackPred st ([] :: Path) $ \s -> do
<> show n
assertFailure (unpack msg)
defTest :: Text -> Check () -> Sem '[Compiler] () -> Test
defTest _testName _testCheck _testProgram =
Test
{ _testEvalOptions = defaultEvalOptions,
..
}
defTestNoJets :: Text -> Check () -> Sem '[Compiler] () -> Test
defTestNoJets _testName _testCheck _testProgram =
Test
{ _testEvalOptions =
EvalOptions
{ _evalIgnoreStdlibCalls = True
},
..
}
tests :: [Test]
tests =
[ Test "push" (eqStack ValueStack [nock| [1 5 nil] |]) $ do
[ defTest "push" (eqStack ValueStack [nock| [1 5 nil] |]) $ do
pushNat 5
pushNat 1,
Test "pop" (eqStack ValueStack [nock| [1 nil] |]) $ do
defTest "pop" (eqStack ValueStack [nock| [1 nil] |]) $ do
pushNat 1
pushNat 33
pop,
Test "increment" (eqStack ValueStack [nock| [3 nil] |]) $ do
defTest "increment" (eqStack ValueStack [nock| [3 nil] |]) $ do
pushNat 1
increment
increment,
Test "dec" (eqStack ValueStack [nock| [5 nil] |]) $ do
defTest "dec" (eqStack ValueStack [nock| [5 nil] |]) $ do
pushNat 6
dec,
Test "branch true" (eqStack ValueStack [nock| [5 nil] |]) $ do
defTest "branch true" (eqStack ValueStack [nock| [5 nil] |]) $ do
push (nockBoolLiteral True)
branch (pushNat 5) (pushNat 666),
Test "branch false" (eqStack ValueStack [nock| [666 nil] |]) $ do
defTest "branch false" (eqStack ValueStack [nock| [666 nil] |]) $ do
push (nockBoolLiteral False)
branch (pushNat 5) (pushNat 666),
Test "sub" (eqStack ValueStack [nock| [5 nil] |]) $ do
defTest "sub" (eqStack ValueStack [nock| [5 nil] |]) $ do
pushNat 3
pushNat 8
callStdlib StdlibSub,
Test "mul" (eqStack ValueStack [nock| [24 nil] |]) $ do
defTest "mul" (eqStack ValueStack [nock| [24 nil] |]) $ do
pushNat 8
pushNat 3
callStdlib StdlibMul,
Test "div" (eqStack ValueStack [nock| [3 nil] |]) $ do
defTest "div" (eqStack ValueStack [nock| [3 nil] |]) $ do
pushNat 5
pushNat 15
callStdlib StdlibDiv,
Test "mod" (eqStack ValueStack [nock| [5 nil] |]) $ do
defTest "mod" (eqStack ValueStack [nock| [5 nil] |]) $ do
pushNat 10
pushNat 15
callStdlib StdlibMod,
Test "add" (eqStack ValueStack [nock| [5 nil] |]) $ do
defTestNoJets "mul no jets" (eqStack ValueStack [nock| [24 nil] |]) $ do
pushNat 8
pushNat 3
callStdlib StdlibMul,
defTestNoJets "div no jets" (eqStack ValueStack [nock| [3 nil] |]) $ do
pushNat 5
pushNat 15
callStdlib StdlibDiv,
defTestNoJets "mod no jets" (eqStack ValueStack [nock| [5 nil] |]) $ do
pushNat 10
pushNat 15
callStdlib StdlibMod,
defTest "add" (eqStack ValueStack [nock| [5 nil] |]) $ do
pushNat 2
pushNat 3
add,
Test "pow2" (eqStack ValueStack [nock| [1 2 8 32 nil] |]) $ do
defTest "add big" (eqStack ValueStack [nock| [55555 nil] |]) $ do
pushNat 33333
pushNat 22222
add,
defTest "mul big" (eqStack ValueStack [nock| [1111088889 nil] |]) $ do
pushNat 33333
pushNat 33333
mul,
defTest "sub big" (eqStack ValueStack [nock| [66666 nil] |]) $ do
pushNat 33333
pushNat 99999
callStdlib StdlibSub,
defTest "le big" (eqStack ValueStack [nock| [true nil] |]) $ do
pushNat 99999
pushNat 999
callStdlib StdlibLe,
defTest "pow2" (eqStack ValueStack [nock| [1 2 8 32 nil] |]) $ do
pushNat 5
pow2
pushNat 3
@ -237,38 +287,38 @@ tests =
pow2
pushNat 0
pow2,
Test "append rights" (eqStack ValueStack [nock| [95 3 nil] |]) $ do
defTest "append rights" (eqStack ValueStack [nock| [95 3 nil] |]) $ do
push (OpQuote # toNock ([] :: Path))
pushNat 1
appendRights
push (OpQuote # toNock [L])
pushNat 5
appendRights,
Test "le less" (eqStack ValueStack [nock| [1 nil] |]) $ do
defTest "le less" (eqStack ValueStack [nock| [1 nil] |]) $ do
pushNat 2
pushNat 3
callStdlib StdlibLe,
Test "lt true" (eqStack ValueStack [nock| [0 nil] |]) $ do
defTest "lt true" (eqStack ValueStack [nock| [0 nil] |]) $ do
pushNat 4
pushNat 3
callStdlib StdlibLt,
Test "lt eq" (eqStack ValueStack [nock| [1 nil] |]) $ do
defTest "lt eq" (eqStack ValueStack [nock| [1 nil] |]) $ do
pushNat 3
pushNat 3
callStdlib StdlibLt,
Test "le eq" (eqStack ValueStack [nock| [0 nil] |]) $ do
defTest "le eq" (eqStack ValueStack [nock| [0 nil] |]) $ do
pushNat 3
pushNat 3
callStdlib StdlibLe,
Test "primitive eq true" (eqStack ValueStack [nock| [0 nil] |]) $ do
defTest "primitive eq true" (eqStack ValueStack [nock| [0 nil] |]) $ do
pushNat 4
pushNat 4
testEq,
Test "primitive eq false" (eqStack ValueStack [nock| [1 nil] |]) $ do
defTest "primitive eq false" (eqStack ValueStack [nock| [1 nil] |]) $ do
pushNat 4
pushNat 1
testEq,
Test
defTest
"save"
( do
eqStack ValueStack [nock| [67 2 nil] |]
@ -279,21 +329,21 @@ tests =
pushNat 3
save False (pushNat 77)
save True (pushNat 67),
Test "primitive increment" (eqStack ValueStack [nock| [5 nil] |]) $ do
defTest "primitive increment" (eqStack ValueStack [nock| [5 nil] |]) $ do
pushNat 3
increment
increment,
Test "call increment" (eqStack ValueStack [nock| [5 nil] |]) $ do
defTest "call increment" (eqStack ValueStack [nock| [5 nil] |]) $ do
pushNat 2
callEnum FunIncrement 1
callEnum FunIncrement 1
callEnum FunIncrement 1,
Test "call increment indirectly" (eqStack ValueStack [nock| [5 nil] |]) $ do
defTest "call increment indirectly" (eqStack ValueStack [nock| [5 nil] |]) $ do
pushNat 2
callEnum FunIncrement 1
callEnum FunCallInc 1
callEnum FunIncrement 1,
Test
defTest
"push temp"
( do
eqStack ValueStack [nock| [5 6 nil] |]
@ -304,20 +354,20 @@ tests =
pushNatOnto TempStack 6
pushTempRef 2 1
pushTempRef 2 0,
Test "push cell" (eqStack ValueStack [nock| [[1 2] nil] |]) $ do
defTest "push cell" (eqStack ValueStack [nock| [[1 2] nil] |]) $ do
push (OpQuote # (1 :: Natural) # (2 :: Natural)),
Test "push unit" (eqStack ValueStack [nock| [[0 nil nil] nil] |]) $ do
defTest "push unit" (eqStack ValueStack [nock| [[0 nil nil] nil] |]) $ do
push constUnit,
Test "alloc nullary constructor" (eqStack ValueStack [nock| [[0 nil nil] nil] |]) $ do
defTest "alloc nullary constructor" (eqStack ValueStack [nock| [[0 nil nil] nil] |]) $ do
allocConstr (constructorTag ConstructorFalse),
Test "alloc unary constructor" (eqStack ValueStack [nock| [[2 [[55 66] nil] nil] nil]|]) $ do
defTest "alloc unary constructor" (eqStack ValueStack [nock| [[2 [[55 66] nil] nil] nil]|]) $ do
push (OpQuote # (55 :: Natural) # (66 :: Natural))
allocConstr (constructorTag ConstructorWrapper),
Test "alloc binary constructor" (eqStack ValueStack [nock| [[3 [9 7 nil] nil] nil] |]) $ do
defTest "alloc binary constructor" (eqStack ValueStack [nock| [[3 [9 7 nil] nil] nil] |]) $ do
pushNat 7
pushNat 9
allocConstr (constructorTag ConstructorPair),
Test
defTest
"alloc closure"
( do
eqSubStack ValueStack (indexStack 0 ++ closurePath ClosureTotalArgsNum) [nock| 5 |]
@ -331,7 +381,7 @@ tests =
pushNat 9
pushNat 10
allocClosure (sym FunConst5) 3,
Test
defTest
"alloc closure no args from value stack"
( do
eqSubStack ValueStack (indexStack 0 ++ closurePath ClosureTotalArgsNum) [nock| 3 |]
@ -340,7 +390,7 @@ tests =
checkStackSize ValueStack 1
)
$ allocClosure (sym FunAdd3) 0,
Test
defTest
"extend closure"
( do
eqSubStack ValueStack (indexStack 0 ++ closurePath ClosureTotalArgsNum) [nock| 5 |]
@ -355,7 +405,7 @@ tests =
pushNat 10
allocClosure (sym FunConst5) 1
extendClosure 2,
Test "alloc, extend and call closure" (eqStack ValueStack [nock| [6 nil] |]) $
defTest "alloc, extend and call closure" (eqStack ValueStack [nock| [6 nil] |]) $
do
pushNat 1
pushNat 2
@ -363,13 +413,13 @@ tests =
allocClosure (sym FunAdd3) 1
extendClosure 1
callHelper False Nothing 1,
Test "call closure" (eqStack ValueStack [nock| [110 nil] |]) $
defTest "call closure" (eqStack ValueStack [nock| [110 nil] |]) $
do
pushNat 100
pushNat 110
allocClosure (sym FunConst) 1
callHelper False Nothing 1,
Test
defTest
"compute argsNum of a closure"
(eqStack ValueStack [nock| [2 7 nil] |])
$ do
@ -379,7 +429,7 @@ tests =
pushNat 10
allocClosure (sym FunConst5) 3
closureArgsNum,
Test
defTest
"save not tail"
( do
eqStack ValueStack [nock| [17 nil] |]
@ -392,7 +442,7 @@ tests =
addOn TempStack
moveTopFromTo TempStack ValueStack
pushNatOnto TempStack 9,
Test
defTest
"save tail"
( do
eqStack ValueStack [nock| [17 nil] |]
@ -405,7 +455,7 @@ tests =
addOn TempStack
moveTopFromTo TempStack ValueStack
pushNatOnto TempStack 9,
Test
defTest
"cmdCase: single branch"
(eqStack ValueStack [nock| [777 [2 [123 nil] nil] nil] |])
$ do
@ -415,7 +465,7 @@ tests =
Nothing
[ (constructorTag ConstructorWrapper, pushNat 777)
],
Test
defTest
"cmdCase: default branch"
(eqStack ValueStack [nock| [5 nil] |])
$ do
@ -425,7 +475,7 @@ tests =
(Just (pop >> pushNat 5))
[ (constructorTag ConstructorFalse, pushNat 777)
],
Test
defTest
"cmdCase: second branch"
(eqStack ValueStack [nock| [5 nil] |])
$ do
@ -436,7 +486,7 @@ tests =
[ (constructorTag ConstructorFalse, pushNat 0),
(constructorTag ConstructorWrapper, pop >> pushNat 5)
],
Test
defTest
"cmdCase: case on builtin true"
(eqStack ValueStack [nock| [5 nil] |])
$ do
@ -446,7 +496,7 @@ tests =
[ (Asm.BuiltinTag Asm.TagTrue, pop >> pushNat 5),
(Asm.BuiltinTag Asm.TagFalse, pushNat 0)
],
Test
defTest
"cmdCase: case on builtin false"
(eqStack ValueStack [nock| [5 nil] |])
$ do
@ -456,7 +506,7 @@ tests =
[ (Asm.BuiltinTag Asm.TagTrue, pushNat 0),
(Asm.BuiltinTag Asm.TagFalse, pop >> pushNat 5)
],
Test
defTest
"push constructor field"
(eqStack TempStack [nock| [30 nil] |])
$ do
@ -466,7 +516,7 @@ tests =
pushConstructorFieldOnto TempStack Asm.StackRef 0
pushConstructorFieldOnto TempStack Asm.StackRef 1
addOn TempStack,
Test
defTest
"trace"
( do
eqStack ValueStack [nock| [10 nil] |]

1
test/Nockma/Eval/Positive.hs
View File

@ -26,6 +26,7 @@ allTests = testGroup "Nockma eval unit positive" (map mk tests)
mk Test {..} = testCase (unpack _testName) $ do
let evalResult =
run
. runReader defaultEvalOptions
. ignoreOutput @(Term Natural)
. runError @(ErrNockNatural Natural)
. runError @NockEvalError

1
test/Nockma/Parse/Positive.hs
View File

@ -52,5 +52,6 @@ tests :: [PosTest]
tests =
[ PosTest "Identity" $(mkRelDir ".") $(mkRelFile "Identity.nock"),
PosTest "Identity Pretty" $(mkRelDir ".") $(mkRelFile "IdentityPretty.pnock"),
PosTest "StdlibCall" $(mkRelDir ".") $(mkRelFile "StdlibCall.pnock"),
PosTest "Stdlib" $(mkRelDir ".") $(mkRelFile "Stdlib.nock")
]

2
tests/nockma/positive/StdlibCall.pnock Normal file
View File

@ -0,0 +1,2 @@
-- It only tests parsing and printing. It cannot be evaluated
[stdlib@add args@[0 1] 123 [0 1]]