From 39d176e6432bb1981fbe3f0b5ed488dab54dc51b Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Fri, 19 Jan 2024 12:01:58 +0100 Subject: [PATCH] Fast nockma eval (#2580) 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@ ] ``` where `add` is the name of the function being called, `` is a nockma term that points to the position of the arguments, and `` and `` are the actual components of the cell. --- .github/workflows/ci.yml | 10 +- Makefile | 1 + app/Commands/Dev/Nockma/Eval.hs | 6 +- app/Commands/Dev/Nockma/Repl.hs | 8 +- package.yaml | 1 + src/Juvix/Compiler/Nockma/Evaluator.hs | 85 ++++++++-- .../Compiler/Nockma/Evaluator/Options.hs | 12 ++ src/Juvix/Compiler/Nockma/Language.hs | 113 +++++++++++++- src/Juvix/Compiler/Nockma/Pretty/Base.hs | 16 +- .../Compiler/Nockma/Translation/FromAsm.hs | 48 ++---- .../Nockma/Translation/FromSource/Base.hs | 30 +++- src/Juvix/Data/Effect/Fail.hs | 4 + src/Juvix/Extra/Strings.hs | 6 + test/Nockma/Compile/Asm/Positive.hs | 21 ++- test/Nockma/Compile/Positive.hs | 146 ++++++++++++------ test/Nockma/Eval/Positive.hs | 1 + test/Nockma/Parse/Positive.hs | 1 + tests/nockma/positive/StdlibCall.pnock | 2 + 18 files changed, 387 insertions(+), 124 deletions(-) create mode 100644 src/Juvix/Compiler/Nockma/Evaluator/Options.hs create mode 100644 tests/nockma/positive/StdlibCall.pnock diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 1437eef867..f9ce5bfb8c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -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 diff --git a/Makefile b/Makefile index d080d89819..86b6becfdd 100644 --- a/Makefile +++ b/Makefile @@ -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 \ diff --git a/app/Commands/Dev/Nockma/Eval.hs b/app/Commands/Dev/Nockma/Eval.hs index c48fe1769a..3bd4a2774e 100644 --- a/app/Commands/Dev/Nockma/Eval.hs +++ b/app/Commands/Dev/Nockma/Eval.hs @@ -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" diff --git a/app/Commands/Dev/Nockma/Repl.hs b/app/Commands/Dev/Nockma/Repl.hs index bc19569424..eb02af9646 100644 --- a/app/Commands/Dev/Nockma/Repl.hs +++ b/app/Commands/Dev/Nockma/Repl.hs @@ -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) diff --git a/package.yaml b/package.yaml index 3bd92c1bc0..7eb8e5ab6b 100644 --- a/package.yaml +++ b/package.yaml @@ -143,6 +143,7 @@ default-extensions: - NoFieldSelectors - NoImplicitPrelude - OverloadedStrings + - PatternSynonyms - QuasiQuotes - RecordWildCards - TemplateHaskell diff --git a/src/Juvix/Compiler/Nockma/Evaluator.hs b/src/Juvix/Compiler/Nockma/Evaluator.hs index 2d38b3f1d0..7ada4da0ce 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator.hs @@ -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 diff --git a/src/Juvix/Compiler/Nockma/Evaluator/Options.hs b/src/Juvix/Compiler/Nockma/Evaluator/Options.hs new file mode 100644 index 0000000000..34451675cf --- /dev/null +++ b/src/Juvix/Compiler/Nockma/Evaluator/Options.hs @@ -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 diff --git a/src/Juvix/Compiler/Nockma/Language.hs b/src/Juvix/Compiler/Nockma/Language.hs index cf284db813..227d9281be 100644 --- a/src/Juvix/Compiler/Nockma/Language.hs +++ b/src/Juvix/Compiler/Nockma/Language.hs @@ -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)) diff --git a/src/Juvix/Compiler/Nockma/Pretty/Base.hs b/src/Juvix/Compiler/Nockma/Pretty/Base.hs index 3d103210fd..4bb2a819a8 100644 --- a/src/Juvix/Compiler/Nockma/Pretty/Base.hs +++ b/src/Juvix/Compiler/Nockma/Pretty/Base.hs @@ -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) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromAsm.hs b/src/Juvix/Compiler/Nockma/Translation/FromAsm.hs index 4d065d34b4..f9e0ce76b2 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromAsm.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromAsm.hs @@ -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 + } + + callCell = (OpPush #. (decodeFn # callFn)) {_cellInfo = Irrelevant (Just meta)} - output (OpPush # decodeFn # callFn) + 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) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs index 3f111b2f70..0e41927cff 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs @@ -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 "") 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 diff --git a/src/Juvix/Data/Effect/Fail.hs b/src/Juvix/Data/Effect/Fail.hs index 42e3835d96..e4dcf62ed7 100644 --- a/src/Juvix/Data/Effect/Fail.hs +++ b/src/Juvix/Data/Effect/Fail.hs @@ -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 #-} diff --git a/src/Juvix/Extra/Strings.hs b/src/Juvix/Extra/Strings.hs index bb06c6387f..a0d394e885 100644 --- a/src/Juvix/Extra/Strings.hs +++ b/src/Juvix/Extra/Strings.hs @@ -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" diff --git a/test/Nockma/Compile/Asm/Positive.hs b/test/Nockma/Compile/Asm/Positive.hs index 0317f7c18a..53923d092b 100644 --- a/test/Nockma/Compile/Asm/Positive.hs +++ b/test/Nockma/Compile/Asm/Positive.hs @@ -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 diff --git a/test/Nockma/Compile/Positive.hs b/test/Nockma/Compile/Positive.hs index 6ad525c1b4..e1c18e45f1 100644 --- a/test/Nockma/Compile/Positive.hs +++ b/test/Nockma/Compile/Positive.hs @@ -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, + defTest "div" (eqStack ValueStack [nock| [3 nil] |]) $ do + pushNat 5 + pushNat 15 + callStdlib StdlibDiv, + defTest "mod" (eqStack ValueStack [nock| [5 nil] |]) $ do + pushNat 10 + pushNat 15 + callStdlib StdlibMod, + defTestNoJets "mul no jets" (eqStack ValueStack [nock| [24 nil] |]) $ do pushNat 8 pushNat 3 callStdlib StdlibMul, - Test "div" (eqStack ValueStack [nock| [3 nil] |]) $ do + defTestNoJets "div no jets" (eqStack ValueStack [nock| [3 nil] |]) $ do pushNat 5 pushNat 15 callStdlib StdlibDiv, - Test "mod" (eqStack ValueStack [nock| [5 nil] |]) $ do + defTestNoJets "mod no jets" (eqStack ValueStack [nock| [5 nil] |]) $ do pushNat 10 pushNat 15 callStdlib StdlibMod, - Test "add" (eqStack ValueStack [nock| [5 nil] |]) $ do + 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] |] diff --git a/test/Nockma/Eval/Positive.hs b/test/Nockma/Eval/Positive.hs index f2fb036981..39f58243e0 100644 --- a/test/Nockma/Eval/Positive.hs +++ b/test/Nockma/Eval/Positive.hs @@ -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 diff --git a/test/Nockma/Parse/Positive.hs b/test/Nockma/Parse/Positive.hs index 7a892161b9..654e53d349 100644 --- a/test/Nockma/Parse/Positive.hs +++ b/test/Nockma/Parse/Positive.hs @@ -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") ] diff --git a/tests/nockma/positive/StdlibCall.pnock b/tests/nockma/positive/StdlibCall.pnock new file mode 100644 index 0000000000..0921105346 --- /dev/null +++ b/tests/nockma/positive/StdlibCall.pnock @@ -0,0 +1,2 @@ +-- It only tests parsing and printing. It cannot be evaluated +[stdlib@add args@[0 1] 123 [0 1]]