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

The assert builtin (#3014)

Browse Source 
* Requires #3015
This commit is contained in:
Łukasz Czajka 2024-09-12 09:29:57 +02:00 committed by GitHub
parent 8e204634b8
commit 26ea94b977
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
62 changed files with 309 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
examples/milestone/Bank/Bank.juvix
View File

@ -70,10 +70,6 @@ calculateInterest : Nat -> Nat -> Nat -> Nat
incrAmount (a : Nat) : Nat := div (a * rate) 10000;
in iterate (min 100 periods) incrAmount amount;
--- Asserts some ;Bool; condition.
assert : {A : Type} -> Bool -> A -> A
| c a := ite c a (failwith "assertion failed");
--- Returns a new ;Token;. Arguments are:
---
--- `owner`: The address of the account to issue the token to
@ -82,7 +78,7 @@ assert : {A : Type} -> Bool -> A -> A
---
--- `caller`: Who is creating the transaction. It must be the bank.
issue : Address -> Address -> Nat -> Token
| caller owner amount := assert (caller == bankAddress) (mkToken owner 0 amount);
| caller owner amount := assert (caller == bankAddress) >-> mkToken owner 0 amount;
--- Deposits some amount of money into the bank.
deposit (bal : Balances) (token : Token) (amount : Nat) : Token :=
@ -102,11 +98,10 @@ withdraw
(rate : Nat)
(periods : Nat)
: Token :=
assert
(caller == bankAddress)
(let
hash : Field := hashAddress recipient;
total : Nat := calculateInterest amount rate periods;
token : Token := mkToken recipient 0 total;
bal' : Balances := decrement hash amount bal;
in runOnChain (commitBalances bal') token);
assert (caller == bankAddress)
>-> let
hash : Field := hashAddress recipient;
total : Nat := calculateInterest amount rate periods;
token : Token := mkToken recipient 0 total;
bal' : Balances := decrement hash amount bal;
in runOnChain (commitBalances bal') token;

2
juvix-stdlib

@ -1 +1 @@
Subproject commit 615a02c8107076ca9661c5234d41792be91a5104
Subproject commit 6010ad32f80498432b9a14752a0b7b50e9b36763

1
runtime/c/src/juvix/api.h
View File

@ -104,6 +104,7 @@ closure_label:
#define JUVIX_INT_TO_UINT8(var0, var1) \
(var0 = make_smallint((word_t)((uint8_t)(get_unboxed_int(var1) & 0xFF))))
#define JUVIX_ASSERT(val) (assert(is_true(val)))
#define JUVIX_TRACE(val) (io_trace(val))
#define JUVIX_DUMP (stacktrace_dump())
#define JUVIX_FAILURE(val) \

4
src/Juvix/Compiler/Asm/Extra/Recursors.hs
View File

@ -92,6 +92,8 @@ recurse' sig = go True
throw $
AsmError loc "popping empty value stack"
return (popValueStack 1 mem)
Assert ->
return mem
Trace ->
return mem
Dump ->
@ -412,6 +414,8 @@ recurseS' sig = go True
return (stackInfoPushValueStack 1 si)
Pop -> do
return (stackInfoPopValueStack 1 si)
Assert ->
return si
Trace ->
return si
Dump ->

5
src/Juvix/Compiler/Asm/Interpreter.hs
View File

@ -82,6 +82,11 @@ runCodeR infoTable funInfo = goCode (funInfo ^. functionCode) >> popLastValueSta
goCode cont
Pop ->
popValueStack >> goCode cont
Assert -> do
v <- topValueStack
unless (v == ValBool True) $
runtimeError "assertion failed"
goCode cont
Trace -> do
v <- topValueStack
logMessage (printValue infoTable v)

3
src/Juvix/Compiler/Asm/Language.hs
View File

@ -49,6 +49,9 @@ data Instruction
Push Value
| -- | Pop the stack. JVA opcode: 'pop'.
Pop
| -- | Assert a boolean on top of the stack. Does not pop the stack. JVA
-- opcode: 'assert'.
Assert
| -- | Print a debug log of the object on top of the stack. Does not pop the
-- stack. JVA opcode: 'trace'.
Trace

1
src/Juvix/Compiler/Asm/Pretty/Base.hs
View File

@ -98,6 +98,7 @@ instance PrettyCode Instruction where
Cairo op -> Tree.ppCode op
Push val -> (primitive Str.instrPush <+>) <$> ppCode val
Pop -> return $ primitive Str.instrPop
Assert -> return $ primitive Str.instrAssert
Trace -> return $ primitive Str.instrTrace
Dump -> return $ primitive Str.instrDump
Failure -> return $ primitive Str.instrFailure

2
src/Juvix/Compiler/Asm/Translation/FromSource.hs
View File

@ -91,6 +91,8 @@ command = do
mkInstr' loc . Push <$> value
"pop" ->
return $ mkInstr' loc Pop
"assert" ->
return $ mkInstr' loc Assert
"trace" ->
return $ mkInstr' loc Trace
"dump" ->

1
src/Juvix/Compiler/Asm/Translation/FromTree.hs
View File

@ -233,6 +233,7 @@ genCode fi =
genUnOp :: Tree.UnaryOpcode -> Command
genUnOp op = case op of
Tree.PrimUnop op' -> mkUnop op'
Tree.OpAssert -> mkInstr Assert
Tree.OpTrace -> mkInstr Trace
Tree.OpFail -> mkInstr Failure

2
src/Juvix/Compiler/Backend/C/Translation/FromReg.hs
View File

@ -227,6 +227,8 @@ fromRegInstr bNoStack info = \case
unsupported "Cairo builtin"
Reg.Assign Reg.InstrAssign {..} ->
return $ stmtsAssign (fromVarRef _instrAssignResult) (fromValue _instrAssignValue)
Reg.Assert Reg.InstrAssert {..} ->
return [StatementExpr $ macroCall "JUVIX_ASSERT" [fromValue _instrAssertValue]]
Reg.Trace Reg.InstrTrace {..} ->
return [StatementExpr $ macroCall "JUVIX_TRACE" [fromValue _instrTraceValue]]
Reg.Dump ->

9
src/Juvix/Compiler/Backend/Cairo/Translation/FromCasm.hs
View File

@ -43,6 +43,7 @@ fromCasm instrs0 =
Casm.Return -> goReturn
Casm.Alloc x -> goAlloc x
Casm.Hint x -> goHint x
Casm.Assert x -> goAssert x
Casm.Trace {} -> []
Casm.Label {} -> []
Casm.Nop -> []
@ -230,6 +231,14 @@ fromCasm instrs0 =
. set instrApUpdate ApUpdateAdd
$ defaultInstruction
goAssert :: Casm.InstrAssert -> [Element]
goAssert Casm.InstrAssert {..} =
toElems
. updateOps False (Casm.Val (Casm.Imm 0))
. updateDst _instrAssertValue
. set instrOpcode AssertEq
$ defaultInstruction
goHint :: Casm.Hint -> [Element]
goHint = \case
Casm.HintInput var -> [ElementHint (Hint ("Input(" <> var <> ")"))]

2
src/Juvix/Compiler/Backend/Rust/Translation/FromReg.hs
View File

@ -130,6 +130,8 @@ fromRegInstr info = \case
unsupported "Cairo builtin"
Reg.Assign Reg.InstrAssign {..} ->
stmtsAssign (mkVarRef _instrAssignResult) (fromValue _instrAssignValue)
Reg.Assert {} ->
unsupported "assert"
Reg.Trace {} ->
unsupported "trace"
Reg.Dump ->

24
src/Juvix/Compiler/Builtins/Assert.hs Normal file
View File

@ -0,0 +1,24 @@
module Juvix.Compiler.Builtins.Assert where
import Juvix.Compiler.Internal.Builtins
import Juvix.Compiler.Internal.Extra
import Juvix.Prelude
checkAssert :: (Members '[Reader BuiltinsTable, Error ScoperError, NameIdGen] r) => FunctionDef -> Sem r ()
checkAssert f = do
bool_ <- getBuiltinNameScoper (getLoc f) BuiltinBool
let assert_ = f ^. funDefName
l = getLoc f
varx <- freshVar l "x"
let x = toExpression varx
assertClauses :: [(Expression, Expression)]
assertClauses = [(assert_ @@ x, x)]
checkBuiltinFunctionInfo
FunInfo
{ _funInfoDef = f,
_funInfoBuiltin = BuiltinAssert,
_funInfoSignature = bool_ --> bool_,
_funInfoClauses = assertClauses,
_funInfoFreeVars = [varx],
_funInfoFreeTypeVars = []
}

8
src/Juvix/Compiler/Casm/Interpreter.hs
View File

@ -64,6 +64,7 @@ hRunCode hout inputInfo (LabelInfo labelInfo) instrs0 = runST goCode
Call x -> goCall x pc ap fp mem
Return -> goReturn pc ap fp mem
Alloc x -> goAlloc x pc ap fp mem
Assert x -> goAssert x pc ap fp mem
Trace x -> goTrace x pc ap fp mem
Hint x -> goHint x pc ap fp mem
Label {} -> go (pc + 1) ap fp mem
@ -244,6 +245,13 @@ hRunCode hout inputInfo (LabelInfo labelInfo) instrs0 = runST goCode
v <- readRValue ap fp mem _instrAllocSize
go (pc + 1) (ap + fromInteger (fieldToInteger v)) fp mem
goAssert :: InstrAssert -> Address -> Address -> Address -> Memory s -> ST s FField
goAssert InstrAssert {..} pc ap fp mem = do
v <- readMemRef ap fp mem _instrAssertValue
when (fieldToInteger v /= 0) $
throwRunError "assertion failed"
go (pc + 1) ap fp mem
goTrace :: InstrTrace -> Address -> Address -> Address -> Memory s -> ST s FField
goTrace InstrTrace {..} pc ap fp mem = do
v <- readRValue ap fp mem _instrTraceValue

2
src/Juvix/Compiler/Casm/Keywords.hs
View File

@ -11,6 +11,7 @@ import Juvix.Data.Keyword.All
kwAbs,
kwAp,
kwApPlusPlus,
kwAssert,
kwCall,
kwColon,
kwDiv,
@ -45,6 +46,7 @@ allKeywords =
kwAbs,
kwAp,
kwApPlusPlus,
kwAssert,
kwCall,
kwColon,
kwDiv,

6
src/Juvix/Compiler/Casm/Language.hs
View File

@ -90,6 +90,7 @@ data Instruction
| Call InstrCall
| Return
| Alloc InstrAlloc
| Assert InstrAssert
| Trace InstrTrace
| Hint Hint
| Label LabelRef
@ -132,6 +133,10 @@ newtype InstrAlloc = InstrAlloc
{ _instrAllocSize :: RValue
}
newtype InstrAssert = InstrAssert
{ _instrAssertValue :: MemRef
}
newtype InstrTrace = InstrTrace
{ _instrTraceValue :: RValue
}
@ -148,4 +153,5 @@ makeLenses ''InstrJump
makeLenses ''InstrJumpIf
makeLenses ''InstrCall
makeLenses ''InstrAlloc
makeLenses ''InstrAssert
makeLenses ''InstrTrace

6
src/Juvix/Compiler/Casm/Pretty/Base.hs
View File

@ -171,6 +171,11 @@ instance PrettyCode InstrAlloc where
s <- ppCode _instrAllocSize
return $ Str.ap <+> Str.plusequal <+> s
instance PrettyCode InstrAssert where
ppCode InstrAssert {..} = do
v <- ppCode _instrAssertValue
return $ Str.assert_ <+> v
instance PrettyCode InstrTrace where
ppCode InstrTrace {..} = do
v <- ppCode _instrTraceValue
@ -185,6 +190,7 @@ instance PrettyCode Instruction where
Call x -> ppCode x
Return -> return Str.ret
Alloc x -> ppCode x
Assert x -> ppCode x
Trace x -> ppCode x
Hint x -> ppCode x
Label x -> (<> colon) <$> ppCode x

13
src/Juvix/Compiler/Casm/Translation/FromReg.hs
View File

@ -286,6 +286,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI
Reg.Assign x -> goAssign x
Reg.Alloc x -> goAlloc x
Reg.AllocClosure x -> goAllocClosure x
Reg.Assert x -> goAssert x
Reg.Trace x -> goTrace x
Reg.Dump -> unsupported "dump"
Reg.Failure x -> goFail x
@ -512,6 +513,18 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI
storedArgsNum = length _instrAllocClosureArgs
leftArgsNum = _instrAllocClosureExpectedArgsNum - storedArgsNum
goAssert :: Reg.InstrAssert -> Sem r ()
goAssert Reg.InstrAssert {..} = do
v <- goValue _instrAssertValue
case v of
Imm c
| c == 0 -> return ()
| otherwise ->
output' 0 $ mkAssign (MemRef Ap 0) (Binop $ BinopValue FieldAdd (MemRef Ap 0) (Imm 1))
Ref r ->
output' 0 $ Assert (InstrAssert r)
Lab {} -> unsupported "assert label"
goTrace :: Reg.InstrTrace -> Sem r ()
goTrace Reg.InstrTrace {..} = do
v <- mkRValue _instrTraceValue

7
src/Juvix/Compiler/Casm/Translation/FromSource.hs
View File

@ -74,6 +74,7 @@ instruction =
<|> parseJump
<|> parseCall
<|> parseReturn
<|> parseAssert
<|> parseTrace
<|> parseAssign
@ -249,6 +250,12 @@ parseReturn = do
kw kwRet
return Return
parseAssert :: ParsecS r Instruction
parseAssert = do
kw kwAssert
r <- parseMemRef
return $ Assert $ InstrAssert {_instrAssertValue = r}
parseTrace :: (Member LabelInfoBuilder r) => ParsecS r Instruction
parseTrace = do
kw kwTrace

4
src/Juvix/Compiler/Casm/Validate.hs
View File

@ -18,6 +18,7 @@ validate labi instrs = mapM_ go instrs
Call x -> goCall x
Return -> return ()
Alloc x -> goAlloc x
Assert x -> goAssert x
Trace x -> goTrace x
Hint {} -> return ()
Label {} -> return ()
@ -66,3 +67,6 @@ validate labi instrs = mapM_ go instrs
goTrace :: InstrTrace -> Either CasmError ()
goTrace InstrTrace {..} = goRValue _instrTraceValue
goAssert :: InstrAssert -> Either CasmError ()
goAssert InstrAssert {} = return ()

8
src/Juvix/Compiler/Concrete/Data/Builtins.hs
View File

@ -125,7 +125,8 @@ instance Serialize BuiltinConstructor
instance NFData BuiltinConstructor
data BuiltinFunction
= BuiltinNatPlus
= BuiltinAssert
| BuiltinNatPlus
| BuiltinNatSub
| BuiltinNatMul
| BuiltinNatUDiv
@ -163,6 +164,7 @@ instance NFData BuiltinFunction
instance Pretty BuiltinFunction where
pretty = \case
BuiltinAssert -> Str.assert
BuiltinNatPlus -> Str.natPlus
BuiltinNatSub -> Str.natSub
BuiltinNatMul -> Str.natMul
@ -368,6 +370,7 @@ isNatBuiltin = \case
BuiltinNatLt -> True
BuiltinNatEq -> True
--
BuiltinAssert -> False
BuiltinBoolIf -> False
BuiltinBoolOr -> False
BuiltinBoolAnd -> False
@ -403,6 +406,7 @@ isIntBuiltin = \case
BuiltinIntLe -> True
BuiltinIntLt -> True
--
BuiltinAssert -> False
BuiltinNatPlus -> False
BuiltinNatSub -> False
BuiltinNatMul -> False
@ -425,6 +429,7 @@ isCastBuiltin = \case
BuiltinFromNat -> True
BuiltinFromInt -> True
--
BuiltinAssert -> False
BuiltinIntEq -> False
BuiltinIntPlus -> False
BuiltinIntSubNat -> False
@ -496,6 +501,7 @@ isIgnoredBuiltin f
-- Monad
BuiltinMonadBind -> False
-- Ignored
BuiltinAssert -> True
BuiltinBoolIf -> True
BuiltinBoolOr -> True
BuiltinBoolAnd -> True

16
src/Juvix/Compiler/Core/Evaluator.hs
View File

@ -217,6 +217,7 @@ geval opts herr tab env0 = eval' env0
OpSeq -> seqOp
OpFail -> failOp
OpTrace -> traceOp
OpAssert -> assertOp
OpAnomaGet -> anomaGetOp
OpAnomaEncode -> anomaEncodeOp
OpAnomaDecode -> anomaDecodeOp
@ -367,6 +368,21 @@ geval opts herr tab env0 = eval' env0
unsafePerformIO (hPutStrLn herr (printNode v) >> return v)
{-# INLINE traceOp #-}
assertOp :: [Node] -> Node
assertOp = unary $ \val ->
let !v = eval' env val
in if
| opts ^. evalOptionsSilent ->
v
| otherwise ->
case v of
NCtr Constr {..}
| _constrTag == BuiltinTag TagTrue ->
v
_ ->
Exception.throw (EvalError ("assertion failed: " <> printNode val) Nothing)
{-# INLINE assertOp #-}
anomaGetOp :: [Node] -> Node
anomaGetOp = unary $ \arg ->
if

2
src/Juvix/Compiler/Core/Extra/Utils.hs
View File

@ -188,6 +188,7 @@ containsDebugOperations = ufold (\x xs -> x || or xs) isDebugOp
OpTrace -> True
OpFail -> True
OpSeq -> True
OpAssert -> False
OpAnomaByteArrayFromAnomaContents -> False
OpAnomaByteArrayToAnomaContents -> False
OpAnomaDecode -> False
@ -466,6 +467,7 @@ builtinOpArgTypes = \case
OpShow -> [mkDynamic']
OpStrConcat -> [mkTypeString', mkTypeString']
OpStrToInt -> [mkTypeString']
OpAssert -> [mkTypeBool']
OpSeq -> [mkDynamic', mkDynamic']
OpTrace -> [mkDynamic']
OpFail -> [mkTypeString']

2
src/Juvix/Compiler/Core/Keywords.hs
View File

@ -15,6 +15,7 @@ import Juvix.Data.Keyword.All
kwAnomaVerifyDetached,
kwAnomaVerifyWithMessage,
kwAny,
kwAssert,
kwAssign,
kwBindOperator,
kwBottom,
@ -72,6 +73,7 @@ allKeywordStrings = keywordsStrings allKeywords
allKeywords :: [Keyword]
allKeywords =
[ delimSemicolon,
kwAssert,
kwAssign,
kwBottom,
kwBuiltin,

3
src/Juvix/Compiler/Core/Language/Builtins.hs
View File

@ -24,6 +24,7 @@ data BuiltinOp
| OpStrConcat
| OpStrToInt
| OpSeq
| OpAssert
| OpTrace
| OpFail
| OpAnomaGet
@ -84,6 +85,7 @@ builtinOpArgsNum = \case
OpStrConcat -> 2
OpStrToInt -> 1
OpSeq -> 2
OpAssert -> 1
OpTrace -> 1
OpFail -> 1
OpAnomaGet -> 1
@ -133,6 +135,7 @@ builtinIsFoldable = \case
OpStrConcat -> True
OpStrToInt -> True
OpSeq -> False
OpAssert -> False
OpTrace -> False
OpFail -> False
OpAnomaGet -> False

4
src/Juvix/Compiler/Core/Pretty/Base.hs
View File

@ -50,6 +50,7 @@ instance PrettyCode BuiltinOp where
OpShow -> return primShow
OpStrConcat -> return primStrConcat
OpStrToInt -> return primStrToInt
OpAssert -> return primAssert
OpSeq -> return primSeq
OpTrace -> return primTrace
OpFail -> return primFail
@ -867,6 +868,9 @@ kwPi = keyword Str.piUnicode
kwDef :: Doc Ann
kwDef = keyword Str.def
primAssert :: Doc Ann
primAssert = primitive Str.assert_
primSeq :: Doc Ann
primSeq = primitive Str.seqq_

3
src/Juvix/Compiler/Core/Transformation/ComputeTypeInfo.hs
View File

@ -64,6 +64,9 @@ computeNodeTypeInfo md = umapL go
OpSeq -> case _builtinAppArgs of
[_, arg2] -> Info.getNodeType arg2
_ -> error "incorrect seq builtin application"
OpAssert -> case _builtinAppArgs of
[arg] -> Info.getNodeType arg
_ -> error "incorrect assert builtin application"
OpTrace -> case _builtinAppArgs of
[arg] -> Info.getNodeType arg
_ -> error "incorrect trace builtin application"

5
src/Juvix/Compiler/Core/Translation/FromInternal.hs
View File

@ -1309,6 +1309,11 @@ goApplication a = do
(_ : _ : arg1 : arg2 : xs) ->
return (mkApps' (mkBuiltinApp' OpSeq [arg1, arg2]) xs)
_ -> error "internal to core: seq must be called with 2 arguments"
Just Internal.BuiltinAssert -> do
as <- exprArgs
case as of
(x : xs) -> return (mkApps' (mkBuiltinApp' OpAssert [x]) xs)
_ -> error "internal to core: assert must be called with 1 argument"
_ -> app
_ -> app

1
src/Juvix/Compiler/Core/Translation/FromSource.hs
View File

@ -569,6 +569,7 @@ builtinAppExpr varsNum vars = do
<|> (kw kwShow $> OpShow)
<|> (kw kwStrConcat $> OpStrConcat)
<|> (kw kwStrToInt $> OpStrToInt)
<|> (kw kwAssert $> OpAssert)
<|> (kw kwSeqq $> OpSeq)
<|> (kw kwTrace $> OpTrace)
<|> (kw kwFail $> OpFail)

1
src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs
View File

@ -28,6 +28,7 @@ fromCore fsize tab =
shouldKeepFunction :: BuiltinFunction -> Bool
shouldKeepFunction = \case
BuiltinAssert -> False
BuiltinNatPlus -> False
BuiltinNatSub -> False
BuiltinNatMul -> False

2
src/Juvix/Compiler/Internal/Translation/FromConcrete.hs
View File

@ -14,6 +14,7 @@ import Data.HashSet qualified as HashSet
import Data.IntMap.Strict qualified as IntMap
import Data.List.NonEmpty qualified as NonEmpty
import Juvix.Compiler.Builtins
import Juvix.Compiler.Builtins.Assert
import Juvix.Compiler.Builtins.Pair
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Extra qualified as Concrete
@ -537,6 +538,7 @@ checkBuiltinFunction ::
BuiltinFunction ->
Sem r ()
checkBuiltinFunction d f = localBuiltins $ case f of
BuiltinAssert -> checkAssert d
BuiltinNatPlus -> checkNatPlus d
BuiltinNatSub -> checkNatSub d
BuiltinNatMul -> checkNatMul d

5
src/Juvix/Compiler/Nockma/Translation/FromTree.hs
View File

@ -517,6 +517,9 @@ compile = \case
arg <- compile _nodeUnopArg
case _nodeUnopOpcode of
Tree.PrimUnop op -> return $ goPrimUnop op arg
Tree.OpAssert ->
-- TODO: remove duplication of `arg` here
return (branch arg arg crash)
Tree.OpFail -> return crash
Tree.OpTrace -> goTrace arg
@ -525,6 +528,7 @@ compile = \case
Tree.OpShow -> stringsErr "show"
Tree.OpStrToInt -> stringsErr "strToInt"
Tree.OpArgsNum ->
-- TODO: remove duplication of `arg` here!!!
let getF f = getClosureField f arg
in sub (getF ClosureTotalArgsNum) (getF ClosureArgsNum)
Tree.OpIntToField -> fieldErr
@ -651,6 +655,7 @@ compile = \case
enabled <- asks (^. compilerOptions . compilerOptionsEnableTrace)
return $
if
-- TODO: remove duplication of `arg` here
| enabled -> OpTrace # arg # arg
| otherwise -> arg

4
src/Juvix/Compiler/Reg/Extra/Base.hs
View File

@ -53,6 +53,7 @@ overValueRefs'' f = \case
If x -> If <$> goIf x
Branch x -> Branch <$> goBranch x
Case x -> Case <$> goCase x
Assert x -> Assert <$> goAssert x
Trace x -> Trace <$> goTrace x
Dump -> return Dump
Failure x -> Failure <$> goFailure x
@ -174,6 +175,9 @@ overValueRefs'' f = \case
goCase :: InstrCase -> m InstrCase
goCase = overM instrCaseValue goValue
goAssert :: InstrAssert -> m InstrAssert
goAssert = overM instrAssertValue goValue
goTrace :: InstrTrace -> m InstrTrace
goTrace = overM instrTraceValue goValue

4
src/Juvix/Compiler/Reg/Extra/Blocks.hs
View File

@ -79,6 +79,7 @@ getValueRefs = \case
Assign x -> goAssign x
Alloc x -> goAlloc x
AllocClosure x -> goAllocClosure x
Assert x -> goAssert x
Trace x -> goTrace x
Dump -> []
Failure x -> goFailure x
@ -103,6 +104,9 @@ getValueRefs = \case
goAllocClosure :: InstrAllocClosure -> [VarRef]
goAllocClosure InstrAllocClosure {..} = concatMap getValueRefs'' _instrAllocClosureArgs
goAssert :: InstrAssert -> [VarRef]
goAssert InstrAssert {..} = getValueRefs'' _instrAssertValue
goTrace :: InstrTrace -> [VarRef]
goTrace InstrTrace {..} = getValueRefs'' _instrTraceValue

5
src/Juvix/Compiler/Reg/Extra/Info.hs
View File

@ -21,6 +21,7 @@ computeMaxStackHeight lims = maximum . map go
Unop {} -> 0
Cairo {} -> 0
Assign {} -> 0
Assert {} -> 0
Trace {} -> 0
Dump -> 0
Failure {} -> 0
@ -73,6 +74,7 @@ computeMaxCallClosuresArgsNum = maximum . map go
Unop {} -> 0
Cairo {} -> 0
Assign {} -> 0
Assert {} -> 0
Trace {} -> 0
Dump -> 0
Failure {} -> 0
@ -121,6 +123,8 @@ computeStringMap strs = snd . run . execState (HashMap.size strs, strs) . mapM g
mapM_ goVal _instrCairoArgs
Assign InstrAssign {..} ->
goVal _instrAssignValue
Assert InstrAssert {..} ->
goVal _instrAssertValue
Trace InstrTrace {..} ->
goVal _instrTraceValue
Dump -> return ()
@ -180,6 +184,7 @@ computeLocalVarsNum = maximum . map go
Unop InstrUnop {..} -> goVarRef _instrUnopResult
Cairo InstrCairo {..} -> goVarRef _instrCairoResult
Assign InstrAssign {..} -> goVarRef _instrAssignResult
Assert {} -> 0
Trace {} -> 0
Dump -> 0
Failure {} -> 0

10
src/Juvix/Compiler/Reg/Interpreter.hs
View File

@ -48,6 +48,7 @@ runFunction hout infoTable args0 info0 = do
Unop x -> goUnop args tmps instrs x
Cairo {} -> throwRunError "unsupported: Cairo builtin" Nothing
Assign x -> goAssign args tmps instrs x
Assert x -> goAssert args tmps instrs x
Trace x -> goTrace args tmps instrs x
Dump -> goDump args tmps instrs
Failure x -> goFailure args tmps instrs x
@ -130,6 +131,15 @@ runFunction hout infoTable args0 info0 = do
writeVarRef args tmps _instrAssignResult val
go args tmps instrs
goAssert :: Args -> Vars s -> Code -> InstrAssert -> ST s Val
goAssert args tmps instrs InstrAssert {..} = do
val <- readValue args tmps _instrAssertValue
case val of
ValBool True ->
go args tmps instrs
_ ->
throwRunError "assertion failed" Nothing
goTrace :: Args -> Vars s -> Code -> InstrTrace -> ST s Val
goTrace args tmps instrs InstrTrace {..} = do
val <- readValue args tmps _instrTraceValue

2
src/Juvix/Compiler/Reg/Keywords.hs
View File

@ -10,6 +10,7 @@ import Juvix.Data.Keyword.All
( kwAdd_,
kwAlloc,
kwArgsNum,
kwAssert,
kwAtoi,
kwBr,
kwCAlloc,
@ -74,6 +75,7 @@ allKeywords =
kwIf,
kwShow,
kwAtoi,
kwAssert,
kwTrace,
kwDump,
kwPrealloc,

3
src/Juvix/Compiler/Reg/Language.hs
View File

@ -25,7 +25,8 @@ data Instruction
| Branch InstrBranch
| Case InstrCase
| ----
Trace InstrTrace
Assert InstrAssert
| Trace InstrTrace
| Dump
| Failure InstrFailure
| Prealloc InstrPrealloc

1
src/Juvix/Compiler/Reg/Language/Blocks.hs
View File

@ -20,6 +20,7 @@ data Instruction
| Assign InstrAssign
| Alloc InstrAlloc
| AllocClosure InstrAllocClosure
| Assert InstrAssert
| Trace InstrTrace
| Dump
| Failure InstrFailure

6
src/Juvix/Compiler/Reg/Language/Instrs.hs
View File

@ -80,6 +80,11 @@ data InstrAssign = InstrAssign
}
deriving stock (Eq)
newtype InstrAssert = InstrAssert
{ _instrAssertValue :: Value
}
deriving stock (Eq)
newtype InstrTrace = InstrTrace
{ _instrTraceValue :: Value
}
@ -184,6 +189,7 @@ makeLenses ''InstrBinop
makeLenses ''InstrUnop
makeLenses ''InstrCairo
makeLenses ''InstrAssign
makeLenses ''InstrAssert
makeLenses ''InstrTrace
makeLenses ''InstrFailure
makeLenses ''InstrAlloc

6
src/Juvix/Compiler/Reg/Pretty/Base.hs
View File

@ -75,6 +75,11 @@ instance PrettyCode InstrAssign where
val <- ppCode _instrAssignValue
return $ res <+> primitive Str.equal <+> val
instance PrettyCode InstrAssert where
ppCode InstrAssert {..} = do
val <- ppCode _instrAssertValue
return $ primitive Str.assert_ <+> val
instance PrettyCode InstrTrace where
ppCode InstrTrace {..} = do
val <- ppCode _instrTraceValue
@ -271,6 +276,7 @@ instance PrettyCode Instruction where
Unop x -> ppCode x
Cairo x -> ppCode x
Assign x -> ppCode x
Assert x -> ppCode x
Trace x -> ppCode x
Dump -> return $ primitive Str.dump
Failure x -> ppCode x

1
src/Juvix/Compiler/Reg/Translation/Blocks/FromReg.hs
View File

@ -30,6 +30,7 @@ fromReg = over infoFunctions (fmap (over functionCode goCode))
Reg.Case x -> mkBlock (Case (fmap goCode x))
Reg.CallClosures {} -> impossible
Reg.TailCallClosures {} -> impossible
Reg.Assert x -> over blockBody (Assert x :) (goCode is)
Reg.Trace x -> over blockBody (Trace x :) (goCode is)
Reg.Dump -> over blockBody (Dump :) (goCode is)
Reg.Failure x -> over blockBody (Failure x :) (goCode is)

1
src/Juvix/Compiler/Reg/Translation/FromAsm.hs
View File

@ -69,6 +69,7 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} =
Asm.Cairo op -> return $ mkCairo op
Asm.Push val -> return $ mkAssign (mkVarRef VarGroupLocal (ntmps + n + 1)) (mkValue val)
Asm.Pop -> return Nop
Asm.Assert -> return $ Assert $ InstrAssert (VRef $ mkVarRef VarGroupLocal (ntmps + n))
Asm.Trace -> return $ Trace $ InstrTrace (VRef $ mkVarRef VarGroupLocal (ntmps + n))
Asm.Dump -> return Dump
Asm.Failure -> return $ Failure $ InstrFailure (VRef $ mkVarRef VarGroupLocal (ntmps + n))

12
src/Juvix/Compiler/Reg/Translation/FromSource.hs
View File

@ -53,6 +53,7 @@ instruction ::
ParsecS r Instruction
instruction =
(instrNop >> return Nop)
<|> (Assert <$> instrAssert)
<|> (Trace <$> instrTrace)
<|> (instrDump >> return Dump)
<|> (Failure <$> instrFailure)
@ -195,6 +196,17 @@ instrTrace = do
{ _instrTraceValue = val
}
instrAssert ::
(Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
ParsecS r InstrAssert
instrAssert = do
kw kwAssert
val <- value
return
InstrAssert
{ _instrAssertValue = val
}
instrDump :: ParsecS r ()
instrDump = kw kwDump

6
src/Juvix/Compiler/Tree/Evaluator.hs
View File

@ -75,6 +75,7 @@ hEval hout tab = eval' [] mempty
let !v = eval' args temps _nodeUnopArg
in case _nodeUnopOpcode of
PrimUnop op -> eitherToError $ evalUnop tab op v
OpAssert -> goAssert v
OpTrace -> goTrace v
OpFail -> goFail v
@ -105,6 +106,11 @@ hEval hout tab = eval' [] mempty
_ -> evalError "expected either a nullary or a binary constructor"
_ -> evalError "expected a constructor"
goAssert :: Value -> Value
goAssert = \case
ValBool True -> ValBool True
_ -> evalError "assertion failed"
goFail :: Value -> Value
goFail v = evalError ("failure: " <> printValue tab v)

7
src/Juvix/Compiler/Tree/EvaluatorEff.hs
View File

@ -70,6 +70,7 @@ eval tab = runReader emptyEvalCtx . eval'
v <- eval' _nodeUnopArg
case _nodeUnopOpcode of
PrimUnop op -> eitherToError $ evalUnop tab op v
OpAssert -> goAssert v
OpTrace -> goTrace v
OpFail -> goFail v
@ -100,6 +101,12 @@ eval tab = runReader emptyEvalCtx . eval'
_ -> evalError "expected either a nullary or a binary constructor"
_ -> evalError "expected a constructor"
goAssert :: Value -> Sem r' Value
goAssert = \case
ValBool True -> return $ ValBool True
ValBool False -> evalError "assertion failed"
v -> evalError ("expected a boolean: " <> printValue tab v)
goFail :: Value -> Sem r' Value
goFail v = evalError ("failure: " <> printValue tab v)

2
src/Juvix/Compiler/Tree/Keywords.hs
View File

@ -17,6 +17,7 @@ import Juvix.Data.Keyword.All
kwAnomaVerifyDetached,
kwAnomaVerifyWithMessage,
kwArgsNum,
kwAssert,
kwAtoi,
kwBr,
kwByteArrayFromListUInt8,
@ -70,6 +71,7 @@ allKeywords =
kwStrcat,
kwShow,
kwAtoi,
kwAssert,
kwTrace,
kwFail,
kwArgsNum,

2
src/Juvix/Compiler/Tree/Language.hs
View File

@ -65,6 +65,8 @@ data BinaryOpcode
data UnaryOpcode
= PrimUnop UnaryOp
| -- | Assert a boolean and return it
OpAssert
| -- | Print a debug log of the argument and return it.
OpTrace
| -- | Interrupt execution with a runtime error printing the argument.

1
src/Juvix/Compiler/Tree/Pretty/Base.hs
View File

@ -297,6 +297,7 @@ instance PrettyCode AnomaOp where
instance PrettyCode UnaryOpcode where
ppCode = \case
PrimUnop x -> ppCode x
OpAssert -> return $ primitive Str.instrAssert
OpTrace -> return $ primitive Str.instrTrace
OpFail -> return $ primitive Str.instrFailure

1
src/Juvix/Compiler/Tree/Transformation/Validate.hs
View File

@ -65,6 +65,7 @@ inferType tab funInfo = goInfer mempty
goUnop :: BinderList Type -> NodeUnop -> Sem r Type
goUnop bl NodeUnop {..} = case _nodeUnopOpcode of
PrimUnop x -> checkPrimUnop x
OpAssert -> goInfer bl _nodeUnopArg
OpTrace -> goInfer bl _nodeUnopArg
OpFail -> checkUnop TyDynamic TyDynamic
where

13
src/Juvix/Compiler/Tree/Translation/FromAsm.hs
View File

@ -92,6 +92,7 @@ goFunction infoTab fi = do
Asm.Push (Asm.Constant c) -> return (mkConst c)
Asm.Push (Asm.Ref r) -> return (mkMemRef r)
Asm.Pop -> goPop
Asm.Assert -> goAssert
Asm.Trace -> goTrace
Asm.Dump -> unsupported (_cmdInstrInfo ^. Asm.commandInfoLocation)
Asm.Failure -> goUnop OpFail
@ -244,8 +245,8 @@ goFunction infoTab fi = do
_nodeBinopArg2 = arg2
}
goTrace :: Sem r Node
goTrace = do
goSeqOp :: UnaryOpcode -> Sem r Node
goSeqOp op = do
arg <- goCode
off <- asks (^. tempSize)
let ref = mkMemRef $ DRef $ mkTempRef $ OffsetRef off Nothing
@ -264,13 +265,19 @@ goFunction infoTab fi = do
Unop
NodeUnop
{ _nodeUnopInfo = mempty,
_nodeUnopOpcode = OpTrace,
_nodeUnopOpcode = op,
_nodeUnopArg = ref
},
_nodeBinopArg2 = ref
}
}
goAssert :: Sem r Node
goAssert = goSeqOp OpAssert
goTrace :: Sem r Node
goTrace = goSeqOp OpTrace
goArgs :: Int -> Sem r [Node]
goArgs n = mapM (const goCode) [1 .. n]

10
src/Juvix/Compiler/Tree/Translation/FromCore.hs
View File

@ -163,6 +163,16 @@ genCode infoTable fi =
_nodeAnomaOpcode = genAnomaOp _builtinAppOp,
_nodeAnomaArgs = args
}
| _builtinAppOp == Core.OpAssert =
case args of
[arg] ->
Unop $
NodeUnop
{ _nodeUnopInfo = mempty,
_nodeUnopOpcode = OpAssert,
_nodeUnopArg = arg
}
_ -> impossible
| otherwise =
case args of
[arg] ->

1
src/Juvix/Compiler/Tree/Translation/FromSource.hs
View File

@ -106,6 +106,7 @@ parseUnop ::
parseUnop =
parseUnaryOp kwShow (PrimUnop OpShow)
<|> parseUnaryOp kwAtoi (PrimUnop OpStrToInt)
<|> parseUnaryOp kwAssert OpAssert
<|> parseUnaryOp kwTrace OpTrace
<|> parseUnaryOp kwFail OpFail
<|> parseUnaryOp kwArgsNum (PrimUnop OpArgsNum)

3
src/Juvix/Data/Keyword/All.hs
View File

@ -265,6 +265,9 @@ kwSeqq = asciiKw Str.seqq_
kwSSeq :: Keyword
kwSSeq = asciiKw Str.sseq_
kwAssert :: Keyword
kwAssert = asciiKw Str.assert_
kwTrace :: Keyword
kwTrace = asciiKw Str.trace_

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

@ -260,6 +260,9 @@ ioSequence = "IO-sequence"
ioReadline :: (IsString s) => s
ioReadline = "IO-readline"
assert :: (IsString s) => s
assert = "assert"
natPrint :: (IsString s) => s
natPrint = "nat-print"
@ -482,6 +485,9 @@ sseq_ = "seq"
eq :: (IsString s) => s
eq = "eq"
assert_ :: (IsString s) => s
assert_ = "assert"
trace_ :: (IsString s) => s
trace_ = "trace"
@ -845,6 +851,9 @@ instrPusht = "pusht"
instrPopt :: (IsString s) => s
instrPopt = "popt"
instrAssert :: (IsString s) => s
instrAssert = "assert"
instrTrace :: (IsString s) => s
instrTrace = "trace"

10
test/Casm/Compilation/Positive.hs
View File

@ -557,5 +557,13 @@ tests =
$(mkRelDir ".")
$(mkRelFile "test077.juvix")
(Just $(mkRelFile "in/test077.json"))
$(mkRelFile "out/test077.out")
$(mkRelFile "out/test077.out"),
posTest
"Test078: Assertions"
True
True
$(mkRelDir ".")
$(mkRelFile "test078.juvix")
Nothing
$(mkRelFile "out/test078.out")
]

8
test/Casm/Run/Positive.hs
View File

@ -178,5 +178,13 @@ tests =
$(mkRelDir ".")
$(mkRelFile "test017.casm")
$(mkRelFile "out/test017.out")
Nothing,
PosTest
"Test018: Assertions"
True
True
$(mkRelDir ".")
$(mkRelFile "test018.casm")
$(mkRelFile "out/test018.out")
Nothing
]

1
tests/Casm/Compilation/positive/out/test078.out Normal file
View File

@ -0,0 +1 @@
482630520

8
tests/Casm/Compilation/positive/test077.juvix
View File

@ -40,11 +40,3 @@ main
| else := Resource.fld0 input;
y := Resource.fld1 input
};
{-
main
(input : Resource)
(path : List (Pair Field Bool))
: Field :=
count path;
-}

11
tests/Casm/Compilation/positive/test078.juvix Normal file
View File

@ -0,0 +1,11 @@
module test078;
import Stdlib.Prelude open;
fact' (acc : Nat) : Nat → Nat
| zero := acc
| (suc x) := assert (acc /= 0) >-> fact' (acc * suc x) x;
fact : Nat → Nat := fact' 1;
main : Nat := assert (fact 10 == 10 * fact 9) >-> fact 5 + fact 10 + fact 12;

1
tests/Casm/positive/out/test018.out Normal file
View File

@ -0,0 +1 @@
0

13
tests/Casm/positive/test018.casm Normal file
View File

@ -0,0 +1,13 @@
-- assertions
start:
[ap] = 10
[ap + 1] = 1
ap += 2
loop:
[ap] = [ap - 2] - 1
[ap + 1] = [ap - 1] * [ap - 2]
ap += 2
jmp loop if [ap - 2] != 0
[ap] = [ap - 1] - 3628800; ap++
assert [ap - 1]