mirror of
https://github.com/anoma/juvix.git
synced 2024-09-11 16:26:33 +03:00
Add support for anoma-encode builtin (#2766)
This PR adds support for the `anoma-encode` builtin: ``` builtin anoma-encode axiom anomaEncode : {A : Type} -> A -> Nat ``` In the backend this is compiled to a call to the Anoma / nockma stdlib `jam` function. This PR also contains: * An implementation of the `jam` function in Haskell. This is used in the Nockma evaluator. * Unit tests for `jam` * A benchmark for `jam` applied to the Anoma / nockma stdlib. Benchmark results: ``` $ juvixbench -p 'Jam' All Nockma Jam jam stdlib: OK 109 ms ± 6.2 ms ```
This commit is contained in:
parent
6d660f583c
commit
1ab94f5537
11
bench2/Benchmark/Nockma.hs
Normal file
11
bench2/Benchmark/Nockma.hs
Normal file
@ -0,0 +1,11 @@
|
||||
module Benchmark.Nockma where
|
||||
|
||||
import Benchmark.Nockma.Encoding qualified as NockmaEncoding
|
||||
import Test.Tasty.Bench
|
||||
|
||||
bm :: Benchmark
|
||||
bm =
|
||||
bgroup
|
||||
"Nockma"
|
||||
[ NockmaEncoding.bm
|
||||
]
|
21
bench2/Benchmark/Nockma/Encoding.hs
Normal file
21
bench2/Benchmark/Nockma/Encoding.hs
Normal file
@ -0,0 +1,21 @@
|
||||
module Benchmark.Nockma.Encoding where
|
||||
|
||||
import Juvix.Compiler.Nockma.Encoding
|
||||
import Juvix.Compiler.Nockma.Language
|
||||
import Juvix.Compiler.Nockma.Stdlib (stdlib)
|
||||
import Juvix.Prelude.Base
|
||||
import Test.Tasty.Bench
|
||||
|
||||
bm :: Benchmark
|
||||
bm =
|
||||
bgroup
|
||||
"Jam"
|
||||
[bench "jam stdlib" $ nf runJam stdlib]
|
||||
|
||||
runJam :: Term Natural -> Natural
|
||||
runJam =
|
||||
(^. atom)
|
||||
. fromRight (error "jam failed")
|
||||
. run
|
||||
. runError @NockNaturalNaturalError
|
||||
. jam
|
@ -1,11 +1,13 @@
|
||||
module Main where
|
||||
|
||||
import Benchmark.Effect qualified as Effect
|
||||
import Benchmark.Nockma qualified as Nockma
|
||||
import Juvix.Prelude
|
||||
import Test.Tasty.Bench
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
defaultMain
|
||||
[ Effect.bm
|
||||
[ Effect.bm,
|
||||
Nockma.bm
|
||||
]
|
||||
|
@ -49,6 +49,7 @@ dependencies:
|
||||
- ansi-terminal == 1.0.*
|
||||
- base == 4.19.*
|
||||
- base16-bytestring == 1.0.*
|
||||
- bitvec == 1.1.*
|
||||
- blaze-html == 0.9.*
|
||||
- bytestring == 0.12.*
|
||||
- cereal == 0.5.*
|
||||
@ -103,6 +104,7 @@ dependencies:
|
||||
- unordered-containers == 0.2.*
|
||||
- utf8-string == 1.0.*
|
||||
- vector == 0.13.*
|
||||
- vector-builder == 0.3.*
|
||||
- versions == 6.0.*
|
||||
- xdg-basedir == 0.2.*
|
||||
- yaml == 0.11.*
|
||||
|
@ -234,6 +234,7 @@ genCode fi =
|
||||
Tree.OpTrace -> mkInstr Trace
|
||||
Tree.OpFail -> mkInstr Failure
|
||||
Tree.OpAnomaGet -> impossible
|
||||
Tree.OpAnomaEncode -> impossible
|
||||
|
||||
snocReturn :: Bool -> Code' -> Code'
|
||||
snocReturn True code = DL.snoc code (mkInstr Return)
|
||||
|
@ -17,3 +17,16 @@ registerAnomaGet f = do
|
||||
((ftype ==% (u <>--> u <>--> keyT --> valueT)) freeVars)
|
||||
(error "anomaGet must be of type {Value Key : Type} -> Key -> Value")
|
||||
registerBuiltin BuiltinAnomaGet (f ^. axiomName)
|
||||
|
||||
registerAnomaEncode :: (Members '[Builtins, NameIdGen] r) => AxiomDef -> Sem r ()
|
||||
registerAnomaEncode f = do
|
||||
let ftype = f ^. axiomType
|
||||
u = ExpressionUniverse smallUniverseNoLoc
|
||||
l = getLoc f
|
||||
encodeT <- freshVar l "encodeT"
|
||||
nat <- getBuiltinName (getLoc f) BuiltinNat
|
||||
let freeVars = HashSet.fromList [encodeT]
|
||||
unless
|
||||
((ftype ==% (u <>--> encodeT --> nat)) freeVars)
|
||||
(error "anomaEncode must be of type {A : Type} -> A -> Nat")
|
||||
registerBuiltin BuiltinAnomaEncode (f ^. axiomName)
|
||||
|
@ -188,6 +188,7 @@ data BuiltinAxiom
|
||||
| BuiltinIntToString
|
||||
| BuiltinIntPrint
|
||||
| BuiltinAnomaGet
|
||||
| BuiltinAnomaEncode
|
||||
| BuiltinPoseidon
|
||||
| BuiltinEcOp
|
||||
| BuiltinRandomEcPoint
|
||||
@ -223,6 +224,7 @@ instance Pretty BuiltinAxiom where
|
||||
BuiltinIntToString -> Str.intToString
|
||||
BuiltinIntPrint -> Str.intPrint
|
||||
BuiltinAnomaGet -> Str.anomaGet
|
||||
BuiltinAnomaEncode -> Str.anomaEncode
|
||||
BuiltinPoseidon -> Str.cairoPoseidon
|
||||
BuiltinEcOp -> Str.cairoEcOp
|
||||
BuiltinRandomEcPoint -> Str.cairoRandomEcPoint
|
||||
|
@ -191,6 +191,7 @@ geval opts herr ctx env0 = eval' env0
|
||||
OpFail -> failOp
|
||||
OpTrace -> traceOp
|
||||
OpAnomaGet -> anomaGetOp
|
||||
OpAnomaEncode -> anomaEncodeOp
|
||||
OpPoseidonHash -> poseidonHashOp
|
||||
OpEc -> ecOp
|
||||
OpRandomEcPoint -> randomEcPointOp
|
||||
@ -337,6 +338,15 @@ geval opts herr ctx env0 = eval' env0
|
||||
err "unsupported builtin operation: OpAnomaGet"
|
||||
{-# INLINE anomaGetOp #-}
|
||||
|
||||
anomaEncodeOp :: [Node] -> Node
|
||||
anomaEncodeOp = unary $ \arg ->
|
||||
if
|
||||
| opts ^. evalOptionsNormalize || opts ^. evalOptionsNoFailure ->
|
||||
mkBuiltinApp' OpAnomaEncode [eval' env arg]
|
||||
| otherwise ->
|
||||
err "unsupported builtin operation: OpAnomaGet"
|
||||
{-# INLINE anomaEncodeOp #-}
|
||||
|
||||
poseidonHashOp :: [Node] -> Node
|
||||
poseidonHashOp = unary $ \arg ->
|
||||
if
|
||||
|
@ -424,6 +424,7 @@ builtinOpArgTypes = \case
|
||||
OpTrace -> [mkDynamic']
|
||||
OpFail -> [mkTypeString']
|
||||
OpAnomaGet -> [mkDynamic']
|
||||
OpAnomaEncode -> [mkDynamic']
|
||||
OpPoseidonHash -> [mkDynamic']
|
||||
OpEc -> [mkDynamic', mkTypeField', mkDynamic']
|
||||
OpRandomEcPoint -> []
|
||||
|
@ -27,6 +27,7 @@ data BuiltinOp
|
||||
| OpTrace
|
||||
| OpFail
|
||||
| OpAnomaGet
|
||||
| OpAnomaEncode
|
||||
| OpPoseidonHash
|
||||
| OpEc
|
||||
| OpRandomEcPoint
|
||||
@ -71,6 +72,7 @@ builtinOpArgsNum = \case
|
||||
OpTrace -> 1
|
||||
OpFail -> 1
|
||||
OpAnomaGet -> 1
|
||||
OpAnomaEncode -> 1
|
||||
OpPoseidonHash -> 1
|
||||
OpEc -> 3
|
||||
OpRandomEcPoint -> 0
|
||||
@ -108,6 +110,7 @@ builtinIsFoldable = \case
|
||||
OpTrace -> False
|
||||
OpFail -> False
|
||||
OpAnomaGet -> False
|
||||
OpAnomaEncode -> False
|
||||
OpPoseidonHash -> False
|
||||
OpEc -> False
|
||||
OpRandomEcPoint -> False
|
||||
@ -122,4 +125,4 @@ builtinsCairo :: [BuiltinOp]
|
||||
builtinsCairo = [OpPoseidonHash, OpEc, OpRandomEcPoint]
|
||||
|
||||
builtinsAnoma :: [BuiltinOp]
|
||||
builtinsAnoma = [OpAnomaGet]
|
||||
builtinsAnoma = [OpAnomaGet, OpAnomaEncode]
|
||||
|
@ -53,6 +53,7 @@ instance PrettyCode BuiltinOp where
|
||||
OpTrace -> return primTrace
|
||||
OpFail -> return primFail
|
||||
OpAnomaGet -> return primAnomaGet
|
||||
OpAnomaEncode -> return primAnomaEncode
|
||||
OpPoseidonHash -> return primPoseidonHash
|
||||
OpEc -> return primEc
|
||||
OpRandomEcPoint -> return primRandomEcPoint
|
||||
@ -801,6 +802,9 @@ primFail = primitive Str.fail_
|
||||
primAnomaGet :: Doc Ann
|
||||
primAnomaGet = primitive Str.anomaGet
|
||||
|
||||
primAnomaEncode :: Doc Ann
|
||||
primAnomaEncode = primitive Str.anomaEncode
|
||||
|
||||
primPoseidonHash :: Doc Ann
|
||||
primPoseidonHash = primitive Str.cairoPoseidon
|
||||
|
||||
|
@ -67,6 +67,7 @@ computeNodeTypeInfo md = umapL go
|
||||
_ -> error "incorrect trace builtin application"
|
||||
OpFail -> Info.getNodeType node
|
||||
OpAnomaGet -> Info.getNodeType node
|
||||
OpAnomaEncode -> Info.getNodeType node
|
||||
OpPoseidonHash -> case _builtinAppArgs of
|
||||
[arg] -> Info.getNodeType arg
|
||||
_ -> error "incorrect poseidon builtin application"
|
||||
|
@ -580,6 +580,7 @@ goAxiomInductive a = whenJust (a ^. Internal.axiomBuiltin) builtinInductive
|
||||
Internal.BuiltinFieldFromInt -> return ()
|
||||
Internal.BuiltinFieldToNat -> return ()
|
||||
Internal.BuiltinAnomaGet -> return ()
|
||||
Internal.BuiltinAnomaEncode -> return ()
|
||||
Internal.BuiltinPoseidon -> return ()
|
||||
Internal.BuiltinEcOp -> return ()
|
||||
Internal.BuiltinRandomEcPoint -> return ()
|
||||
@ -700,6 +701,12 @@ goAxiomDef a = maybe goAxiomNotBuiltin builtinBody (a ^. Internal.axiomBuiltin)
|
||||
(mkLambda' (mkVar' 0) (mkBuiltinApp' OpAnomaGet [mkVar' 0]))
|
||||
)
|
||||
)
|
||||
Internal.BuiltinAnomaEncode ->
|
||||
registerAxiomDef
|
||||
( mkLambda'
|
||||
mkSmallUniv
|
||||
(mkLambda' (mkVar' 0) (mkBuiltinApp' OpAnomaEncode [mkVar' 0]))
|
||||
)
|
||||
Internal.BuiltinPoseidon -> do
|
||||
psName <- getPoseidonStateName
|
||||
psSym <- getPoseidonStateSymbol
|
||||
@ -1098,6 +1105,7 @@ goApplication a = do
|
||||
_ -> app
|
||||
Just Internal.BuiltinFieldToNat -> app
|
||||
Just Internal.BuiltinAnomaGet -> app
|
||||
Just Internal.BuiltinAnomaEncode -> app
|
||||
Just Internal.BuiltinPoseidon -> app
|
||||
Just Internal.BuiltinEcOp -> app
|
||||
Just Internal.BuiltinRandomEcPoint -> app
|
||||
|
@ -96,6 +96,7 @@ fromCore fsize tab =
|
||||
BuiltinIntToString -> False
|
||||
BuiltinIntPrint -> False
|
||||
BuiltinAnomaGet -> False
|
||||
BuiltinAnomaEncode -> False
|
||||
BuiltinPoseidon -> False
|
||||
BuiltinEcOp -> False
|
||||
BuiltinRandomEcPoint -> False
|
||||
|
@ -571,6 +571,7 @@ registerBuiltinAxiom d = \case
|
||||
BuiltinIntToString -> registerIntToString d
|
||||
BuiltinIntPrint -> registerIntPrint d
|
||||
BuiltinAnomaGet -> registerAnomaGet d
|
||||
BuiltinAnomaEncode -> registerAnomaEncode d
|
||||
BuiltinPoseidon -> registerPoseidon d
|
||||
BuiltinEcOp -> registerEcOp d
|
||||
BuiltinRandomEcPoint -> registerRandomEcPoint d
|
||||
|
6
src/Juvix/Compiler/Nockma/Encoding.hs
Normal file
6
src/Juvix/Compiler/Nockma/Encoding.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Juvix.Compiler.Nockma.Encoding
|
||||
( module Juvix.Compiler.Nockma.Encoding.Jam,
|
||||
)
|
||||
where
|
||||
|
||||
import Juvix.Compiler.Nockma.Encoding.Jam
|
48
src/Juvix/Compiler/Nockma/Encoding/Base.hs
Normal file
48
src/Juvix/Compiler/Nockma/Encoding/Base.hs
Normal file
@ -0,0 +1,48 @@
|
||||
module Juvix.Compiler.Nockma.Encoding.Base where
|
||||
|
||||
import Data.Bit as Bit
|
||||
import Data.Bits
|
||||
import Data.Vector.Unboxed qualified as U
|
||||
import Juvix.Compiler.Nockma.Encoding.Effect.BitWriter
|
||||
import Juvix.Prelude.Base
|
||||
|
||||
-- | Binary encode an integer to a vector of bits, ordered from least to most significant bits.
|
||||
-- NB: 0 is encoded as the empty bit vector is specified by the Hoon serialization spec
|
||||
writeIntegral :: forall a r. (Integral a, Member BitWriter r) => a -> Sem r ()
|
||||
writeIntegral x
|
||||
| x < 0 = error "integerToVectorBits: negative integers are not supported in this implementation"
|
||||
| otherwise = unfoldBits (fromIntegral x)
|
||||
where
|
||||
unfoldBits :: Integer -> Sem r ()
|
||||
unfoldBits n
|
||||
| n == 0 = return ()
|
||||
| otherwise = writeBit (Bit (testBit n 0)) <> unfoldBits (n `shiftR` 1)
|
||||
|
||||
integerToVectorBits :: (Integral a) => a -> Bit.Vector Bit
|
||||
integerToVectorBits = run . execBitWriter . writeIntegral
|
||||
|
||||
-- | Computes the number of bits required to store the argument in binary
|
||||
-- NB: 0 is encoded to the empty bit vector (as specified by the Hoon serialization spec), so 0 has bit length 0.
|
||||
bitLength :: forall a. (Integral a) => a -> Int
|
||||
bitLength = \case
|
||||
0 -> 0
|
||||
n -> go (fromIntegral n) 0
|
||||
where
|
||||
go :: Integer -> Int -> Int
|
||||
go 0 acc = acc
|
||||
go x acc = go (x `shiftR` 1) (acc + 1)
|
||||
|
||||
-- | Decode a vector of bits (ordered from least to most significant bits) to an integer
|
||||
vectorBitsToInteger :: Bit.Vector Bit -> Integer
|
||||
vectorBitsToInteger = U.ifoldl' go 0
|
||||
where
|
||||
go :: Integer -> Int -> Bit -> Integer
|
||||
go acc idx (Bit b)
|
||||
| b = setBit acc idx
|
||||
| otherwise = acc
|
||||
|
||||
-- | Transform a Natural to an Int, computes Nothing if the Natural does not fit in an Int
|
||||
safeNaturalToInt :: Natural -> Maybe Int
|
||||
safeNaturalToInt n
|
||||
| n > fromIntegral (maxBound :: Int) = Nothing
|
||||
| otherwise = Just (fromIntegral n)
|
51
src/Juvix/Compiler/Nockma/Encoding/Effect/BitWriter.hs
Normal file
51
src/Juvix/Compiler/Nockma/Encoding/Effect/BitWriter.hs
Normal file
@ -0,0 +1,51 @@
|
||||
module Juvix.Compiler.Nockma.Encoding.Effect.BitWriter where
|
||||
|
||||
import Data.Bit as Bit
|
||||
import Juvix.Prelude.Base
|
||||
import VectorBuilder.Builder as Builder
|
||||
import VectorBuilder.Vector
|
||||
|
||||
data BitWriter :: Effect where
|
||||
WriteBit :: Bit -> BitWriter m ()
|
||||
GetCurrentPosition :: BitWriter m Int
|
||||
|
||||
makeSem ''BitWriter
|
||||
|
||||
writeOne :: (Member BitWriter r) => Sem r ()
|
||||
writeOne = writeBit (Bit True)
|
||||
|
||||
writeZero :: (Member BitWriter r) => Sem r ()
|
||||
writeZero = writeBit (Bit False)
|
||||
|
||||
newtype WriterState = WriterState
|
||||
{ _writerStateBuilder :: Builder Bit
|
||||
}
|
||||
|
||||
makeLenses ''WriterState
|
||||
|
||||
initWriterState :: WriterState
|
||||
initWriterState = WriterState {_writerStateBuilder = mempty}
|
||||
|
||||
runBitWriter :: forall a r. Sem (BitWriter ': r) a -> Sem r (Bit.Vector Bit, a)
|
||||
runBitWriter sem = do
|
||||
(s, res) <- runState initWriterState (re sem)
|
||||
return (build (s ^. writerStateBuilder), res)
|
||||
|
||||
execBitWriter :: forall a r. Sem (BitWriter ': r) a -> Sem r (Bit.Vector Bit)
|
||||
execBitWriter sem = do
|
||||
s <- execState initWriterState (re sem)
|
||||
return (build (s ^. writerStateBuilder))
|
||||
|
||||
re :: Sem (BitWriter ': r) a -> Sem (State WriterState ': r) a
|
||||
re = interpretTop $ \case
|
||||
WriteBit b -> writeBit' b
|
||||
GetCurrentPosition -> getCurrentPosition'
|
||||
|
||||
writeBit' :: (Member (State WriterState) r) => Bit -> Sem r ()
|
||||
writeBit' b = modify appendBit
|
||||
where
|
||||
appendBit :: WriterState -> WriterState
|
||||
appendBit = over writerStateBuilder (<> Builder.singleton b)
|
||||
|
||||
getCurrentPosition' :: (Member (State WriterState) r) => Sem r Int
|
||||
getCurrentPosition' = Builder.size <$> gets (^. writerStateBuilder)
|
116
src/Juvix/Compiler/Nockma/Encoding/Jam.hs
Normal file
116
src/Juvix/Compiler/Nockma/Encoding/Jam.hs
Normal file
@ -0,0 +1,116 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
|
||||
-- |
|
||||
-- An implmentation of the [Hoon jam](https://developers.urbit.org/reference/hoon/stdlib/2p#jam) function.
|
||||
--
|
||||
-- This is based on Urbit's [Rust implementation](https://github.com/urbit/noun/blob/4b22042623d7f3112b40c0f69138dc798e9bc56e/src/noun.rs#L175).
|
||||
module Juvix.Compiler.Nockma.Encoding.Jam where
|
||||
|
||||
import Data.Bit as Bit
|
||||
import Data.Bits
|
||||
import Juvix.Compiler.Nockma.Encoding.Base
|
||||
import Juvix.Compiler.Nockma.Encoding.Effect.BitWriter
|
||||
import Juvix.Compiler.Nockma.Language
|
||||
import Juvix.Prelude.Base
|
||||
|
||||
newtype JamState a = JamState
|
||||
{ _jamStateCache :: HashMap (Term a) Int
|
||||
}
|
||||
|
||||
initJamState :: forall a. (Hashable a) => JamState a
|
||||
initJamState =
|
||||
JamState
|
||||
{ _jamStateCache = mempty
|
||||
}
|
||||
|
||||
makeLenses ''JamState
|
||||
|
||||
-- | Write the binary encoding of argument interpreted as a length to the output
|
||||
writeLength :: forall r. (Member BitWriter r) => Int -> Sem r ()
|
||||
writeLength len = do
|
||||
let lenOfLen = finiteBitSize len - countLeadingZeros len
|
||||
replicateM_ lenOfLen writeZero
|
||||
writeOne
|
||||
unless (lenOfLen == 0) (go len)
|
||||
where
|
||||
go :: Int -> Sem r ()
|
||||
-- Exclude the most significant bit of the length
|
||||
go l = unless (l == 1) $ do
|
||||
writeBit (Bit (testBit l 0))
|
||||
go (l `shiftR` 1)
|
||||
|
||||
-- | Write the atom tag 0b0 to the output
|
||||
writeAtomTag :: (Member BitWriter r) => Sem r ()
|
||||
writeAtomTag = writeZero
|
||||
|
||||
-- | Write the cell tag 0b01 to the output
|
||||
writeCellTag :: (Member BitWriter r) => Sem r ()
|
||||
writeCellTag = writeOne >> writeZero
|
||||
|
||||
-- | Write the backref tag 0b11 to the output
|
||||
writeBackrefTag :: (Member BitWriter r) => Sem r ()
|
||||
writeBackrefTag = writeOne >> writeOne
|
||||
|
||||
-- | Encode and write an atom to the output
|
||||
writeAtom :: (Integral a, Member BitWriter r) => Atom a -> Sem r ()
|
||||
writeAtom a = do
|
||||
writeAtomTag
|
||||
writeLength (bitLength (a ^. atom))
|
||||
writeIntegral (a ^. atom)
|
||||
|
||||
-- | Encode and write a cell to the output
|
||||
writeCell :: (Hashable a, Integral a, Members '[BitWriter, State (JamState a)] r) => Cell a -> Sem r ()
|
||||
writeCell c = do
|
||||
writeCellTag
|
||||
jamSem (c ^. cellLeft)
|
||||
jamSem (c ^. cellRight)
|
||||
|
||||
-- | Encode and write a backref to the output
|
||||
writeBackref :: (Member BitWriter r) => Int -> Sem r ()
|
||||
writeBackref idx = do
|
||||
writeBackrefTag
|
||||
writeLength (bitLength idx)
|
||||
writeIntegral idx
|
||||
|
||||
-- | Cache the position of the encoding of the passed term
|
||||
cacheTerm :: forall r a. (Hashable a, Members '[BitWriter, State (JamState a)] r) => Term a -> Sem r ()
|
||||
cacheTerm t = do
|
||||
pos <- getCurrentPosition
|
||||
modify (set (jamStateCache . at t) (Just pos))
|
||||
|
||||
-- | Lookup the encoding of a term from the cache
|
||||
lookupCache :: forall a r. (Hashable a, Member (State (JamState a)) r) => Term a -> Sem r (Maybe Int)
|
||||
lookupCache t = gets @(JamState a) (^. jamStateCache . at t)
|
||||
|
||||
-- | Encode and write a Nock term to the output
|
||||
jamSem :: forall a r. (Integral a, Hashable a, Members '[BitWriter, State (JamState a)] r) => Term a -> Sem r ()
|
||||
jamSem t = do
|
||||
ct <- lookupCache @a t
|
||||
case ct of
|
||||
Just idx -> case t of
|
||||
TermAtom a -> do
|
||||
let idxBitLength = finiteBitSize idx - countLeadingZeros idx
|
||||
atomBitLength = bitLength (a ^. atom)
|
||||
if
|
||||
| atomBitLength <= idxBitLength -> writeAtom a
|
||||
| otherwise -> writeBackref idx
|
||||
TermCell {} -> writeBackref idx
|
||||
Nothing -> do
|
||||
cacheTerm t
|
||||
case t of
|
||||
TermAtom a -> writeAtom a
|
||||
TermCell c -> writeCell c
|
||||
|
||||
jamToBits :: forall a. (Integral a, Hashable a) => Term a -> Bit.Vector Bit
|
||||
jamToBits =
|
||||
run
|
||||
. execBitWriter
|
||||
. evalState (initJamState @a)
|
||||
. jamSem
|
||||
|
||||
-- | jam encode a Nock term to an atom
|
||||
jam :: forall a r. (Integral a, Hashable a, NockNatural a, Member (Error (ErrNockNatural a)) r) => Term a -> Sem r (Atom a)
|
||||
jam t = do
|
||||
let i = fromInteger . vectorBitsToInteger . jamToBits $ t
|
||||
ai <- fromNatural i
|
||||
return (Atom ai emptyAtomInfo)
|
@ -7,6 +7,7 @@ module Juvix.Compiler.Nockma.Evaluator
|
||||
where
|
||||
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Juvix.Compiler.Nockma.Encoding qualified as Encoding
|
||||
import Juvix.Compiler.Nockma.Evaluator.Error
|
||||
import Juvix.Compiler.Nockma.Evaluator.Options
|
||||
import Juvix.Compiler.Nockma.Evaluator.Storage
|
||||
@ -228,6 +229,7 @@ evalProfile inistack initerm =
|
||||
StdlibLt -> binCmp (<)
|
||||
StdlibLe -> binCmp (<=)
|
||||
StdlibPow2 -> unaArith (2 ^)
|
||||
StdlibEncode -> TermAtom <$> Encoding.jam args'
|
||||
|
||||
goAutoConsCell :: AutoConsCell a -> Sem r (Term a)
|
||||
goAutoConsCell c = do
|
||||
|
@ -254,6 +254,7 @@ serializeOp = \case
|
||||
class (NockmaEq a) => NockNatural a where
|
||||
type ErrNockNatural a :: Type
|
||||
nockNatural :: (Member (Error (ErrNockNatural a)) r) => Atom a -> Sem r Natural
|
||||
fromNatural :: (Member (Error (ErrNockNatural a)) r) => Natural -> Sem r a
|
||||
serializeNockOp :: NockOp -> a
|
||||
serializePath :: Path -> a
|
||||
|
||||
@ -309,6 +310,7 @@ nockBoolLiteral b
|
||||
instance NockNatural Natural where
|
||||
type ErrNockNatural Natural = NockNaturalNaturalError
|
||||
nockNatural a = return (a ^. atom)
|
||||
fromNatural = return
|
||||
nockTrue = Atom 0 (atomHintInfo AtomHintBool)
|
||||
nockFalse = Atom 1 (atomHintInfo AtomHintBool)
|
||||
nockNil = Atom 0 (atomHintInfo AtomHintNil)
|
||||
|
@ -20,3 +20,4 @@ stdlibPath = \case
|
||||
StdlibLe -> [nock| [9 84 0 31] |]
|
||||
StdlibLt -> [nock| [9 343 0 31] |]
|
||||
StdlibPow2 -> [nock| [9 4 0 3] |]
|
||||
StdlibEncode -> [nock| [9 22 0 1] |]
|
||||
|
@ -14,6 +14,7 @@ instance Pretty StdlibFunction where
|
||||
StdlibLt -> "<"
|
||||
StdlibLe -> "<="
|
||||
StdlibPow2 -> "pow2"
|
||||
StdlibEncode -> "encode"
|
||||
|
||||
data StdlibFunction
|
||||
= StdlibDec
|
||||
@ -25,6 +26,7 @@ data StdlibFunction
|
||||
| StdlibLt
|
||||
| StdlibLe
|
||||
| StdlibPow2
|
||||
| StdlibEncode
|
||||
deriving stock (Show, Lift, Eq, Bounded, Enum, Generic)
|
||||
|
||||
instance Hashable StdlibFunction
|
||||
|
@ -426,6 +426,7 @@ compile = \case
|
||||
Tree.OpFail -> return crash
|
||||
Tree.OpTrace -> goTrace arg
|
||||
Tree.OpAnomaGet -> goAnomaGet arg
|
||||
Tree.OpAnomaEncode -> goAnomaEncode arg
|
||||
|
||||
goPrimUnop :: Tree.UnaryOp -> Term Natural -> Term Natural
|
||||
goPrimUnop op arg = case op of
|
||||
@ -442,6 +443,9 @@ compile = \case
|
||||
let arg = remakeList [getFieldInSubject AnomaGetOrder, key]
|
||||
return (OpScry # (OpQuote # nockNilTagged "OpScry-typehint") # arg)
|
||||
|
||||
goAnomaEncode :: Term Natural -> Sem r (Term Natural)
|
||||
goAnomaEncode arg = return (callStdlib StdlibEncode [arg])
|
||||
|
||||
goTrace :: Term Natural -> Sem r (Term Natural)
|
||||
goTrace arg = do
|
||||
enabled <- asks (^. compilerOptions . compilerOptionsEnableTrace)
|
||||
|
@ -75,6 +75,7 @@ hEval hout tab = eval' [] mempty
|
||||
OpTrace -> goTrace v
|
||||
OpFail -> goFail v
|
||||
OpAnomaGet -> evalError "Unsupported op: OpAnomaGet"
|
||||
OpAnomaEncode -> evalError "Unsupported op: OpAnomaEncode"
|
||||
|
||||
goFail :: Value -> Value
|
||||
goFail v = evalError ("failure: " <> printValue tab v)
|
||||
|
@ -70,6 +70,7 @@ eval tab = runReader emptyEvalCtx . eval'
|
||||
OpTrace -> goTrace v
|
||||
OpFail -> goFail v
|
||||
OpAnomaGet -> evalError "Unsupported op: OpAnomaGet"
|
||||
OpAnomaEncode -> evalError "Unsupported op: OpAnomaEncode"
|
||||
|
||||
goFail :: Value -> Sem r' Value
|
||||
goFail v = evalError ("failure: " <> printValue tab v)
|
||||
|
@ -69,6 +69,8 @@ data UnaryOpcode
|
||||
OpFail
|
||||
| -- | Get a value by key from Anoma storage
|
||||
OpAnomaGet
|
||||
| -- | Encode a value to an Anoma atom
|
||||
OpAnomaEncode
|
||||
|
||||
data NodeBinop = NodeBinop
|
||||
{ _nodeBinopInfo :: NodeInfo,
|
||||
|
@ -246,6 +246,7 @@ instance PrettyCode UnaryOpcode where
|
||||
OpTrace -> return $ primitive Str.instrTrace
|
||||
OpFail -> return $ primitive Str.instrFailure
|
||||
OpAnomaGet -> return $ primitive Str.anomaGet
|
||||
OpAnomaEncode -> return $ primitive Str.anomaEncode
|
||||
|
||||
instance PrettyCode NodeUnop where
|
||||
ppCode NodeUnop {..} = do
|
||||
|
@ -11,13 +11,17 @@ checkNoAnoma = walkT checkNode
|
||||
checkNode :: Symbol -> Node -> Sem r ()
|
||||
checkNode _ = \case
|
||||
Unop NodeUnop {..} -> case _nodeUnopOpcode of
|
||||
OpAnomaGet ->
|
||||
throw
|
||||
TreeError
|
||||
{ _treeErrorMsg = "OpAnomaGet is unsupported",
|
||||
_treeErrorLoc = _nodeUnopInfo ^. nodeInfoLocation
|
||||
}
|
||||
OpAnomaGet -> unsupportedErr "OpAnomaGet"
|
||||
OpAnomaEncode -> unsupportedErr "OpAnomaEncode"
|
||||
OpFail -> return ()
|
||||
OpTrace -> return ()
|
||||
PrimUnop {} -> return ()
|
||||
where
|
||||
unsupportedErr :: Text -> Sem r ()
|
||||
unsupportedErr opName =
|
||||
throw
|
||||
TreeError
|
||||
{ _treeErrorMsg = opName <> " is unsupported",
|
||||
_treeErrorLoc = _nodeUnopInfo ^. nodeInfoLocation
|
||||
}
|
||||
_ -> return ()
|
||||
|
@ -66,6 +66,7 @@ inferType tab funInfo = goInfer mempty
|
||||
OpTrace -> goInfer bl _nodeUnopArg
|
||||
OpFail -> checkUnop TyDynamic TyDynamic
|
||||
OpAnomaGet -> checkUnop TyDynamic TyDynamic
|
||||
OpAnomaEncode -> checkUnop TyDynamic TyDynamic
|
||||
where
|
||||
loc = _nodeUnopInfo ^. nodeInfoLocation
|
||||
|
||||
|
@ -296,6 +296,7 @@ genCode infoTable fi =
|
||||
Core.OpTrace -> OpTrace
|
||||
Core.OpFail -> OpFail
|
||||
Core.OpAnomaGet -> OpAnomaGet
|
||||
Core.OpAnomaEncode -> OpAnomaEncode
|
||||
_ -> impossible
|
||||
|
||||
genCairoOp :: Core.BuiltinOp -> CairoOp
|
||||
|
@ -329,6 +329,9 @@ intPrint = "int-print"
|
||||
anomaGet :: (IsString s) => s
|
||||
anomaGet = "anoma-get"
|
||||
|
||||
anomaEncode :: (IsString s) => s
|
||||
anomaEncode = "anoma-encode"
|
||||
|
||||
builtinSeq :: (IsString s) => s
|
||||
builtinSeq = "seq"
|
||||
|
||||
|
@ -543,5 +543,11 @@ allTests =
|
||||
$(mkRelDir ".")
|
||||
$(mkRelFile "test074.juvix")
|
||||
[OpQuote # k1, OpQuote # k2]
|
||||
$ checkOutput [v1, v2]
|
||||
$ checkOutput [v1, v2],
|
||||
mkAnomaCallTest
|
||||
"Test075: Anoma encode"
|
||||
$(mkRelDir ".")
|
||||
$(mkRelFile "test075.juvix")
|
||||
[]
|
||||
$ checkNatOutput [2, 84081, 4657, 12]
|
||||
]
|
||||
|
@ -51,7 +51,8 @@ allTests =
|
||||
"Nockma eval positive"
|
||||
[ testGroup "Unit" (map mkNockmaTest unitTests),
|
||||
testGroup "Juvix calling convention" (map mkNockmaTest juvixCallingConventionTests),
|
||||
testGroup "Anoma calling convention" (map mkNockmaTest anomaCallingConventionTests)
|
||||
testGroup "Anoma calling convention" (map mkNockmaTest anomaCallingConventionTests),
|
||||
testGroup "Anoma serialization tests" (map mkNockmaTest serializationTests)
|
||||
]
|
||||
where
|
||||
mkNockmaTest :: Test -> TestTree
|
||||
@ -89,6 +90,12 @@ compilerTest :: Text -> Term Natural -> Check () -> Bool -> Test
|
||||
compilerTest n mainFun _testCheck _evalInterceptStdlibCalls =
|
||||
anomaTest n mainFun [] _testCheck _evalInterceptStdlibCalls
|
||||
|
||||
serializationTest :: Text -> Term Natural -> Term Natural -> Test
|
||||
serializationTest n jamTerm cueTerm =
|
||||
let _testCheck :: Check () = eqNock cueTerm
|
||||
mainFun :: Term Natural = callStdlib StdlibEncode [OpQuote # jamTerm]
|
||||
in anomaTest n mainFun [] _testCheck True
|
||||
|
||||
withAssertErrKeyNotInStorage :: Test -> Test
|
||||
withAssertErrKeyNotInStorage Test {..} =
|
||||
let _testAssertEvalError :: Maybe (NockEvalError Natural -> Assertion) = Just f
|
||||
@ -145,6 +152,27 @@ anomaCallingConventionTests =
|
||||
return (anomaTest "stdlib sub args" (sub (OpAddress # p0) (OpAddress # p1)) args (eqNock [nock| 2 |]))
|
||||
]
|
||||
|
||||
serializationTests :: [Test]
|
||||
serializationTests =
|
||||
[ serializationTest "jam 0" [nock| 0 |] [nock| 2 |],
|
||||
serializationTest "jam 1" [nock| 1 |] [nock| 12 |],
|
||||
serializationTest "jam 2" [nock| 2 |] [nock| 72 |],
|
||||
serializationTest "jam 19" [nock| 19 |] [nock| 2480 |],
|
||||
serializationTest "jam 581.949.002" [nock| 581.949.002 |] [nock| 1.191.831.557.952 |],
|
||||
serializationTest "jam [1 19]" [nock| [0 19] |] [nock| 39689 |],
|
||||
serializationTest "jam [1 1]" [nock| [1 1] |] [nock| 817 |],
|
||||
serializationTest "jam [10.000 10.000]" [nock| [10.000 10.000] |] [nock| 4.952.983.169 |],
|
||||
serializationTest "jam [999.999.999 999.999.999]" [nock| [999.999.999 999.999.999] |] [nock| 1.301.217.674.263.809 |],
|
||||
serializationTest "jam [222 444 888]" [nock| [222 444 888] |] [nock| 250.038.217.192.960.129 |],
|
||||
serializationTest "jam [[107 110] [107 110]]" [nock| [[107 110] [107 110]] |] [nock| 635.080.761.093 |],
|
||||
serializationTest "jam [0 1 2 3 4 5 6 7 8 9 10]" [nock| [0 1 2 3 4 5 6 7 8 9 10] |] [nock| 25.681.224.503.728.653.597.984.370.231.065 |],
|
||||
serializationTest "jam [99 100 101 102 103 104 0]" [nock| [99 100 101 102 103 104 0] |] [nock| 223.372.995.869.285.333.705.242.560.449 |],
|
||||
serializationTest "jam [[222 444 888] [222 444 888]]" [nock| [[222 444 888] [222 444 888]] |] [nock| 170.479.614.045.978.345.989 |],
|
||||
serializationTest "jam [[0 1] [1 2] [2 3] [3 4] 0]" [nock| [[0 1] [1 2] [2 3] [3 4] 0] |] [nock| 11.976.248.475.217.237.797 |],
|
||||
serializationTest "jam [[0 1] [1 2] [2 3] [3 4] [4 5] [5 6] [6 7] [7 8] [8 9] 0]" [nock| [[0 1] [1 2] [2 3] [3 4] [4 5] [5 6] [6 7] [7 8] [8 9] 0] |] [nock| 7.694.087.033.387.855.647.747.387.855.514.468.399.947.749.137.782.565 |],
|
||||
serializationTest "jam [[0 1] [2 3] [4 5] [6 7] [8 9] [10 11] [12 13] [14 15] [16 17] [18 19] [20 21] 0] " [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 |]
|
||||
]
|
||||
|
||||
juvixCallingConventionTests :: [Test]
|
||||
juvixCallingConventionTests =
|
||||
[True, False]
|
||||
|
17
tests/Anoma/Compilation/positive/test075.juvix
Normal file
17
tests/Anoma/Compilation/positive/test075.juvix
Normal file
@ -0,0 +1,17 @@
|
||||
module test075;
|
||||
|
||||
import Stdlib.Prelude open;
|
||||
import Stdlib.Debug.Trace open;
|
||||
|
||||
builtin anoma-encode
|
||||
axiom anomaEncode : {A : Type} -> A -> Nat;
|
||||
|
||||
main : Nat :=
|
||||
-- jam 0 == 2
|
||||
trace (anomaEncode 0)
|
||||
-- jam [1 2 0] == 84081
|
||||
>>> trace (anomaEncode [1;2])
|
||||
-- jam [1 2] == 4657
|
||||
>>> trace (anomaEncode (1 , 2))
|
||||
-- jam 1 == 12
|
||||
>>> anomaEncode false;
|
Loading…
Reference in New Issue
Block a user