From c499d0d7e11fb5d935c83e825dc06735316be9a1 Mon Sep 17 00:00:00 2001 From: Paul Cadman Date: Fri, 11 Oct 2024 15:53:06 +0100 Subject: [PATCH] Support Anoma stdlib curry function (#3097) This PR adds support for the Anoma node stdlib function to the nockma backend. https://developers.urbit.org/reference/hoon/stdlib/2n#cury This PR also changes the arguments placeholder value when compiling functions and closures to make it a tuple of length equal to the function/closure arity. To use curry, the function argument's placeholder argument tuple must have length equal to the function airty. For example if we are compiling a function with arity 2, the compiled nock function should have the form: ``` [compiled-code [0 0] env] ``` --- src/Juvix/Compiler/Nockma/Evaluator.hs | 14 +- src/Juvix/Compiler/Nockma/StdlibFunction.hs | 1 + .../Compiler/Nockma/StdlibFunction/Base.hs | 2 + .../Compiler/Nockma/Translation/FromTree.hs | 25 ++-- test/Nockma/Eval/Positive.hs | 130 +++++++++++++++++- 5 files changed, 159 insertions(+), 13 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Evaluator.hs b/src/Juvix/Compiler/Nockma/Evaluator.hs index 59b515320d..d7a7880e6b 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator.hs @@ -197,15 +197,18 @@ evalProfile inistack initerm = ParsedOperatorCell o -> goOperatorCell o ParsedStdlibCallCell o -> do intercept' <- asks (^. evalInterceptStdlibCalls) + let nonInterceptCall = goOperatorCell (o ^. stdlibCallRaw) + -- Pass the raw call to goStdlibCall so that stdlib intercepts + -- can choose to use the raw call instead. if - | intercept' -> goStdlibCall (o ^. stdlibCallCell) - | otherwise -> goOperatorCell (o ^. stdlibCallRaw) + | intercept' -> goStdlibCall nonInterceptCall (o ^. stdlibCallCell) + | otherwise -> nonInterceptCall where loc :: Maybe Interval loc = term ^. termLoc - goStdlibCall :: StdlibCall a -> Sem r (Term a) - goStdlibCall StdlibCall {..} = do + goStdlibCall :: Sem r (Term a) -> StdlibCall a -> Sem r (Term a) + goStdlibCall nonInterceptCall StdlibCall {..} = do let w = EvalCrumbStdlibCallArgs (CrumbStdlibCallArgs _stdlibCallFunction) args' <- withCrumb w (recEval stack _stdlibCallArgs) let binArith :: (a -> a -> a) -> Sem r (Term a) @@ -262,6 +265,9 @@ evalProfile inistack initerm = StdlibLengthBytes -> case args' of TermAtom a -> TermAtom <$> goLengthBytes a _ -> error "expected an atom" + -- Use the raw nock code for curry. The nock stdlib curry function is + -- small. There's no benefit in implementing it separately in the evaluator. + StdlibCurry -> nonInterceptCall where goCat :: Atom a -> Atom a -> Sem r (Term a) goCat arg1 arg2 = TermAtom . setAtomHint AtomHintString <$> atomConcatenateBytes arg1 arg2 diff --git a/src/Juvix/Compiler/Nockma/StdlibFunction.hs b/src/Juvix/Compiler/Nockma/StdlibFunction.hs index 4cef7f5646..427de12cfb 100644 --- a/src/Juvix/Compiler/Nockma/StdlibFunction.hs +++ b/src/Juvix/Compiler/Nockma/StdlibFunction.hs @@ -27,6 +27,7 @@ stdlibPath = \case StdlibSignDetached -> [nock| [9 23 0 1] |] StdlibVerify -> [nock| [9 4 0 1] |] StdlibLengthList -> [nock| [9 1.406 0 31] |] + StdlibCurry -> [nock| [9 4 0 31] |] -- Obtained from the urbit dojo using: -- -- => anoma !=(~(met block 3)) diff --git a/src/Juvix/Compiler/Nockma/StdlibFunction/Base.hs b/src/Juvix/Compiler/Nockma/StdlibFunction/Base.hs index 6474dcd327..1285916751 100644 --- a/src/Juvix/Compiler/Nockma/StdlibFunction/Base.hs +++ b/src/Juvix/Compiler/Nockma/StdlibFunction/Base.hs @@ -24,6 +24,7 @@ instance Pretty StdlibFunction where StdlibFoldBytes -> "fold-bytes" StdlibLengthList -> "length-list" StdlibLengthBytes -> "length-bytes" + StdlibCurry -> "curry" data StdlibFunction = StdlibDec @@ -45,6 +46,7 @@ data StdlibFunction | StdlibFoldBytes | StdlibLengthList | StdlibLengthBytes + | StdlibCurry deriving stock (Show, Lift, Eq, Bounded, Enum, Generic) instance Hashable StdlibFunction diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 60d33c3c16..2fea37e6a5 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -31,6 +31,9 @@ module Juvix.Compiler.Nockma.Translation.FromTree runCompilerWith, emptyCompilerCtx, CompilerCtx (..), + stdlibCurry, + IndexTupleArgs (..), + indexTuple, ) where @@ -758,7 +761,7 @@ compile = \case args <- mapM compile _nodeAllocClosureArgs return . makeClosure $ \case FunCode -> opAddress "allocClosureFunPath" (base <> fpath <> closurePath FunCode) - ArgsTuple -> OpQuote # argsTuplePlaceholder "goAllocClosure" + ArgsTuple -> OpQuote # argsTuplePlaceholder "goAllocClosure" farity FunctionsLibrary -> OpQuote # functionsLibraryPlaceHolder StandardLibrary -> OpQuote # stdlibPlaceHolder ClosureTotalArgsNum -> nockNatLiteral farity @@ -784,8 +787,11 @@ compile = \case opAddress' :: Term Natural -> Term Natural opAddress' x = evaluated $ (opQuote "opAddress'" OpAddress) # x -argsTuplePlaceholder :: Text -> Term Natural -argsTuplePlaceholder txt = nockNilTagged ("argsTuplePlaceholder-" <> txt) +argsTuplePlaceholder :: Text -> Natural -> Term Natural +argsTuplePlaceholder txt arity = ("argsTuplePlaceholder-" <> txt) @ foldTermsOrNil (replicate arityInt (TermAtom nockNil)) + where + arityInt :: Int + arityInt = fromIntegral arity appendRights :: (Member (Reader CompilerCtx) r) => Path -> Term Natural -> Sem r (Term Natural) appendRights path n = do @@ -975,18 +981,18 @@ runCompilerWith _opts constrs moduleFuns mainFun = compiledFuns = (OpQuote # (666 :: Natural)) -- TODO we have this unused term so that indices match. Remove it and adjust as needed : ( makeLibraryFunction - <$> [(f ^. compilerFunctionName, runCompilerFunction compilerCtx f) | f <- libFuns] + <$> [(f ^. compilerFunctionName, f ^. compilerFunctionArity, runCompilerFunction compilerCtx f) | f <- libFuns] ) - makeLibraryFunction :: (Text, Term Natural) -> Term Natural - makeLibraryFunction (funName, c) = + makeLibraryFunction :: (Text, Natural, Term Natural) -> Term Natural + makeLibraryFunction (funName, funArity, c) = ("def-" <> funName) @ makeClosure ( \p -> let nockNilHere = nockNilTagged ("makeLibraryFunction-" <> show p) in case p of FunCode -> ("funCode-" <> funName) @ c - ArgsTuple -> ("argsTuple-" <> funName) @ argsTuplePlaceholder "libraryFunction" + ArgsTuple -> ("argsTuple-" <> funName) @ argsTuplePlaceholder "libraryFunction" funArity FunctionsLibrary -> ("functionsLibrary-" <> funName) @ functionsLibraryPlaceHolder StandardLibrary -> ("stdlib-" <> funName) @ stdlibPlaceHolder ClosureTotalArgsNum -> ("closureTotalArgsNum-" <> funName) @ nockNilHere @@ -1000,7 +1006,7 @@ runCompilerWith _opts constrs moduleFuns mainFun = let nockNilHere = nockNilTagged ("makeMainFunction-" <> show p) in case p of FunCode -> run . runReader compilerCtx $ mainFunctionWrapper funcsLib c - ArgsTuple -> argsTuplePlaceholder "mainFunction" + ArgsTuple -> argsTuplePlaceholder "mainFunction" (mainFun ^. compilerFunctionArity) FunctionsLibrary -> functionsLibraryPlaceHolder StandardLibrary -> stdlib ClosureTotalArgsNum -> nockNilHere @@ -1304,3 +1310,6 @@ intToUInt8 i = callStdlib StdlibMod [i, nockIntegralLiteral @Natural (2 ^ uint8S where uint8Size :: Natural uint8Size = 8 + +stdlibCurry :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) +stdlibCurry f arg = callStdlib StdlibCurry [f, arg] diff --git a/test/Nockma/Eval/Positive.hs b/test/Nockma/Eval/Positive.hs index 32ca070ddf..7c4f1eeb02 100644 --- a/test/Nockma/Eval/Positive.hs +++ b/test/Nockma/Eval/Positive.hs @@ -159,6 +159,113 @@ testWithStorage s = Test defaultEvalOptions Nothing (Storage (HashMap.fromList ( test :: Text -> Term Natural -> Term Natural -> Check () -> Test test = testWithStorage [] +--- A Nock formula that computes logical and +nockAnd :: Term Natural +nockAnd = + OpIf + # (OpAddress # argPath 0) + # ( OpIf + # (OpAddress # argPath 1) + # nockTrueLiteral + # nockFalseLiteral + ) + # nockFalseLiteral + where + argPath :: Natural -> Path + argPath idx = + closurePath ArgsTuple + ++ indexTuple + ( IndexTupleArgs + { _indexTupleArgsIndex = idx, + _indexTupleArgsLength = funArity + } + ) + funArity :: Natural + funArity = 2 + +--- A nock function that computes logical and +nockAndFun :: Term Natural +nockAndFun = nockAnd # args # env + where + arg :: Term Natural + arg = nockNilTagged "placeholder argument" + + args :: Term Natural + args = arg # arg + + env :: Term Natural + env = nockNilTagged "environment" + +--- A Nock formula that computes logical and of 3 arguments +nockAnd3 :: Term Natural +nockAnd3 = + OpIf + # (OpAddress # argPath 0) + # ( OpIf + # (OpAddress # argPath 1) + # ( OpIf + # (OpAddress # argPath 2) + # nockTrueLiteral + # nockFalseLiteral + ) + # nockFalseLiteral + ) + # nockFalseLiteral + where + argPath :: Natural -> Path + argPath idx = + closurePath ArgsTuple + ++ indexTuple + ( IndexTupleArgs + { _indexTupleArgsIndex = idx, + _indexTupleArgsLength = funArity + } + ) + funArity :: Natural + funArity = 3 + +--- A nock function that computes logical and for 3 arguments +nockAnd3Fun :: Term Natural +nockAnd3Fun = nockAnd3 # args # env + where + arg :: Term Natural + arg = nockNilTagged "placeholder argument" + + args :: Term Natural + args = arg # arg # arg + + env :: Term Natural + env = nockNilTagged "environment" + +-- | Wrap a function in a formula that calls the function with arguments from the subject. +applyFun :: Term Natural -> Term Natural +applyFun f = + OpPush + # f + # ( OpCall + # codePath + # ( OpReplace + # ( argsPath + # (OpAddress # subjectPath >># (OpAddress # argsPath)) + ) + # (OpAddress # fPath) + ) + ) + where + codePath :: Path + codePath = closurePath FunCode + + argsPath :: Path + argsPath = closurePath ArgsTuple + + -- Path to the function being applied after pushing + fPath :: Path + fPath = [L] + + -- Path to the original subject after pushing + subjectPath :: Path + subjectPath = [R] + anomaCallingConventionTests :: [Test] anomaCallingConventionTests = [True, False] @@ -172,7 +279,24 @@ anomaCallingConventionTests = in run . runReader fx . runReader emptyCompilerCtx $ do p0 <- pathToArg 0 p1 <- pathToArg 1 - return (anomaTestM "stdlib sub args" (sub (OpAddress # p0) (OpAddress # p1)) args (eqNock [nock| 2 |])) + return (anomaTestM "stdlib sub args" (sub (OpAddress # p0) (OpAddress # p1)) args (eqNock [nock| 2 |])), + --- sanity check nockAnd + anomaTestM "(and true false) == false" (return nockAnd) [nockTrueLiteral, nockFalseLiteral] (eqNock [nock| false |]), + anomaTestM "(and true true) == true" (return nockAnd) [nockTrueLiteral, nockTrueLiteral] (eqNock [nock| true |]), + --- test curry with and + anomaTestM "(curry and true) false == false" (applyFun <$> stdlibCurry (OpQuote # nockAndFun) nockTrueLiteral) [nockFalseLiteral] (eqNock [nock| false |]), + anomaTestM "(curry and true) true == true" (applyFun <$> stdlibCurry (OpQuote # nockAndFun) nockTrueLiteral) [nockTrueLiteral] (eqNock [nock| true |]), + anomaTestM "(curry and false) true == false" (applyFun <$> stdlibCurry (OpQuote # nockAndFun) nockFalseLiteral) [nockTrueLiteral] (eqNock [nock| false |]), + anomaTestM "(curry and false) false == false" (applyFun <$> stdlibCurry (OpQuote # nockAndFun) nockFalseLiteral) [nockFalseLiteral] (eqNock [nock| false |]), + --- sanity check nockAnd3 + anomaTestM "(and3 true false true) == false" (return nockAnd3) [nockTrueLiteral, nockFalseLiteral, nockTrueLiteral] (eqNock [nock| false |]), + anomaTestM "(and3 true true false) == false" (return nockAnd3) [nockTrueLiteral, nockTrueLiteral, nockFalseLiteral] (eqNock [nock| false |]), + anomaTestM "(and3 true true true) == true" (return nockAnd3) [nockTrueLiteral, nockTrueLiteral, nockTrueLiteral] (eqNock [nock| true |]), + --- test curry with and3 + anomaTestM "(curry and3 true) false true == false" (applyFun <$> stdlibCurry (OpQuote # nockAnd3Fun) nockTrueLiteral) [nockFalseLiteral, nockTrueLiteral] (eqNock [nock| false |]), + anomaTestM "(curry and3 true) true true == true" (applyFun <$> stdlibCurry (OpQuote # nockAnd3Fun) nockTrueLiteral) [nockTrueLiteral, nockTrueLiteral] (eqNock [nock| true |]), + anomaTestM "(curry and3 false) true true == false" (applyFun <$> stdlibCurry (OpQuote # nockAnd3Fun) nockFalseLiteral) [nockTrueLiteral, nockTrueLiteral] (eqNock [nock| false |]), + anomaTestM "(curry and3 false) false true == false" (applyFun <$> stdlibCurry (OpQuote # nockAnd3Fun) nockFalseLiteral) [nockFalseLiteral, nockTrueLiteral] (eqNock [nock| false |]) ] serializationTests :: [Test] @@ -232,6 +356,10 @@ serializationTests = [nock| [[0 1] [2 3] [4 5] [6 7] [8 9] [10 11] [12 13] [14 15] [16 17] [18 19] [20 21] 0] |] [nock| 308.947.677.754.874.070.959.300.747.182.056.036.528.545.493.781.368.831.595.479.491.505.523.344.414.501 |] +-- Call a formula with specified arguments +nockCall :: Term Natural -> NonEmpty (Term Natural) -> Term Natural +nockCall formula args = (OpReplace # ([R, L] # foldTerms args) # (OpQuote # formula)) >># (OpCall # [L] # (OpAddress # emptyPath)) + juvixCallingConventionTests :: [Test] juvixCallingConventionTests = [True, False]