From 2bfc80964fc945711d401611eeea3f60b75d2b22 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 27 Sep 2024 22:48:01 +0200 Subject: [PATCH 01/18] extend CompilerCtx --- .../Compiler/Nockma/Translation/FromTree.hs | 104 +++++++++++------- 1 file changed, 67 insertions(+), 37 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 2a752e58b8..090f492eb6 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -34,6 +34,7 @@ module Juvix.Compiler.Nockma.Translation.FromTree where import Data.ByteString qualified as BS +import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Nockma.Encoding import Juvix.Compiler.Nockma.Encoding.Ed25519 qualified as E import Juvix.Compiler.Nockma.Language.Path @@ -113,9 +114,17 @@ newtype FunctionCtx = FunctionCtx { _functionCtxArity :: Natural } +newtype TempRef = TempRef + { _tempRefIndex :: Int + } + data CompilerCtx = CompilerCtx { _compilerFunctionInfos :: HashMap FunctionId FunctionInfo, _compilerConstructorInfos :: ConstructorInfos, + -- | Maps temporary variables to their stack indices. + _compilerTempVarMap :: HashMap Int TempRef, + _compilerTempVarsNum :: Int, + _compilerStackHeight :: Int, _compilerOptions :: CompilerOptions } @@ -158,6 +167,7 @@ data AnomaCallablePathId -- 3. argsNum is the number of arguments that have been applied to the closure. -- 4. args is the list of args that have been applied. -- The length of the list should be argsNum. +-- TODO: this comment seems outdated pathFromEnum :: (Enum a) => a -> Path pathFromEnum = indexStack . fromIntegral . fromEnum @@ -195,6 +205,7 @@ indexInStack s idx = stackPath s ++ indexStack idx makeLenses ''CompilerOptions makeLenses ''AnomaResult makeLenses ''CompilerFunction +makeLenses ''TempRef makeLenses ''CompilerCtx makeLenses ''FunctionCtx makeLenses ''ConstructorInfo @@ -458,27 +469,23 @@ compile = \case goSave :: Tree.NodeSave -> Sem r (Term Natural) goSave Tree.NodeSave {..} = do - arg <- compile _nodeSaveArg - body <- compile _nodeSaveBody - return (withTemp arg body) + withTempVar _nodeSaveArg (compile _nodeSaveBody) goCase :: Tree.NodeCase -> Sem r (Term Natural) goCase c = do def <- mapM compile (c ^. Tree.nodeCaseDefault) arg <- compile (c ^. Tree.nodeCaseArg) - branches <- - sequence - [ do - let withTemp' t - | b ^. Tree.caseBranchSave = withTemp arg t - | otherwise = t - - body' <- withTemp' <$> compile (b ^. Tree.caseBranchBody) - return (b ^. Tree.caseBranchTag, body') - | b <- c ^. Tree.nodeCaseBranches - ] + branches <- mapM goCaseBranch (c ^. Tree.nodeCaseBranches) caseCmd arg def branches + goCaseBranch :: Tree.CaseBranch -> Sem r (Tree.Tag, Term Natural) + goCaseBranch b = do + let withSave t + | b ^. Tree.caseBranchSave = t + | otherwise = popTempVar t + body' <- withSave $ compile (b ^. Tree.caseBranchBody) + return (b ^. Tree.caseBranchTag, body') + goBranch :: Tree.NodeBranch -> Sem r (Term Natural) goBranch Tree.NodeBranch {..} = do arg <- compile _nodeBranchArg @@ -754,19 +761,37 @@ argsTuplePlaceholder txt = nockNilTagged ("argsTuplePlaceholder-" <> txt) appendRights :: Path -> Term Natural -> Term Natural appendRights path n = dec (mul (pow2 n) (OpInc # OpQuote # path)) -withTemp :: Term Natural -> Term Natural -> Term Natural -withTemp toBePushed body = - OpSequence # pushTemp # body - where - pushTemp :: Term Natural - pushTemp = - remakeList - [ let p = opAddress "pushTemp" (stackPath s) - in if - | TempStack == s -> toBePushed # p - | otherwise -> p - | s <- allElements - ] +withTemp :: + (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => + Tree.Node -> + (TempRef -> Sem r (Term Natural)) -> + Sem r (Term Natural) +withTemp value f = do + value' <- compile value + stackHeight <- asks (^. compilerStackHeight) + body' <- local (over compilerStackHeight (+ 1)) $ f (TempRef stackHeight) + return $ OpPush # value' # body' + +withTempVar :: + (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => + Tree.Node -> + (Sem r (Term Natural)) -> + Sem r (Term Natural) +withTempVar value cont = withTemp value $ \temp -> do + tempVar <- asks (^. compilerTempVarsNum) + local (over compilerTempVarMap (HashMap.insert tempVar temp)) + . local (over compilerTempVarsNum (+ 1)) + $ cont + +popTempVar :: + (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => + (Sem r (Term Natural)) -> + Sem r (Term Natural) +popTempVar cont = do + tempVar <- asks (^. compilerTempVarsNum) + local (over compilerTempVarMap (HashMap.delete (tempVar - 1))) + . local (over compilerTempVarsNum (\x -> x - 1)) + $ cont testEq :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => Tree.Node -> Tree.Node -> Sem r (Term Natural) testEq a b = do @@ -783,6 +808,8 @@ nockIntegralLiteral = (OpQuote #) . toNock @Natural . fromIntegral -- | xs must be a list. -- ys is a (possibly empty) tuple. -- the result is a tuple. +-- NOTE: xs occurs twice, but that's fine because each occurrence is in a +-- different if branch. appendToTuple :: Term Natural -> Term Natural -> Term Natural -> Term Natural -> Term Natural appendToTuple xs lenXs ys lenYs = OpIf # isZero lenYs # listToTuple xs lenXs # append xs lenXs ys @@ -850,18 +877,15 @@ constUnit = constVoid constVoid :: Term Natural constVoid = TermAtom nockVoid -directRefPath :: forall r. (Members '[Reader FunctionCtx] r) => Tree.DirectRef -> Sem r Path +directRefPath :: forall r. (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => Tree.DirectRef -> Sem r Path directRefPath = \case Tree.ArgRef a -> pathToArg (fromOffsetRef a) - Tree.TempRef Tree.RefTemp {..} -> - return - ( tempRefPath - (fromIntegral (fromJust _refTempTempHeight)) - (fromOffsetRef _refTempOffsetRef) - ) - -tempRefPath :: Natural -> Natural -> Path -tempRefPath tempHeight off = indexInStack TempStack (tempHeight - off - 1) + Tree.TempRef Tree.RefTemp {..} -> do + stackHeight <- asks (^. compilerStackHeight) + varMap <- asks (^. compilerTempVarMap) + let tempIdx = _refTempOffsetRef ^. Tree.offsetRefOffset + ref = fromJust $ HashMap.lookup tempIdx varMap + return $ indexStack $ fromIntegral $ (stackHeight - ref ^. tempRefIndex - 1) nockmaBuiltinTag :: Tree.BuiltinDataTag -> NockmaBuiltinTag nockmaBuiltinTag = \case @@ -935,6 +959,9 @@ runCompilerWith opts constrs moduleFuns mainFun = makeAnomaFun CompilerCtx { _compilerFunctionInfos = functionInfos, _compilerConstructorInfos = constrs, + _compilerTempVarMap = mempty, + _compilerTempVarsNum = 0, + _compilerStackHeight = 0, _compilerOptions = opts } @@ -1113,6 +1140,9 @@ constructorTagToTerm = \case Tree.UserTag t -> OpQuote # toNock (fromIntegral (t ^. Tree.tagUserWord) :: Natural) Tree.BuiltinTag b -> builtinTagToTerm (nockmaBuiltinTag b) +-- Creates a case command from the compiled value `arg` and the compiled +-- branches. Note: `arg` is duplicated, so it should be a reference -- not +-- perform any non-trivial computation! caseCmd :: forall r. (Members '[Reader CompilerCtx] r) => From 0bafc1f6f67b0a3b95f17da18b421c0b8399addf Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 30 Sep 2024 20:40:35 +0200 Subject: [PATCH 02/18] wip --- .../Compiler/Nockma/Translation/FromTree.hs | 302 ++++++++++-------- 1 file changed, 173 insertions(+), 129 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 090f492eb6..5d594ed058 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -15,7 +15,6 @@ module Juvix.Compiler.Nockma.Translation.FromTree add, dec, mul, - sub, pow2, nockNatLiteral, nockIntegralLiteral, @@ -159,6 +158,9 @@ data AnomaCallablePathId | AnomaGetOrder deriving stock (Enum, Bounded, Eq, Show) +indexStack :: Natural -> Path +indexStack idx = replicate idx R ++ [L] + -- | A closure has the following structure: -- [code totalArgsNum argsNum args], where -- 1. code is code to run when fully applied. @@ -179,8 +181,8 @@ data ConstructorPathId constructorPath :: ConstructorPathId -> Path constructorPath = pathFromEnum -stackPath :: AnomaCallablePathId -> Path -stackPath s = indexStack (fromIntegral (fromEnum s)) +closurePath :: AnomaCallablePathId -> Path +closurePath = pathFromEnum data IndexTupleArgs = IndexTupleArgs { _indexTupleArgsLength :: Natural, @@ -196,12 +198,6 @@ indexTuple IndexTupleArgs {..} | otherwise = [L] in replicate _indexTupleArgsIndex R ++ lastL -indexStack :: Natural -> Path -indexStack idx = replicate idx R ++ [L] - -indexInStack :: AnomaCallablePathId -> Natural -> Path -indexInStack s idx = stackPath s ++ indexStack idx - makeLenses ''CompilerOptions makeLenses ''AnomaResult makeLenses ''CompilerFunction @@ -211,6 +207,16 @@ makeLenses ''FunctionCtx makeLenses ''ConstructorInfo makeLenses ''FunctionInfo +stackPath :: (Member (Reader CompilerCtx) r) => AnomaCallablePathId -> Sem r Path +stackPath s = do + h <- asks (^. compilerStackHeight) + return $ indexStack (fromIntegral (h + fromEnum s)) + +indexInStack :: (Member (Reader CompilerCtx) r) => AnomaCallablePathId -> Natural -> Sem r Path +indexInStack s idx = do + sp <- stackPath s + return $ sp ++ indexStack idx + runCompilerFunction :: CompilerCtx -> CompilerFunction -> Term Natural runCompilerFunction ctx fun = run @@ -218,11 +224,12 @@ runCompilerFunction ctx fun = . runReader ctx $ fun ^. compilerFunction -pathToArg :: (Members '[Reader FunctionCtx] r) => Natural -> Sem r Path +pathToArg :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => Natural -> Sem r Path pathToArg n = do ari <- asks (^. functionCtxArity) + path <- stackPath ArgsTuple return - ( stackPath ArgsTuple + ( path <> indexTuple IndexTupleArgs { _indexTupleArgsLength = ari, @@ -337,26 +344,38 @@ fromTreeTable t = case t ^. Tree.infoMainFunction of fromOffsetRef :: Tree.OffsetRef -> Natural fromOffsetRef = fromIntegral . (^. Tree.offsetRefOffset) -anomaCallableClosureWrapper :: Term Natural -anomaCallableClosureWrapper = +tempRefPath :: (Member (Reader CompilerCtx) r) => TempRef -> Sem r Path +tempRefPath (TempRef idx) = do + h <- asks (^. compilerStackHeight) + return $ indexStack (fromIntegral (h - idx - 1)) + +addressTempRef :: (Member (Reader CompilerCtx) r) => TempRef -> Sem r (Term Natural) +addressTempRef tr = do + p <- tempRefPath tr + return $ opAddress "tempRef" p + +anomaCallableClosureWrapper :: (Member (Reader CompilerCtx) r) => Sem r (Term Natural) +anomaCallableClosureWrapper = do let closureArgsNum :: Term Natural = getClosureFieldInSubject ClosureArgsNum closureTotalArgsNum :: Term Natural = getClosureFieldInSubject ClosureTotalArgsNum - appendAndReplaceArgsTuple = + remainingArgsNum <- sub closureTotalArgsNum closureArgsNum + let appendAndReplaceArgsTuple = replaceArgsWithTerm "anomaCallableClosureWrapper" $ appendToTuple (getClosureFieldInSubject ClosureArgs) closureArgsNum (getClosureFieldInSubject ArgsTuple) - (sub closureTotalArgsNum closureArgsNum) + remainingArgsNum closureArgsIsEmpty = isZero closureArgsNum adjustArgs = OpIf # closureArgsIsEmpty # (opAddress "wrapperSubject" emptyPath) # appendAndReplaceArgsTuple - in opCall "closureWrapper" (closurePath RawCode) adjustArgs + in return $ opCall "closureWrapper" (closurePath RawCode) adjustArgs mainFunctionWrapper :: Term Natural -> Term Natural mainFunctionWrapper funslib = -- 1. The Anoma system expects to receive a function of type `ScryId -> Transaction` -- - -- 2. The ScryId is only used to construct the argument to the Scry operation (i.e the anomaGet builtin in the Juvix frontend), + -- 2. The ScryId is only used to construct the argument to the Scry operation + -- (i.e the anomaGet builtin in the Juvix frontend), -- -- 3. When the Juvix developer writes a function to submit to Anoma they use -- type `() -> Transaction`, this wrapper is used to capture the ScryId @@ -498,21 +517,24 @@ compile = \case args <- mapM compile _nodeAnomaArgs case _nodeAnomaOpcode of Tree.OpAnomaGet -> goAnomaGet args - Tree.OpAnomaEncode -> return (goAnomaEncode args) - Tree.OpAnomaDecode -> return (goAnomaDecode args) - Tree.OpAnomaVerifyDetached -> return (goAnomaVerifyDetached args) - Tree.OpAnomaSign -> return (goAnomaSign args) - Tree.OpAnomaVerifyWithMessage -> return (goAnomaVerifyWithMessage args) - Tree.OpAnomaSignDetached -> return (goAnomaSignDetached args) + Tree.OpAnomaEncode -> goAnomaEncode args + Tree.OpAnomaDecode -> goAnomaDecode args + Tree.OpAnomaVerifyDetached -> goAnomaVerifyDetached args + Tree.OpAnomaSign -> goAnomaSign args + Tree.OpAnomaVerifyWithMessage -> goAnomaVerifyWithMessage args + Tree.OpAnomaSignDetached -> goAnomaSignDetached args Tree.OpAnomaByteArrayFromAnomaContents -> return (goAnomaByteArrayFromAnomaContents args) Tree.OpAnomaByteArrayToAnomaContents -> return (goAnomaByteArrayToAnomaContents args) goByteArrayOp :: Tree.NodeByteArray -> Sem r (Term Natural) goByteArrayOp Tree.NodeByteArray {..} = do args <- mapM compile _nodeByteArrayArgs - return $ case _nodeByteArrayOpcode of - Tree.OpByteArrayLength -> goByteArrayLength args - Tree.OpByteArrayFromListUInt8 -> callStdlib StdlibLengthList args # callStdlib StdlibFoldBytes args + case _nodeByteArrayOpcode of + Tree.OpByteArrayLength -> return $ goByteArrayLength args + Tree.OpByteArrayFromListUInt8 -> do + len <- callStdlib StdlibLengthList args + args' <- callStdlib StdlibFoldBytes args + return $ len # args' where goByteArrayLength :: [Term Natural] -> Term Natural goByteArrayLength = \case @@ -520,38 +542,43 @@ compile = \case _ -> impossible goUnop :: Tree.NodeUnop -> Sem r (Term Natural) - goUnop Tree.NodeUnop {..} = do - arg <- compile _nodeUnopArg + goUnop Tree.NodeUnop {..} = case _nodeUnopOpcode of - Tree.PrimUnop op -> return $ goPrimUnop op arg + Tree.PrimUnop op -> goPrimUnop op _nodeUnopArg Tree.OpAssert -> - -- TODO: remove duplication of `arg` here - return (branch arg arg crash) + withTemp _nodeUnopArg $ \ref -> do + arg <- addressTempRef ref + return (branch arg arg crash) Tree.OpFail -> return crash - Tree.OpTrace -> goTrace arg + Tree.OpTrace -> do + arg <- compile _nodeUnopArg + goTrace arg - goPrimUnop :: Tree.UnaryOp -> Term Natural -> Term Natural + goPrimUnop :: Tree.UnaryOp -> Tree.Node -> Sem r (Term Natural) goPrimUnop op arg = case op of 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) + withTemp + arg + ( \ref -> do + arg' <- addressTempRef ref + sub (getClosureField ClosureTotalArgsNum arg') (getClosureField ClosureArgsNum arg') + ) Tree.OpIntToField -> fieldErr Tree.OpFieldToInt -> fieldErr - Tree.OpIntToUInt8 -> intToUInt8 arg - Tree.OpUInt8ToInt -> arg + Tree.OpIntToUInt8 -> intToUInt8 =<< compile arg + Tree.OpUInt8ToInt -> compile arg goAnomaGet :: [Term Natural] -> Sem r (Term Natural) goAnomaGet key = do let arg = remakeList [getFieldInSubject AnomaGetOrder, foldTermsOrNil key] return (OpScry # (OpQuote # nockNilTagged "OpScry-typehint") # arg) - goAnomaEncode :: [Term Natural] -> Term Natural + goAnomaEncode :: [Term Natural] -> Sem r (Term Natural) goAnomaEncode = callStdlib StdlibEncode - goAnomaDecode :: [Term Natural] -> Term Natural + goAnomaDecode :: [Term Natural] -> Sem r (Term Natural) goAnomaDecode = callStdlib StdlibDecode byteArrayPayload :: Text -> Term Natural -> Term Natural @@ -560,50 +587,59 @@ compile = \case mkByteArray :: Term Natural -> Term Natural -> Term Natural mkByteArray len payload = len # payload - goAnomaVerifyDetached :: [Term Natural] -> Term Natural + goAnomaVerifyDetached :: [Term Natural] -> Sem r (Term Natural) goAnomaVerifyDetached = \case - [sig, message, pubKey] -> + [sig, message, pubKey] -> do + enc <- goAnomaEncode [message] callStdlib StdlibVerifyDetached [ byteArrayPayload "verifyDetachedSig" sig, - goAnomaEncode [message], + enc, byteArrayPayload "verifyDetachedPubKey" pubKey ] _ -> impossible - goAnomaSign :: [Term Natural] -> Term Natural + goAnomaSign :: [Term Natural] -> Sem r (Term Natural) goAnomaSign = \case - [message, privKey] -> - opReplace - "callMkByteArrayOnSignResult" - (closurePath ArgsTuple) - ( callStdlib - StdlibSign - [ goAnomaEncode [message], - byteArrayPayload "anomaSignPrivKeyTail" privKey - ] - ) - (opAddress "stack" emptyPath) - >># goReturnByteArray + [message, privKey] -> do + enc <- goAnomaEncode [message] + stdcall <- + callStdlib + StdlibSign + [ enc, + byteArrayPayload "anomaSignPrivKeyTail" privKey + ] + return $ + opReplace + "callMkByteArrayOnSignResult" + (closurePath ArgsTuple) + stdcall + (opAddress "stack" emptyPath) + >># goReturnByteArray _ -> impossible where - goReturnByteArray :: Term Natural - goReturnByteArray = mkByteArray (callStdlib StdlibLengthBytes [signResult]) signResult + goReturnByteArray :: Sem r (Term Natural) + goReturnByteArray = do + res <- callStdlib StdlibLengthBytes [signResult] + return $ mkByteArray res signResult signResult :: Term Natural signResult = opAddress "sign-result" (closurePath ArgsTuple) - goAnomaSignDetached :: [Term Natural] -> Term Natural + goAnomaSignDetached :: [Term Natural] -> Sem r (Term Natural) goAnomaSignDetached = \case - [message, privKeyByteArray] -> - mkByteArray - (nockNatLiteral (integerToNatural (toInteger E.signatureLength))) - ( callStdlib - StdlibSignDetached - [ goAnomaEncode [message], - byteArrayPayload "privKeyByteArrayTail" privKeyByteArray - ] - ) + [message, privKeyByteArray] -> do + enc <- goAnomaEncode [message] + stdcall <- + callStdlib + StdlibSignDetached + [ enc, + byteArrayPayload "privKeyByteArrayTail" privKeyByteArray + ] + return $ + mkByteArray + (nockNatLiteral (integerToNatural (toInteger E.signatureLength))) + stdcall _ -> impossible goAnomaByteArrayToAnomaContents :: [Term Natural] -> Term Natural @@ -620,19 +656,24 @@ compile = \case -- anomaDecode <$> verify signedMessage pubKey -- -- verify returns a `Maybe Nat` that is `Just msg` if the signedMessage is verified. - goAnomaVerifyWithMessage :: [Term Natural] -> Term Natural + goAnomaVerifyWithMessage :: [Term Natural] -> Sem r (Term Natural) goAnomaVerifyWithMessage = \case - [signedMessage, pubKey] -> - opReplace - "callDecodeFromVerify-args" - (closurePath ArgsTuple) - (callStdlib StdlibVerify [byteArrayPayload "signedMessageByteArray" signedMessage, byteArrayPayload "pubKeyByteArray" pubKey]) - (opAddress "stack" emptyPath) - >># goDecodeResult + [signedMessage, pubKey] -> do + stdcall <- callStdlib StdlibVerify [byteArrayPayload "signedMessageByteArray" signedMessage, byteArrayPayload "pubKeyByteArray" pubKey] + return $ + opReplace + "callDecodeFromVerify-args" + (closurePath ArgsTuple) + stdcall + (opAddress "stack" emptyPath) + >># goDecodeResult _ -> impossible where - goDecodeResult :: Term Natural - goDecodeResult = branch (OpIsCell # verifyResult) goDecodeResultJust goDecodeResultNothing + goDecodeResult :: Sem r (Term Natural) + goDecodeResult = do + decJust <- goDecodeResultJust + return $ + branch (OpIsCell # verifyResult) decJust goDecodeResultNothing -- just x is represented as [nil x] so the payload of just is always at index 1. justPayloadPath :: Path @@ -643,13 +684,15 @@ compile = \case _indexTupleArgsIndex = 1 } - goDecodeResultJust :: Term Natural - goDecodeResultJust = - opReplace - "putDecodeResultInJust" - justPayloadPath - (callStdlib StdlibDecode [opAddress "verify-result-just" (closurePath ArgsTuple ++ justPayloadPath)]) - verifyResult + goDecodeResultJust :: Sem r (Term Natural) + goDecodeResultJust = do + stdcall <- callStdlib StdlibDecode [opAddress "verify-result-just" (closurePath ArgsTuple ++ justPayloadPath)] + return $ + opReplace + "putDecodeResultInJust" + justPayloadPath + stdcall + verifyResult goDecodeResultNothing :: Term Natural goDecodeResultNothing = verifyResult @@ -676,15 +719,15 @@ compile = \case where goPrimBinop :: Tree.BinaryOp -> [Term Natural] -> Sem r (Term Natural) goPrimBinop op args = case op of - Tree.OpIntAdd -> return (callStdlib StdlibAdd args) - Tree.OpIntSub -> return (callStdlib StdlibSub args) - Tree.OpIntMul -> return (callStdlib StdlibMul args) - Tree.OpIntDiv -> return (callStdlib StdlibDiv args) - Tree.OpIntMod -> return (callStdlib StdlibMod args) - Tree.OpBool Tree.OpIntLt -> return (callStdlib StdlibLt args) - Tree.OpBool Tree.OpIntLe -> return (callStdlib StdlibLe args) + Tree.OpIntAdd -> callStdlib StdlibAdd args + Tree.OpIntSub -> callStdlib StdlibSub args + Tree.OpIntMul -> callStdlib StdlibMul args + Tree.OpIntDiv -> callStdlib StdlibDiv args + Tree.OpIntMod -> callStdlib StdlibMod args + Tree.OpBool Tree.OpIntLt -> callStdlib StdlibLt args + Tree.OpBool Tree.OpIntLe -> callStdlib StdlibLe args Tree.OpBool Tree.OpEq -> testEq _nodeBinopArg1 _nodeBinopArg2 - Tree.OpStrConcat -> return (callStdlib StdlibCatBytes args) + Tree.OpStrConcat -> callStdlib StdlibCatBytes args Tree.OpFieldAdd -> fieldErr Tree.OpFieldSub -> fieldErr Tree.OpFieldMul -> fieldErr @@ -743,23 +786,26 @@ opAddress' x = evaluated $ (opQuote "opAddress'" OpAddress) # x -- [a [b [c 0]]] -> [a [b c]] -- len = quote 3 -- TODO lst is being evaluated three times! -listToTuple :: Term Natural -> Term Natural -> Term Natural -listToTuple lst len = +listToTuple :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) +listToTuple lst len = do -- posOfLast uses stdlib so when it is evaulated the stdlib must be in the -- subject lst must also be evaluated against the standard subject. We achieve -- this by evaluating `lst #. posOfLastOffset` in `t1`. The address that -- posOfLastOffset now points to must be shifted by [L] to make it relative to -- `lst`. - let posOfLastOffset = appendRights [L] (dec len) - posOfLast = appendRights emptyPath (dec len) - t1 = (lst #. posOfLastOffset) >># (opAddress' (OpAddress # [R])) >># (opAddress "listToTupleLast" [L]) - in OpIf # isZero len # lst # (replaceSubterm' lst posOfLast t1) + posOfLastOffset <- appendRights [L] =<< dec len + posOfLast <- appendRights emptyPath =<< dec len + let t1 = (lst #. posOfLastOffset) >># (opAddress' (OpAddress # [R])) >># (opAddress "listToTupleLast" [L]) + return $ + OpIf # isZero len # lst # (replaceSubterm' lst posOfLast t1) argsTuplePlaceholder :: Text -> Term Natural argsTuplePlaceholder txt = nockNilTagged ("argsTuplePlaceholder-" <> txt) -appendRights :: Path -> Term Natural -> Term Natural -appendRights path n = dec (mul (pow2 n) (OpInc # OpQuote # path)) +appendRights :: (Member (Reader CompilerCtx) r) => Path -> Term Natural -> Sem r (Term Natural) +appendRights path n = do + n' <- pow2 n + mul n' (OpInc # OpQuote # path) >>= dec withTemp :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => @@ -814,10 +860,10 @@ appendToTuple :: Term Natural -> Term Natural -> Term Natural -> Term Natural -> appendToTuple xs lenXs ys lenYs = OpIf # isZero lenYs # listToTuple xs lenXs # append xs lenXs ys -append :: Term Natural -> Term Natural -> Term Natural -> Term Natural -append xs lenXs ys = - let posOfXsNil = appendRights emptyPath lenXs - in replaceSubterm' xs posOfXsNil ys +append :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Term Natural -> Sem r (Term Natural) +append xs lenXs ys = do + posOfXsNil <- appendRights emptyPath lenXs + return $ replaceSubterm' xs posOfXsNil ys extendClosure :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => @@ -828,8 +874,8 @@ extendClosure Tree.NodeExtendClosure {..} = do closure <- compile _nodeExtendClosureFun let argsNum = getClosureField ClosureArgsNum closure oldArgs = getClosureField ClosureArgs closure - allArgs = append oldArgs argsNum (remakeList args) - newArgsNum = add argsNum (nockIntegralLiteral (length _nodeExtendClosureArgs)) + allArgs <- append oldArgs argsNum (remakeList args) + newArgsNum <- add argsNum (nockIntegralLiteral (length _nodeExtendClosureArgs)) return . makeClosure $ \case WrapperCode -> getClosureField WrapperCode closure RawCode -> getClosureField RawCode closure @@ -855,21 +901,23 @@ extendClosure Tree.NodeExtendClosure {..} = do -- @ L] :: this whole replace is editing what's at axis L, i.e. what was pushed -- ] -- ] -callStdlib :: StdlibFunction -> [Term Natural] -> Term Natural -callStdlib fun args = +callStdlib :: (Member (Reader CompilerCtx) r) => StdlibFunction -> [Term Natural] -> Sem r (Term Natural) +callStdlib fun args = do + stdpath <- stackPath StandardLibrary let fPath = stdlibPath fun - getFunCode = opAddress "callStdlibFunCode" (stackPath StandardLibrary) >># fPath - adjustArgs = case nonEmpty args of - Just args' -> opReplace "callStdlib-args" (closurePath ArgsTuple) ((opAddress "stdlibR" [R]) >># foldTerms args') (opAddress "stdlibL" [L]) + getFunCode = opAddress "callStdlibFunCode" stdpath >># fPath + argsPath <- stackPath ArgsTuple + let adjustArgs = case nonEmpty args of + Just args' -> opReplace "callStdlib-args" argsPath ((opAddress "stdlibR" [R]) >># foldTerms args') (opAddress "stdlibL" [L]) Nothing -> opAddress "adjustArgsNothing" [L] callFn = opCall "callStdlib" (closurePath WrapperCode) adjustArgs - callCell = set cellCall (Just meta) (OpPush #. (getFunCode # callFn)) meta = StdlibCall { _stdlibCallArgs = foldTermsOrNil args, _stdlibCallFunction = fun } - in TermCell callCell + callCell = set cellCall (Just meta) (OpPush #. (getFunCode # callFn)) + in return $ TermCell callCell constUnit :: Term Natural constUnit = constVoid @@ -935,10 +983,6 @@ fieldErr = unsupported "the field type" cairoErr :: a cairoErr = unsupported "cairo builtins" --- | Computes a - b -sub :: Term Natural -> Term Natural -> Term Natural -sub a b = callStdlib StdlibSub [a, b] - makeList :: (Foldable f) => f (Term Natural) -> Term Natural makeList ts = foldTerms (toList ts `prependList` pure (nockNilTagged "makeList")) @@ -1021,7 +1065,7 @@ runCompilerWith opts constrs moduleFuns mainFun = makeAnomaFun return ( _compilerFunctionId, FunctionInfo - { _functionInfoPath = indexInStack FunctionsLibrary i, + { _functionInfoPath = indexStack FunctionsLibrary i, _functionInfoArity = _compilerFunctionArity, _functionInfoName = _compilerFunctionName } @@ -1069,9 +1113,6 @@ builtinFunction = \case _compilerFunctionName = "builtinPlaceholderName" } -closurePath :: AnomaCallablePathId -> Path -closurePath = stackPath - -- | Call a function. Arguments to the function are assumed to be in the ArgsTuple stack -- TODO what about temporary stack? callFun :: @@ -1278,19 +1319,22 @@ getConstructorMemRep tag = (^. constructorInfoMemRep) <$> getConstructorInfo tag crash :: Term Natural crash = ("crash" @ OpAddress # OpAddress # OpAddress) -mul :: Term Natural -> Term Natural -> Term Natural +mul :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) mul a b = callStdlib StdlibMul [a, b] -pow2 :: Term Natural -> Term Natural -pow2 = callStdlib StdlibPow2 . pure +pow2 :: (Member (Reader CompilerCtx) r) => Term Natural -> Sem r (Term Natural) +pow2 x = callStdlib StdlibPow2 [x] -add :: Term Natural -> Term Natural -> Term Natural +add :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) add a b = callStdlib StdlibAdd [a, b] -dec :: Term Natural -> Term Natural -dec = callStdlib StdlibDec . pure +sub :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) +sub a b = callStdlib StdlibSub [a, b] + +dec :: (Member (Reader CompilerCtx) r) => Term Natural -> Sem r (Term Natural) +dec x = callStdlib StdlibDec [x] -intToUInt8 :: Term Natural -> Term Natural +intToUInt8 :: (Member (Reader CompilerCtx) r) => Term Natural -> Sem r (Term Natural) intToUInt8 i = callStdlib StdlibMod [i, nockIntegralLiteral @Natural (2 ^ uint8Size)] where uint8Size :: Natural From f75880e7035d81fe172dfd8562a5f3ab161974e2 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Tue, 1 Oct 2024 19:29:25 +0200 Subject: [PATCH 03/18] fix compilation --- .../Compiler/Nockma/Translation/FromTree.hs | 67 +++++++----- test/Nockma/Eval/Positive.hs | 100 ++++++++++-------- 2 files changed, 97 insertions(+), 70 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 5d594ed058..ddb8d44d1e 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -13,6 +13,7 @@ module Juvix.Compiler.Nockma.Translation.FromTree closurePath, foldTermsOrNil, add, + sub, dec, mul, pow2, @@ -29,6 +30,8 @@ module Juvix.Compiler.Nockma.Translation.FromTree opAddress', replaceSubterm', runCompilerWith, + emptyCompilerCtx, + CompilerCtx (..), ) where @@ -127,6 +130,17 @@ data CompilerCtx = CompilerCtx _compilerOptions :: CompilerOptions } +emptyCompilerCtx :: CompilerCtx +emptyCompilerCtx = + CompilerCtx + { _compilerFunctionInfos = mempty, + _compilerConstructorInfos = mempty, + _compilerTempVarMap = mempty, + _compilerTempVarsNum = 0, + _compilerStackHeight = 0, + _compilerOptions = CompilerOptions True + } + data ConstructorInfo = ConstructorInfo { _constructorInfoArity :: Natural, _constructorInfoMemRep :: NockmaMemRep @@ -212,11 +226,6 @@ stackPath s = do h <- asks (^. compilerStackHeight) return $ indexStack (fromIntegral (h + fromEnum s)) -indexInStack :: (Member (Reader CompilerCtx) r) => AnomaCallablePathId -> Natural -> Sem r Path -indexInStack s idx = do - sp <- stackPath s - return $ sp ++ indexStack idx - runCompilerFunction :: CompilerCtx -> CompilerFunction -> Term Natural runCompilerFunction ctx fun = run @@ -359,13 +368,13 @@ anomaCallableClosureWrapper = do let closureArgsNum :: Term Natural = getClosureFieldInSubject ClosureArgsNum closureTotalArgsNum :: Term Natural = getClosureFieldInSubject ClosureTotalArgsNum remainingArgsNum <- sub closureTotalArgsNum closureArgsNum - let appendAndReplaceArgsTuple = - replaceArgsWithTerm "anomaCallableClosureWrapper" $ - appendToTuple - (getClosureFieldInSubject ClosureArgs) - closureArgsNum - (getClosureFieldInSubject ArgsTuple) - remainingArgsNum + tup <- + appendToTuple + (getClosureFieldInSubject ClosureArgs) + closureArgsNum + (getClosureFieldInSubject ArgsTuple) + remainingArgsNum + let appendAndReplaceArgsTuple = replaceArgsWithTerm "anomaCallableClosureWrapper" tup closureArgsIsEmpty = isZero closureArgsNum adjustArgs = OpIf # closureArgsIsEmpty # (opAddress "wrapperSubject" emptyPath) # appendAndReplaceArgsTuple in return $ opCall "closureWrapper" (closurePath RawCode) adjustArgs @@ -609,13 +618,14 @@ compile = \case [ enc, byteArrayPayload "anomaSignPrivKeyTail" privKey ] + ret <- goReturnByteArray return $ opReplace "callMkByteArrayOnSignResult" (closurePath ArgsTuple) stdcall (opAddress "stack" emptyPath) - >># goReturnByteArray + >># ret _ -> impossible where goReturnByteArray :: Sem r (Term Natural) @@ -660,13 +670,14 @@ compile = \case goAnomaVerifyWithMessage = \case [signedMessage, pubKey] -> do stdcall <- callStdlib StdlibVerify [byteArrayPayload "signedMessageByteArray" signedMessage, byteArrayPayload "pubKeyByteArray" pubKey] + res <- goDecodeResult return $ opReplace "callDecodeFromVerify-args" (closurePath ArgsTuple) stdcall (opAddress "stack" emptyPath) - >># goDecodeResult + >># res _ -> impossible where goDecodeResult :: Sem r (Term Natural) @@ -739,8 +750,9 @@ compile = \case fpath <- getFunctionPath fun farity <- getFunctionArity fun args <- mapM compile _nodeAllocClosureArgs + wrapper <- anomaCallableClosureWrapper return . makeClosure $ \case - WrapperCode -> OpQuote # anomaCallableClosureWrapper + WrapperCode -> OpQuote # wrapper ArgsTuple -> OpQuote # argsTuplePlaceholder "goAllocClosure" FunctionsLibrary -> OpQuote # functionsLibraryPlaceHolder RawCode -> opAddress "allocClosureFunPath" (fpath <> closurePath RawCode) @@ -763,8 +775,8 @@ compile = \case closure <- compile f let argsNum = getClosureField ClosureArgsNum closure oldArgs = getClosureField ClosureArgs closure - allArgs = appendToTuple oldArgs argsNum (foldTermsOrNil newargs) (nockIntegralLiteral (length newargs)) - newSubject = replaceSubject $ \case + allArgs <- appendToTuple oldArgs argsNum (foldTermsOrNil newargs) (nockIntegralLiteral (length newargs)) + let newSubject = replaceSubject $ \case WrapperCode -> Just (getClosureField RawCode closure) -- We Want RawCode because we already have all args. ArgsTuple -> Just allArgs RawCode -> Just (OpQuote # nockNilTagged "callClosure-RawCode") @@ -856,9 +868,17 @@ nockIntegralLiteral = (OpQuote #) . toNock @Natural . fromIntegral -- the result is a tuple. -- NOTE: xs occurs twice, but that's fine because each occurrence is in a -- different if branch. -appendToTuple :: Term Natural -> Term Natural -> Term Natural -> Term Natural -> Term Natural -appendToTuple xs lenXs ys lenYs = - OpIf # isZero lenYs # listToTuple xs lenXs # append xs lenXs ys +appendToTuple :: + (Member (Reader CompilerCtx) r) => + Term Natural -> + Term Natural -> + Term Natural -> + Term Natural -> + Sem r (Term Natural) +appendToTuple xs lenXs ys lenYs = do + tp1 <- listToTuple xs lenXs + tp2 <- append xs lenXs ys + return $ OpIf # isZero lenYs # tp1 # tp2 append :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Term Natural -> Sem r (Term Natural) append xs lenXs ys = do @@ -1000,12 +1020,9 @@ runCompilerWith opts constrs moduleFuns mainFun = makeAnomaFun compilerCtx :: CompilerCtx compilerCtx = - CompilerCtx + emptyCompilerCtx { _compilerFunctionInfos = functionInfos, _compilerConstructorInfos = constrs, - _compilerTempVarMap = mempty, - _compilerTempVarsNum = 0, - _compilerStackHeight = 0, _compilerOptions = opts } @@ -1065,7 +1082,7 @@ runCompilerWith opts constrs moduleFuns mainFun = makeAnomaFun return ( _compilerFunctionId, FunctionInfo - { _functionInfoPath = indexStack FunctionsLibrary i, + { _functionInfoPath = pathFromEnum FunctionsLibrary ++ indexStack i, _functionInfoArity = _compilerFunctionArity, _functionInfoName = _compilerFunctionName } diff --git a/test/Nockma/Eval/Positive.hs b/test/Nockma/Eval/Positive.hs index f304020955..19425ef938 100644 --- a/test/Nockma/Eval/Positive.hs +++ b/test/Nockma/Eval/Positive.hs @@ -91,23 +91,29 @@ compilerTest :: Text -> Term Natural -> Check () -> Bool -> Test compilerTest n mainFun _testCheck _evalInterceptStdlibCalls = anomaTest n mainFun [] _testCheck _evalInterceptStdlibCalls +compilerTestM :: Text -> Sem '[Reader CompilerCtx] (Term Natural) -> Check () -> Bool -> Test +compilerTestM n mainFun = + compilerTest n (run . runReader emptyCompilerCtx $ mainFun) + serializationTest :: Term Natural -> Term Natural -> [Test] -serializationTest jamTerm cueTerm = +serializationTest jamTerm cueTerm = run . runReader emptyCompilerCtx $ do let jamCheck :: Check () = eqNock cueTerm - jamCall :: Term Natural = callStdlib StdlibEncode [OpQuote # jamTerm] - cueCall :: Term Natural = callStdlib StdlibDecode [OpQuote # cueTerm] - cueCheck :: Check () = eqNock jamTerm + jamCall :: Term Natural <- callStdlib StdlibEncode [OpQuote # jamTerm] + cueCall :: Term Natural <- callStdlib StdlibDecode [OpQuote # cueTerm] + let cueCheck :: Check () = eqNock jamTerm ppJamTerm :: Text = ppPrint jamTerm ppCueTerm :: Text = ppPrint cueTerm - in [ anomaTest ("jam " <> ppJamTerm <> " == " <> ppCueTerm) jamCall [] jamCheck True, - anomaTest ("cue " <> ppCueTerm <> " == " <> ppJamTerm) cueCall [] cueCheck True - ] + return + [ anomaTest ("jam " <> ppJamTerm <> " == " <> ppCueTerm) jamCall [] jamCheck True, + anomaTest ("cue " <> ppCueTerm <> " == " <> ppJamTerm) cueCall [] cueCheck True + ] -- | Test decode (encode t) = t serializationIdTest :: Text -> Term Natural -> Test -serializationIdTest n jamTerm = - let call :: Term Natural = callStdlib StdlibDecode [callStdlib StdlibEncode [OpQuote # jamTerm]] - in anomaTest (n <> ": " <> "cue . jam = id") call [] (eqNock jamTerm) True +serializationIdTest n jamTerm = run . runReader emptyCompilerCtx $ do + arg <- callStdlib StdlibEncode [OpQuote # jamTerm] + call <- callStdlib StdlibDecode [arg] + return $ anomaTest (n <> ": " <> "cue . jam = id") call [] (eqNock jamTerm) True withAssertErrKeyNotInStorage :: Test -> Test withAssertErrKeyNotInStorage Test {..} = @@ -143,6 +149,10 @@ anomaTest n mainFun args _testCheck _evalInterceptStdlibCalls = _testAssertEvalError :: Maybe (NockEvalError Natural -> Assertion) = Nothing in Test {..} +anomaTestM :: Text -> Sem '[Reader CompilerCtx] (Term Natural) -> [Term Natural] -> Check () -> Bool -> Test +anomaTestM n mainFun = + anomaTest n (run . runReader emptyCompilerCtx $ mainFun) + testWithStorage :: [(Term Natural, Term Natural)] -> Text -> Term Natural -> Term Natural -> Check () -> Test testWithStorage s = Test defaultEvalOptions Nothing (Storage (HashMap.fromList (first StorageKey <$> s))) @@ -152,17 +162,17 @@ test = testWithStorage [] anomaCallingConventionTests :: [Test] anomaCallingConventionTests = [True, False] - <**> [ anomaTest "stdlib add" (add (nockNatLiteral 1) (nockNatLiteral 2)) [] (eqNock [nock| 3 |]), - anomaTest "stdlib add with arg" (add (nockNatLiteral 1) (nockNatLiteral 2)) [nockNatLiteral 1] (eqNock [nock| 3 |]), + <**> [ anomaTestM "stdlib add" (add (nockNatLiteral 1) (nockNatLiteral 2)) [] (eqNock [nock| 3 |]), + anomaTestM "stdlib add with arg" (add (nockNatLiteral 1) (nockNatLiteral 2)) [nockNatLiteral 1] (eqNock [nock| 3 |]), let args = [nockNatLiteral 3, nockNatLiteral 1] fx = FunctionCtx { _functionCtxArity = fromIntegral (length args) } - in run . runReader fx $ do + in run . runReader fx . runReader emptyCompilerCtx $ do p0 <- pathToArg 0 p1 <- pathToArg 1 - return (anomaTest "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 |])) ] serializationTests :: [Test] @@ -225,32 +235,32 @@ serializationTests = juvixCallingConventionTests :: [Test] juvixCallingConventionTests = [True, False] - <**> [ compilerTest "stdlib add" (add (nockNatLiteral 1) (nockNatLiteral 2)) (eqNock [nock| 3 |]), - compilerTest "stdlib dec" (dec (nockNatLiteral 1)) (eqNock [nock| 0 |]), - compilerTest "stdlib mul" (mul (nockNatLiteral 2) (nockNatLiteral 3)) (eqNock [nock| 6 |]), - compilerTest "stdlib sub" (sub (nockNatLiteral 2) (nockNatLiteral 1)) (eqNock [nock| 1 |]), - compilerTest "stdlib div" (callStdlib StdlibDiv [nockNatLiteral 10, nockNatLiteral 3]) (eqNock [nock| 3 |]), - compilerTest "stdlib mod" (callStdlib StdlibMod [nockNatLiteral 3, nockNatLiteral 2]) (eqNock [nock| 1 |]), - compilerTest "stdlib le" (callStdlib StdlibLe [nockNatLiteral 3, nockNatLiteral 3]) (eqNock [nock| true |]), - compilerTest "stdlib lt" (callStdlib StdlibLt [nockNatLiteral 3, nockNatLiteral 3]) (eqNock [nock| false |]), - compilerTest "stdlib pow2" (pow2 (nockNatLiteral 3)) (eqNock [nock| 8 |]), - compilerTest "stdlib nested" (dec (dec (nockNatLiteral 20))) (eqNock [nock| 18 |]), - compilerTest "append rights - empty" (appendRights emptyPath (nockNatLiteral 3)) (eqNock (toNock [R, R, R])), - compilerTest "append rights" (appendRights [L, L] (nockNatLiteral 3)) (eqNock (toNock [L, L, R, R, R])), + <**> [ compilerTestM "stdlib add" (add (nockNatLiteral 1) (nockNatLiteral 2)) (eqNock [nock| 3 |]), + compilerTestM "stdlib dec" (dec (nockNatLiteral 1)) (eqNock [nock| 0 |]), + compilerTestM "stdlib mul" (mul (nockNatLiteral 2) (nockNatLiteral 3)) (eqNock [nock| 6 |]), + compilerTestM "stdlib sub" (sub (nockNatLiteral 2) (nockNatLiteral 1)) (eqNock [nock| 1 |]), + compilerTestM "stdlib div" (callStdlib StdlibDiv [nockNatLiteral 10, nockNatLiteral 3]) (eqNock [nock| 3 |]), + compilerTestM "stdlib mod" (callStdlib StdlibMod [nockNatLiteral 3, nockNatLiteral 2]) (eqNock [nock| 1 |]), + compilerTestM "stdlib le" (callStdlib StdlibLe [nockNatLiteral 3, nockNatLiteral 3]) (eqNock [nock| true |]), + compilerTestM "stdlib lt" (callStdlib StdlibLt [nockNatLiteral 3, nockNatLiteral 3]) (eqNock [nock| false |]), + compilerTestM "stdlib pow2" (pow2 (nockNatLiteral 3)) (eqNock [nock| 8 |]), + compilerTestM "stdlib nested" (dec =<< (dec (nockNatLiteral 20))) (eqNock [nock| 18 |]), + compilerTestM "append rights - empty" (appendRights emptyPath (nockNatLiteral 3)) (eqNock (toNock [R, R, R])), + compilerTestM "append rights" (appendRights [L, L] (nockNatLiteral 3)) (eqNock (toNock [L, L, R, R, R])), compilerTest "opAddress" ((OpQuote # (foldTerms (toNock @Natural <$> (5 :| [6, 1])))) >># opAddress' (OpQuote # [R, R])) (eqNock (toNock @Natural 1)), compilerTest "foldTermsOrNil (empty)" (foldTermsOrNil []) (eqNock (nockNilTagged "expected-result")), let l :: NonEmpty Natural = 1 :| [2] l' :: NonEmpty (Term Natural) = nockNatLiteral <$> l in compilerTest "foldTermsOrNil (non-empty)" (foldTermsOrNil (toList l')) (eqNock (foldTerms (toNock @Natural <$> l))), let l :: NonEmpty (Term Natural) = toNock <$> nonEmpty' [1 :: Natural .. 3] - in compilerTest "list to tuple" (listToTuple (OpQuote # makeList (toList l)) (nockIntegralLiteral (length l))) $ + in compilerTestM "list to tuple" (listToTuple (OpQuote # makeList (toList l)) (nockIntegralLiteral (length l))) $ eqNock (foldTerms l), let l :: Term Natural = OpQuote # foldTerms (toNock @Natural <$> (1 :| [2, 3])) in compilerTest "replaceSubterm'" (replaceSubterm' l (OpQuote # toNock [R]) (OpQuote # (toNock @Natural 999))) (eqNock (toNock @Natural 1 # toNock @Natural 999)), let lst :: [Term Natural] = toNock @Natural <$> [1, 2, 3] len = nockIntegralLiteral (length lst) l :: Term Natural = OpQuote # makeList lst - in compilerTest "append" (append l len l) (eqNock (makeList (lst ++ lst))), + in compilerTestM "append" (append l len l) (eqNock (makeList (lst ++ lst))), let l :: [Natural] = [1, 2] r :: NonEmpty Natural = 3 :| [4] res :: Term Natural = foldTerms (toNock <$> prependList l r) @@ -258,31 +268,31 @@ juvixCallingConventionTests = lenR :: Term Natural = nockIntegralLiteral (length r) lstL = OpQuote # makeList (map toNock l) tupR = OpQuote # foldTerms (toNock <$> r) - in compilerTest "appendToTuple (left non-empty, right non-empty)" (appendToTuple lstL lenL tupR lenR) (eqNock res), + in compilerTestM "appendToTuple (left non-empty, right non-empty)" (appendToTuple lstL lenL tupR lenR) (eqNock res), let l :: NonEmpty Natural = 1 :| [2] res :: Term Natural = foldTerms (toNock <$> l) lenL :: Term Natural = nockIntegralLiteral (length l) lstL = OpQuote # makeList (toNock <$> (toList l)) - in compilerTest "appendToTuple (left non-empty, right empty)" (appendToTuple lstL lenL (OpQuote # nockNilTagged "appendToTuple") (nockNatLiteral 0)) (eqNock res), + in compilerTestM "appendToTuple (left non-empty, right empty)" (appendToTuple lstL lenL (OpQuote # nockNilTagged "appendToTuple") (nockNatLiteral 0)) (eqNock res), let r :: NonEmpty Natural = 3 :| [4] res :: Term Natural = foldTerms (toNock <$> r) lenR :: Term Natural = nockIntegralLiteral (length r) tupR = OpQuote # foldTerms (toNock <$> r) - in compilerTest "appendToTuple (left empty, right-nonempty)" (appendToTuple (OpQuote # nockNilTagged "test-appendtotuple") (nockNatLiteral 0) tupR lenR) (eqNock res), - compilerTest "stdlib cat" (callStdlib StdlibCatBytes [nockNatLiteral 2, nockNatLiteral 1]) (eqNock [nock| 258 |]), - compilerTest "fold bytes empty" (callStdlib StdlibFoldBytes [OpQuote # makeList []]) (eqNock [nock| 0 |]), - compilerTest "fold bytes [1, 0, 0] == 1" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [1, 0, 0])]) (eqNock [nock| 1 |]), - compilerTest "fold bytes single byte" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [123])]) (eqNock [nock| 123 |]), - compilerTest "fold bytes [0, 1] == 256" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [0, 1])]) (eqNock [nock| 256 |]), - compilerTest "fold bytes [5, 1] == 261" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [5, 1])]) (eqNock [nock| 261 |]), - compilerTest "fold bytes [0, 1, 0] == 256" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [0, 1, 0])]) (eqNock [nock| 256 |]), - compilerTest "length [] == 0" (callStdlib StdlibLengthList [OpQuote # makeList []]) (eqNock [nock| 0 |]), - compilerTest "length [10] == 1" (callStdlib StdlibLengthList [OpQuote # makeList [[nock| 10 |]]]) (eqNock [nock| 1 |]), - compilerTest "length [[1 2, 3], 0] == 2" (callStdlib StdlibLengthList [OpQuote # makeList [[nock| [1 2 3] |], [nock| 0 |]]]) (eqNock [nock| 2 |]), - compilerTest "length-bytes 256 == 2" (callStdlib StdlibLengthBytes [nockNatLiteral 256]) (eqNock [nock| 2 |]), - compilerTest "length-bytes 255 == 1" (callStdlib StdlibLengthBytes [nockNatLiteral 255]) (eqNock [nock| 1 |]), - compilerTest "length-bytes 1 == 1" (callStdlib StdlibLengthBytes [nockNatLiteral 1]) (eqNock [nock| 1 |]), - compilerTest "length-bytes 0 == 0" (callStdlib StdlibLengthBytes [nockNatLiteral 0]) (eqNock [nock| 0 |]) + in compilerTestM "appendToTuple (left empty, right-nonempty)" (appendToTuple (OpQuote # nockNilTagged "test-appendtotuple") (nockNatLiteral 0) tupR lenR) (eqNock res), + compilerTestM "stdlib cat" (callStdlib StdlibCatBytes [nockNatLiteral 2, nockNatLiteral 1]) (eqNock [nock| 258 |]), + compilerTestM "fold bytes empty" (callStdlib StdlibFoldBytes [OpQuote # makeList []]) (eqNock [nock| 0 |]), + compilerTestM "fold bytes [1, 0, 0] == 1" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [1, 0, 0])]) (eqNock [nock| 1 |]), + compilerTestM "fold bytes single byte" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [123])]) (eqNock [nock| 123 |]), + compilerTestM "fold bytes [0, 1] == 256" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [0, 1])]) (eqNock [nock| 256 |]), + compilerTestM "fold bytes [5, 1] == 261" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [5, 1])]) (eqNock [nock| 261 |]), + compilerTestM "fold bytes [0, 1, 0] == 256" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [0, 1, 0])]) (eqNock [nock| 256 |]), + compilerTestM "length [] == 0" (callStdlib StdlibLengthList [OpQuote # makeList []]) (eqNock [nock| 0 |]), + compilerTestM "length [10] == 1" (callStdlib StdlibLengthList [OpQuote # makeList [[nock| 10 |]]]) (eqNock [nock| 1 |]), + compilerTestM "length [[1 2, 3], 0] == 2" (callStdlib StdlibLengthList [OpQuote # makeList [[nock| [1 2 3] |], [nock| 0 |]]]) (eqNock [nock| 2 |]), + compilerTestM "length-bytes 256 == 2" (callStdlib StdlibLengthBytes [nockNatLiteral 256]) (eqNock [nock| 2 |]), + compilerTestM "length-bytes 255 == 1" (callStdlib StdlibLengthBytes [nockNatLiteral 255]) (eqNock [nock| 1 |]), + compilerTestM "length-bytes 1 == 1" (callStdlib StdlibLengthBytes [nockNatLiteral 1]) (eqNock [nock| 1 |]), + compilerTestM "length-bytes 0 == 0" (callStdlib StdlibLengthBytes [nockNatLiteral 0]) (eqNock [nock| 0 |]) ] unitTests :: [Test] From aa95307f0526d7757f2efb1e457213665026ce39 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Wed, 2 Oct 2024 17:49:54 +0200 Subject: [PATCH 04/18] fix paths --- .../Compiler/Nockma/Translation/FromTree.hs | 171 +++++++++--------- 1 file changed, 83 insertions(+), 88 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index ddb8d44d1e..963dffb7e1 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -226,6 +226,11 @@ stackPath s = do h <- asks (^. compilerStackHeight) return $ indexStack (fromIntegral (h + fromEnum s)) +getSubjectBasePath :: (Member (Reader CompilerCtx) r) => Sem r Path +getSubjectBasePath = do + h <- asks (^. compilerStackHeight) + return $ indexStack (fromIntegral h) + runCompilerFunction :: CompilerCtx -> CompilerFunction -> Term Natural runCompilerFunction ctx fun = run @@ -374,13 +379,14 @@ anomaCallableClosureWrapper = do closureArgsNum (getClosureFieldInSubject ArgsTuple) remainingArgsNum - let appendAndReplaceArgsTuple = replaceArgsWithTerm "anomaCallableClosureWrapper" tup - closureArgsIsEmpty = isZero closureArgsNum - adjustArgs = OpIf # closureArgsIsEmpty # (opAddress "wrapperSubject" emptyPath) # appendAndReplaceArgsTuple - in return $ opCall "closureWrapper" (closurePath RawCode) adjustArgs - -mainFunctionWrapper :: Term Natural -> Term Natural -mainFunctionWrapper funslib = + appendAndReplaceArgsTuple <- replaceArgsWithTerm "anomaCallableClosureWrapper" tup + subjectBasePath <- getSubjectBasePath + let closureArgsIsEmpty = isZero closureArgsNum + adjustArgs = OpIf # closureArgsIsEmpty # (opAddress "wrapperSubject" subjectBasePath) # appendAndReplaceArgsTuple + return $ opCall "closureWrapper" (closurePath RawCode) adjustArgs + +mainFunctionWrapper :: (Member (Reader CompilerCtx) r) => Term Natural -> Sem r (Term Natural) +mainFunctionWrapper funslib = do -- 1. The Anoma system expects to receive a function of type `ScryId -> Transaction` -- -- 2. The ScryId is only used to construct the argument to the Scry operation @@ -392,12 +398,11 @@ mainFunctionWrapper funslib = -- when anomaGet is compiled. -- -- 4. If the Anoma system expectation changes then this code must be changed. - let captureAnomaGetOrder :: Term Natural - captureAnomaGetOrder = replaceSubject $ \case - AnomaGetOrder -> Just (getClosureFieldInSubject ArgsTuple) - FunctionsLibrary -> Just (OpQuote # funslib) - _ -> Nothing - in opCall "mainFunctionWrapper" (closurePath RawCode) captureAnomaGetOrder + captureAnomaGetOrder <- replaceSubject $ \case + AnomaGetOrder -> Just (getClosureFieldInSubject ArgsTuple) + FunctionsLibrary -> Just (OpQuote # funslib) + _ -> Nothing + return $ opCall "mainFunctionWrapper" (closurePath RawCode) captureAnomaGetOrder compile :: forall r. (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => Tree.Node -> Sem r (Term Natural) compile = \case @@ -497,7 +502,8 @@ compile = \case goSave :: Tree.NodeSave -> Sem r (Term Natural) goSave Tree.NodeSave {..} = do - withTempVar _nodeSaveArg (compile _nodeSaveBody) + arg <- compile _nodeSaveArg + withTempVar arg (compile _nodeSaveBody) goCase :: Tree.NodeCase -> Sem r (Term Natural) goCase c = do @@ -554,10 +560,11 @@ compile = \case goUnop Tree.NodeUnop {..} = case _nodeUnopOpcode of Tree.PrimUnop op -> goPrimUnop op _nodeUnopArg - Tree.OpAssert -> - withTemp _nodeUnopArg $ \ref -> do - arg <- addressTempRef ref - return (branch arg arg crash) + Tree.OpAssert -> do + arg <- compile _nodeUnopArg + withTemp arg $ \ref -> do + tmp <- addressTempRef ref + return (branch tmp tmp crash) Tree.OpFail -> return crash Tree.OpTrace -> do arg <- compile _nodeUnopArg @@ -567,12 +574,13 @@ compile = \case goPrimUnop op arg = case op of Tree.OpShow -> stringsErr "show" Tree.OpStrToInt -> stringsErr "strToInt" - Tree.OpArgsNum -> + Tree.OpArgsNum -> do + arg' <- compile arg withTemp - arg + arg' ( \ref -> do - arg' <- addressTempRef ref - sub (getClosureField ClosureTotalArgsNum arg') (getClosureField ClosureArgsNum arg') + tmp <- addressTempRef ref + sub (getClosureField ClosureTotalArgsNum tmp) (getClosureField ClosureArgsNum tmp) ) Tree.OpIntToField -> fieldErr Tree.OpFieldToInt -> fieldErr @@ -619,6 +627,7 @@ compile = \case byteArrayPayload "anomaSignPrivKeyTail" privKey ] ret <- goReturnByteArray + -- TODO: is this correct? should we adjust paths? return $ opReplace "callMkByteArrayOnSignResult" @@ -670,46 +679,35 @@ compile = \case goAnomaVerifyWithMessage = \case [signedMessage, pubKey] -> do stdcall <- callStdlib StdlibVerify [byteArrayPayload "signedMessageByteArray" signedMessage, byteArrayPayload "pubKeyByteArray" pubKey] - res <- goDecodeResult - return $ - opReplace - "callDecodeFromVerify-args" - (closurePath ArgsTuple) - stdcall - (opAddress "stack" emptyPath) - >># res + withTemp stdcall goDecodeResult _ -> impossible where - goDecodeResult :: Sem r (Term Natural) - goDecodeResult = do - decJust <- goDecodeResultJust + goDecodeResult :: TempRef -> Sem r (Term Natural) + goDecodeResult ref = do + decJust <- goDecodeResultJust ref + res <- addressTempRef ref return $ - branch (OpIsCell # verifyResult) decJust goDecodeResultNothing - - -- just x is represented as [nil x] so the payload of just is always at index 1. - justPayloadPath :: Path - justPayloadPath = - indexTuple - IndexTupleArgs - { _indexTupleArgsLength = 2, - _indexTupleArgsIndex = 1 - } + branch (OpIsCell # res) decJust res - goDecodeResultJust :: Sem r (Term Natural) - goDecodeResultJust = do - stdcall <- callStdlib StdlibDecode [opAddress "verify-result-just" (closurePath ArgsTuple ++ justPayloadPath)] + goDecodeResultJust :: TempRef -> Sem r (Term Natural) + goDecodeResultJust ref = do + refPath <- tempRefPath ref + stdcall <- callStdlib StdlibDecode [opAddress "verify-result-just" (refPath ++ justPayloadPath)] return $ opReplace "putDecodeResultInJust" justPayloadPath stdcall - verifyResult - - goDecodeResultNothing :: Term Natural - goDecodeResultNothing = verifyResult - - verifyResult :: Term Natural - verifyResult = opAddress "verify-result" (closurePath ArgsTuple) + (opAddress "tempRef" refPath) + where + -- just x is represented as [nil x] so the payload of just is always at index 1. + justPayloadPath :: Path + justPayloadPath = + indexTuple + IndexTupleArgs + { _indexTupleArgsLength = 2, + _indexTupleArgsIndex = 1 + } goTrace :: Term Natural -> Sem r (Term Natural) goTrace arg = do @@ -776,17 +774,17 @@ compile = \case let argsNum = getClosureField ClosureArgsNum closure oldArgs = getClosureField ClosureArgs closure allArgs <- appendToTuple oldArgs argsNum (foldTermsOrNil newargs) (nockIntegralLiteral (length newargs)) - let newSubject = replaceSubject $ \case - WrapperCode -> Just (getClosureField RawCode closure) -- We Want RawCode because we already have all args. - ArgsTuple -> Just allArgs - RawCode -> Just (OpQuote # nockNilTagged "callClosure-RawCode") - TempStack -> Just (OpQuote # nockNilTagged "callClosure-TempStack") - FunctionsLibrary -> Nothing - StandardLibrary -> Nothing - ClosureArgs -> Nothing - ClosureTotalArgsNum -> Nothing - ClosureArgsNum -> Nothing - AnomaGetOrder -> Nothing + newSubject <- replaceSubject $ \case + WrapperCode -> Just (getClosureField RawCode closure) -- We Want RawCode because we already have all args. + ArgsTuple -> Just allArgs + RawCode -> Just (OpQuote # nockNilTagged "callClosure-RawCode") + TempStack -> Just (OpQuote # nockNilTagged "callClosure-TempStack") + FunctionsLibrary -> Nothing + StandardLibrary -> Nothing + ClosureArgs -> Nothing + ClosureTotalArgsNum -> Nothing + ClosureArgsNum -> Nothing + AnomaGetOrder -> Nothing return (opCall "callClosure" (closurePath WrapperCode) newSubject) isZero :: Term Natural -> Term Natural @@ -821,18 +819,17 @@ appendRights path n = do withTemp :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => - Tree.Node -> + Term Natural -> (TempRef -> Sem r (Term Natural)) -> Sem r (Term Natural) withTemp value f = do - value' <- compile value stackHeight <- asks (^. compilerStackHeight) body' <- local (over compilerStackHeight (+ 1)) $ f (TempRef stackHeight) - return $ OpPush # value' # body' + return $ OpPush # value # body' withTempVar :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => - Tree.Node -> + Term Natural -> (Sem r (Term Natural)) -> Sem r (Term Natural) withTempVar value cont = withTemp value $ \temp -> do @@ -1010,7 +1007,10 @@ remakeList :: (Foldable l) => l (Term Natural) -> Term Natural remakeList ts = foldTerms (toList ts `prependList` pure (OpQuote # nockNilTagged "remakeList")) runCompilerWith :: CompilerOptions -> ConstructorInfos -> [CompilerFunction] -> CompilerFunction -> AnomaResult -runCompilerWith opts constrs moduleFuns mainFun = makeAnomaFun +runCompilerWith opts constrs moduleFuns mainFun = + AnomaResult + { _anomaClosure = mainClosure + } where libFuns :: [CompilerFunction] libFuns = moduleFuns ++ (builtinFunction <$> allElements) @@ -1062,7 +1062,7 @@ runCompilerWith opts constrs moduleFuns mainFun = makeAnomaFun makeMainFunction c = makeClosure $ \p -> let nockNilHere = nockNilTagged ("makeMainFunction-" <> show p) in case p of - WrapperCode -> mainFunctionWrapper funcsLib + WrapperCode -> run . runReader compilerCtx $ mainFunctionWrapper funcsLib ArgsTuple -> argsTuplePlaceholder "mainFunction" FunctionsLibrary -> functionsLibraryPlaceHolder RawCode -> c @@ -1088,12 +1088,6 @@ runCompilerWith opts constrs moduleFuns mainFun = makeAnomaFun } ) - makeAnomaFun :: AnomaResult - makeAnomaFun = - AnomaResult - { _anomaClosure = mainClosure - } - stdlibPlaceHolder :: Term Natural stdlibPlaceHolder = TermAtom @@ -1148,27 +1142,28 @@ callFunWithArgs :: FunctionId -> [Term Natural] -> Sem r (Term Natural) -callFunWithArgs fun args = (replaceArgs args >>#) <$> callFun fun +callFunWithArgs fun args = do + replArgs <- replaceArgs args + (replArgs >>#) <$> callFun fun -replaceSubject :: (AnomaCallablePathId -> Maybe (Term Natural)) -> Term Natural +replaceSubject :: (Member (Reader CompilerCtx) r) => (AnomaCallablePathId -> Maybe (Term Natural)) -> Sem r (Term Natural) replaceSubject = replaceSubject' "replaceSubject" -replaceSubject' :: Text -> (AnomaCallablePathId -> Maybe (Term Natural)) -> Term Natural -replaceSubject' tag f = - remakeList - [ case f s of - Nothing -> opAddress tag (closurePath s) - Just t' -> t' - | s <- allElements - ] +replaceSubject' :: (Member (Reader CompilerCtx) r) => Text -> (AnomaCallablePathId -> Maybe (Term Natural)) -> Sem r (Term Natural) +replaceSubject' tag f = do + lst <- forM allElements $ \s -> do + case f s of + Nothing -> opAddress tag <$> stackPath s + Just t' -> return t' + return $ remakeList lst -replaceArgsWithTerm :: Text -> Term Natural -> Term Natural +replaceArgsWithTerm :: (Member (Reader CompilerCtx) r) => Text -> Term Natural -> Sem r (Term Natural) replaceArgsWithTerm tag term = replaceSubject' ("replaceArgsWithTerm-" <> tag) $ \case ArgsTuple -> Just term _ -> Nothing -replaceArgs :: [Term Natural] -> Term Natural +replaceArgs :: (Member (Reader CompilerCtx) r) => [Term Natural] -> Sem r (Term Natural) replaceArgs = replaceArgsWithTerm "replaceArgs" . foldTermsOrNil getFunctionInfo :: (Members '[Reader CompilerCtx] r) => FunctionId -> Sem r FunctionInfo From 6aa62f1930af60ca4ab0abbccbe3ffcb1fac3d1e Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Wed, 2 Oct 2024 18:53:56 +0200 Subject: [PATCH 05/18] fix case --- .../Compiler/Nockma/Translation/FromTree.hs | 56 ++++++++++--------- 1 file changed, 31 insertions(+), 25 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 963dffb7e1..615ba758c6 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -503,14 +503,15 @@ compile = \case goSave :: Tree.NodeSave -> Sem r (Term Natural) goSave Tree.NodeSave {..} = do arg <- compile _nodeSaveArg - withTempVar arg (compile _nodeSaveBody) + withTempVar arg (const (compile _nodeSaveBody)) goCase :: Tree.NodeCase -> Sem r (Term Natural) goCase c = do def <- mapM compile (c ^. Tree.nodeCaseDefault) arg <- compile (c ^. Tree.nodeCaseArg) - branches <- mapM goCaseBranch (c ^. Tree.nodeCaseBranches) - caseCmd arg def branches + withTempVar arg $ \ref -> do + branches <- mapM goCaseBranch (c ^. Tree.nodeCaseBranches) + caseCmd ref def branches goCaseBranch :: Tree.CaseBranch -> Sem r (Tree.Tag, Term Natural) goCaseBranch b = do @@ -830,13 +831,13 @@ withTemp value f = do withTempVar :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => Term Natural -> - (Sem r (Term Natural)) -> + (TempRef -> Sem r (Term Natural)) -> Sem r (Term Natural) withTempVar value cont = withTemp value $ \temp -> do tempVar <- asks (^. compilerTempVarsNum) local (over compilerTempVarMap (HashMap.insert tempVar temp)) . local (over compilerTempVarsNum (+ 1)) - $ cont + $ cont (TempRef tempVar) popTempVar :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => @@ -1199,15 +1200,15 @@ constructorTagToTerm = \case caseCmd :: forall r. (Members '[Reader CompilerCtx] r) => - Term Natural -> + TempRef -> Maybe (Term Natural) -> [(Tree.Tag, Term Natural)] -> Sem r (Term Natural) -caseCmd arg defaultBranch = \case +caseCmd ref defaultBranch = \case [] -> return (fromJust defaultBranch) (tag, b) : bs -> case tag of Tree.BuiltinTag t -> case nockmaBuiltinTag t of - NockmaBuiltinBool v -> return (goBoolTag v b bs) + NockmaBuiltinBool v -> goBoolTag v b bs Tree.UserTag {} -> do rep <- getConstructorMemRep tag case rep of @@ -1217,10 +1218,10 @@ caseCmd arg defaultBranch = \case | otherwise -> error "redundant branch. Impossible?" NockmaMemRepList constr -> do bs' <- mapM (firstM asNockmaMemRepListConstr) bs - return (goRepList ((constr, b) :| bs')) + goRepList ((constr, b) :| bs') NockmaMemRepMaybe constr -> do bs' <- mapM (firstM asNockmaMemRepMaybeConstr) bs - return (goRepMaybe ((constr, b) :| bs')) + goRepMaybe ((constr, b) :| bs') where goRepConstr :: Tree.Tag -> @@ -1228,6 +1229,7 @@ caseCmd arg defaultBranch = \case [(Tree.Tag, Term Natural)] -> Sem r (Term Natural) goRepConstr tag b bs = do + arg <- addressTempRef ref let cond :: Term Natural = OpEq # constructorTagToTerm tag @@ -1262,12 +1264,14 @@ caseCmd arg defaultBranch = \case Bool -> Term Natural -> [(Tree.Tag, Term Natural)] -> - (Term Natural) - goBoolTag v b bs = + Sem r (Term Natural) + goBoolTag v b bs = do + arg <- addressTempRef ref let otherBranch = fromMaybe crash (firstJust f bs <|> defaultBranch) - in if - | v -> branch arg b otherBranch - | otherwise -> branch arg otherBranch b + return $ + if + | v -> branch arg b otherBranch + | otherwise -> branch arg otherBranch b where f :: (Tree.Tag, Term Natural) -> Maybe (Term Natural) f (tag', br) = case tag' of @@ -1275,24 +1279,26 @@ caseCmd arg defaultBranch = \case Tree.BuiltinTag tag -> case nockmaBuiltinTag tag of NockmaBuiltinBool v' -> guard (v /= v') $> br - goRepList :: NonEmpty (NockmaMemRepListConstr, Term Natural) -> Term Natural - goRepList ((c, b) :| bs) = + goRepList :: NonEmpty (NockmaMemRepListConstr, Term Natural) -> Sem r (Term Natural) + goRepList ((c, b) :| bs) = do + arg <- addressTempRef ref let cond = OpIsCell # arg otherBranch = fromMaybe crash (firstJust f bs <|> defaultBranch) - in case c of - NockmaMemRepListConstrCons -> branch cond b otherBranch - NockmaMemRepListConstrNil -> branch cond otherBranch b + return $ case c of + NockmaMemRepListConstrCons -> branch cond b otherBranch + NockmaMemRepListConstrNil -> branch cond otherBranch b where f :: (NockmaMemRepListConstr, Term Natural) -> Maybe (Term Natural) f (c', br) = guard (c /= c') $> br - goRepMaybe :: NonEmpty (NockmaMemRepMaybeConstr, Term Natural) -> Term Natural - goRepMaybe ((c, b) :| bs) = + goRepMaybe :: NonEmpty (NockmaMemRepMaybeConstr, Term Natural) -> Sem r (Term Natural) + goRepMaybe ((c, b) :| bs) = do + arg <- addressTempRef ref let cond = OpIsCell # arg otherBranch = fromMaybe crash (firstJust f bs <|> defaultBranch) - in case c of - NockmaMemRepMaybeConstrJust -> branch cond b otherBranch - NockmaMemRepMaybeConstrNothing -> branch cond otherBranch b + return $ case c of + NockmaMemRepMaybeConstrJust -> branch cond b otherBranch + NockmaMemRepMaybeConstrNothing -> branch cond otherBranch b where f :: (NockmaMemRepMaybeConstr, Term Natural) -> Maybe (Term Natural) f (c', br) = guard (c /= c') $> br From 2fc7c138df6c2e08c64fd9fbdec8bb2dc6db2f44 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Thu, 3 Oct 2024 14:04:07 +0200 Subject: [PATCH 06/18] fix closures --- src/Juvix/Compiler/Nockma/Anoma.hs | 6 +- .../Compiler/Nockma/Translation/FromTree.hs | 120 ++++++++---------- 2 files changed, 53 insertions(+), 73 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Anoma.hs b/src/Juvix/Compiler/Nockma/Anoma.hs index 32d879ef31..c2035c4d72 100644 --- a/src/Juvix/Compiler/Nockma/Anoma.hs +++ b/src/Juvix/Compiler/Nockma/Anoma.hs @@ -16,9 +16,9 @@ anomaCallTuple = \case helper replaceArgs = opCall "anomaCall" - (closurePath WrapperCode) - (repArgs (OpAddress # emptyPath)) + (closurePath FunCode) + (replArgs (OpAddress # emptyPath)) where - repArgs x = case replaceArgs of + replArgs x = case replaceArgs of Nothing -> x Just r -> r x diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 615ba758c6..e73fb77c1d 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -159,12 +159,10 @@ data CompilerFunction = CompilerFunction -- because the stack must have the structure of a Nock function, -- i.e [code args env] data AnomaCallablePathId - = WrapperCode + = FunCode | ArgsTuple | --- FunctionsLibrary - | RawCode - | TempStack | StandardLibrary | ClosureTotalArgsNum | ClosureArgsNum @@ -229,7 +227,7 @@ stackPath s = do getSubjectBasePath :: (Member (Reader CompilerCtx) r) => Sem r Path getSubjectBasePath = do h <- asks (^. compilerStackHeight) - return $ indexStack (fromIntegral h) + return $ replicate h R runCompilerFunction :: CompilerCtx -> CompilerFunction -> Term Natural runCompilerFunction ctx fun = @@ -368,25 +366,8 @@ addressTempRef tr = do p <- tempRefPath tr return $ opAddress "tempRef" p -anomaCallableClosureWrapper :: (Member (Reader CompilerCtx) r) => Sem r (Term Natural) -anomaCallableClosureWrapper = do - let closureArgsNum :: Term Natural = getClosureFieldInSubject ClosureArgsNum - closureTotalArgsNum :: Term Natural = getClosureFieldInSubject ClosureTotalArgsNum - remainingArgsNum <- sub closureTotalArgsNum closureArgsNum - tup <- - appendToTuple - (getClosureFieldInSubject ClosureArgs) - closureArgsNum - (getClosureFieldInSubject ArgsTuple) - remainingArgsNum - appendAndReplaceArgsTuple <- replaceArgsWithTerm "anomaCallableClosureWrapper" tup - subjectBasePath <- getSubjectBasePath - let closureArgsIsEmpty = isZero closureArgsNum - adjustArgs = OpIf # closureArgsIsEmpty # (opAddress "wrapperSubject" subjectBasePath) # appendAndReplaceArgsTuple - return $ opCall "closureWrapper" (closurePath RawCode) adjustArgs - -mainFunctionWrapper :: (Member (Reader CompilerCtx) r) => Term Natural -> Sem r (Term Natural) -mainFunctionWrapper funslib = do +mainFunctionWrapper :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) +mainFunctionWrapper funslib funCode = do -- 1. The Anoma system expects to receive a function of type `ScryId -> Transaction` -- -- 2. The ScryId is only used to construct the argument to the Scry operation @@ -399,10 +380,11 @@ mainFunctionWrapper funslib = do -- -- 4. If the Anoma system expectation changes then this code must be changed. captureAnomaGetOrder <- replaceSubject $ \case + FunCode -> Just (OpQuote # funCode) AnomaGetOrder -> Just (getClosureFieldInSubject ArgsTuple) FunctionsLibrary -> Just (OpQuote # funslib) _ -> Nothing - return $ opCall "mainFunctionWrapper" (closurePath RawCode) captureAnomaGetOrder + return $ opCall "mainFunctionWrapper" (closurePath FunCode) captureAnomaGetOrder compile :: forall r. (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => Tree.Node -> Sem r (Term Natural) compile = \case @@ -746,16 +728,14 @@ compile = \case goAllocClosure :: Tree.NodeAllocClosure -> Sem r (Term Natural) goAllocClosure Tree.NodeAllocClosure {..} = do let fun = UserFunction _nodeAllocClosureFunSymbol + base <- getSubjectBasePath fpath <- getFunctionPath fun farity <- getFunctionArity fun args <- mapM compile _nodeAllocClosureArgs - wrapper <- anomaCallableClosureWrapper return . makeClosure $ \case - WrapperCode -> OpQuote # wrapper + FunCode -> opAddress "allocClosureFunPath" (base <> fpath <> closurePath FunCode) ArgsTuple -> OpQuote # argsTuplePlaceholder "goAllocClosure" FunctionsLibrary -> OpQuote # functionsLibraryPlaceHolder - RawCode -> opAddress "allocClosureFunPath" (fpath <> closurePath RawCode) - TempStack -> remakeList [] StandardLibrary -> OpQuote # stdlibPlaceHolder ClosureTotalArgsNum -> nockNatLiteral farity ClosureArgsNum -> nockIntegralLiteral (length args) @@ -766,27 +746,16 @@ compile = \case goExtendClosure = extendClosure goCall :: Tree.NodeCall -> Sem r (Term Natural) - goCall Tree.NodeCall {..} = do - newargs <- mapM compile _nodeCallArgs + goCall Tree.NodeCall {..} = case _nodeCallType of - Tree.CallFun fun -> callFunWithArgs (UserFunction fun) newargs + Tree.CallFun fun -> do + newargs <- mapM compile _nodeCallArgs + callFunWithArgs (UserFunction fun) newargs Tree.CallClosure f -> do closure <- compile f - let argsNum = getClosureField ClosureArgsNum closure - oldArgs = getClosureField ClosureArgs closure - allArgs <- appendToTuple oldArgs argsNum (foldTermsOrNil newargs) (nockIntegralLiteral (length newargs)) - newSubject <- replaceSubject $ \case - WrapperCode -> Just (getClosureField RawCode closure) -- We Want RawCode because we already have all args. - ArgsTuple -> Just allArgs - RawCode -> Just (OpQuote # nockNilTagged "callClosure-RawCode") - TempStack -> Just (OpQuote # nockNilTagged "callClosure-TempStack") - FunctionsLibrary -> Nothing - StandardLibrary -> Nothing - ClosureArgs -> Nothing - ClosureTotalArgsNum -> Nothing - ClosureArgsNum -> Nothing - AnomaGetOrder -> Nothing - return (opCall "callClosure" (closurePath WrapperCode) newSubject) + withTemp closure $ \ref -> do + newargs <- mapM compile _nodeCallArgs + callClosure ref newargs isZero :: Term Natural -> Term Natural isZero a = OpEq # a # nockNatLiteral 0 @@ -796,7 +765,7 @@ opAddress' x = evaluated $ (opQuote "opAddress'" OpAddress) # x -- [a [b [c 0]]] -> [a [b c]] -- len = quote 3 --- TODO lst is being evaluated three times! +-- TODO: lst is being evaluated three times! listToTuple :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) listToTuple lst len = do -- posOfLast uses stdlib so when it is evaulated the stdlib must be in the @@ -895,14 +864,12 @@ extendClosure Tree.NodeExtendClosure {..} = do allArgs <- append oldArgs argsNum (remakeList args) newArgsNum <- add argsNum (nockIntegralLiteral (length _nodeExtendClosureArgs)) return . makeClosure $ \case - WrapperCode -> getClosureField WrapperCode closure - RawCode -> getClosureField RawCode closure + FunCode -> getClosureField FunCode closure ClosureTotalArgsNum -> getClosureField ClosureTotalArgsNum closure ClosureArgsNum -> newArgsNum ClosureArgs -> allArgs ArgsTuple -> getClosureField ArgsTuple closure FunctionsLibrary -> getClosureField FunctionsLibrary closure - TempStack -> getClosureField TempStack closure StandardLibrary -> getClosureField StandardLibrary closure AnomaGetOrder -> getClosureField AnomaGetOrder closure @@ -928,7 +895,7 @@ callStdlib fun args = do let adjustArgs = case nonEmpty args of Just args' -> opReplace "callStdlib-args" argsPath ((opAddress "stdlibR" [R]) >># foldTerms args') (opAddress "stdlibL" [L]) Nothing -> opAddress "adjustArgsNothing" [L] - callFn = opCall "callStdlib" (closurePath WrapperCode) adjustArgs + callFn = opCall "callStdlib" (closurePath FunCode) adjustArgs meta = StdlibCall { _stdlibCallArgs = foldTermsOrNil args, @@ -1047,11 +1014,9 @@ runCompilerWith opts constrs moduleFuns mainFun = ( \p -> let nockNilHere = nockNilTagged ("makeLibraryFunction-" <> show p) in case p of - WrapperCode -> ("wrapperCode-" <> funName) @ c + FunCode -> ("funCode-" <> funName) @ c ArgsTuple -> ("argsTuple-" <> funName) @ argsTuplePlaceholder "libraryFunction" FunctionsLibrary -> ("functionsLibrary-" <> funName) @ functionsLibraryPlaceHolder - RawCode -> ("rawCode-" <> funName) @ c - TempStack -> ("tempStack-" <> funName) @ nockNilHere StandardLibrary -> ("stdlib-" <> funName) @ stdlibPlaceHolder ClosureTotalArgsNum -> ("closureTotalArgsNum-" <> funName) @ nockNilHere ClosureArgsNum -> ("closureArgsNum-" <> funName) @ nockNilHere @@ -1063,11 +1028,9 @@ runCompilerWith opts constrs moduleFuns mainFun = makeMainFunction c = makeClosure $ \p -> let nockNilHere = nockNilTagged ("makeMainFunction-" <> show p) in case p of - WrapperCode -> run . runReader compilerCtx $ mainFunctionWrapper funcsLib + FunCode -> run . runReader compilerCtx $ mainFunctionWrapper funcsLib c ArgsTuple -> argsTuplePlaceholder "mainFunction" FunctionsLibrary -> functionsLibraryPlaceHolder - RawCode -> c - TempStack -> nockNilHere StandardLibrary -> stdlib ClosureTotalArgsNum -> nockNilHere ClosureArgsNum -> nockNilHere @@ -1125,27 +1088,42 @@ builtinFunction = \case _compilerFunctionName = "builtinPlaceholderName" } --- | Call a function. Arguments to the function are assumed to be in the ArgsTuple stack --- TODO what about temporary stack? -callFun :: - (Members '[Reader CompilerCtx] r) => - FunctionId -> - Sem r (Term Natural) -callFun fun = do - fpath <- getFunctionPath fun - fname <- getFunctionName fun - let p' = fpath ++ closurePath WrapperCode - return (opCall ("callFun-" <> fname) p' (opAddress "callFunSubject" emptyPath)) - -- | Call a function with the passed arguments callFunWithArgs :: + forall r. (Members '[Reader CompilerCtx] r) => FunctionId -> [Term Natural] -> Sem r (Term Natural) callFunWithArgs fun args = do replArgs <- replaceArgs args - (replArgs >>#) <$> callFun fun + -- after `replArgs` the temporary stack is empty + (replArgs >>#) <$> mkFunCall + where + mkFunCall :: Sem r (Term Natural) + mkFunCall = do + -- here the temporary stack has been deleted + fpath <- getFunctionPath fun + fname <- getFunctionName fun + let p' = fpath ++ closurePath FunCode + return (opCall ("callFun-" <> fname) p' (opAddress "callFunSubject" emptyPath)) + +callClosure :: (Members '[Reader CompilerCtx] r) => TempRef -> [Term Natural] -> Sem r (Term Natural) +callClosure ref newArgs = do + closure <- addressTempRef ref + let oldArgsNum = getClosureField ClosureArgsNum closure + oldArgs = getClosureField ClosureArgs closure + allArgs <- appendToTuple oldArgs oldArgsNum (foldTermsOrNil newArgs) (nockIntegralLiteral (length newArgs)) + newSubject <- replaceSubject $ \case + FunCode -> Just (getClosureField FunCode closure) + ArgsTuple -> Just allArgs + FunctionsLibrary -> Nothing + StandardLibrary -> Nothing + ClosureArgs -> Nothing + ClosureTotalArgsNum -> Nothing + ClosureArgsNum -> Nothing + AnomaGetOrder -> Nothing + return (opCall "callClosure" (closurePath FunCode) newSubject) replaceSubject :: (Member (Reader CompilerCtx) r) => (AnomaCallablePathId -> Maybe (Term Natural)) -> Sem r (Term Natural) replaceSubject = replaceSubject' "replaceSubject" @@ -1164,6 +1142,8 @@ replaceArgsWithTerm tag term = ArgsTuple -> Just term _ -> Nothing +-- | Replace the arguments in the ArgsTuple stack with the passed arguments. +-- Resets the temporary stack to empty. replaceArgs :: (Member (Reader CompilerCtx) r) => [Term Natural] -> Sem r (Term Natural) replaceArgs = replaceArgsWithTerm "replaceArgs" . foldTermsOrNil From 5f42ce249ad15041ad70edcac4b05ff02b51cfa8 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Thu, 3 Oct 2024 18:09:18 +0200 Subject: [PATCH 07/18] comments --- src/Juvix/Compiler/Nockma/Translation/FromTree.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index e73fb77c1d..6627170b44 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -773,6 +773,12 @@ listToTuple lst len = do -- this by evaluating `lst #. posOfLastOffset` in `t1`. The address that -- posOfLastOffset now points to must be shifted by [L] to make it relative to -- `lst`. + -- + -- TODO: dec and the pow2 in appendRights are being evaluated twice. We should + -- have appendRights' which takes 2^n instead of n + -- + -- TODO: there is way too much arithmetic here with many calls to stdlib; this + -- makes the generated code very inefficient posOfLastOffset <- appendRights [L] =<< dec len posOfLast <- appendRights emptyPath =<< dec len let t1 = (lst #. posOfLastOffset) >># (opAddress' (OpAddress # [R])) >># (opAddress "listToTupleLast" [L]) @@ -835,6 +841,7 @@ nockIntegralLiteral = (OpQuote #) . toNock @Natural . fromIntegral -- the result is a tuple. -- NOTE: xs occurs twice, but that's fine because each occurrence is in a -- different if branch. +-- TODO: this function generates extremely inefficient code appendToTuple :: (Member (Reader CompilerCtx) r) => Term Natural -> @@ -845,8 +852,11 @@ appendToTuple :: appendToTuple xs lenXs ys lenYs = do tp1 <- listToTuple xs lenXs tp2 <- append xs lenXs ys + -- TODO: omit the if when lenYs is known at compile-time return $ OpIf # isZero lenYs # tp1 # tp2 +-- TODO: what does this function do? what are the arguments? +-- TODO: this function generates inefficient code append :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Term Natural -> Sem r (Term Natural) append xs lenXs ys = do posOfXsNil <- appendRights emptyPath lenXs From e1f8247cc57e590c3d8f46a4dad22ba032f826fd Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Thu, 3 Oct 2024 19:26:39 +0200 Subject: [PATCH 08/18] fix case default --- .../Compiler/Nockma/Translation/FromTree.hs | 25 +++++++------------ 1 file changed, 9 insertions(+), 16 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 6627170b44..af201aefdc 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -489,9 +489,9 @@ compile = \case goCase :: Tree.NodeCase -> Sem r (Term Natural) goCase c = do - def <- mapM compile (c ^. Tree.nodeCaseDefault) arg <- compile (c ^. Tree.nodeCaseArg) withTempVar arg $ \ref -> do + def <- mapM (popTempVar . compile) (c ^. Tree.nodeCaseDefault) branches <- mapM goCaseBranch (c ^. Tree.nodeCaseBranches) caseCmd ref def branches @@ -1106,17 +1106,11 @@ callFunWithArgs :: [Term Natural] -> Sem r (Term Natural) callFunWithArgs fun args = do - replArgs <- replaceArgs args - -- after `replArgs` the temporary stack is empty - (replArgs >>#) <$> mkFunCall - where - mkFunCall :: Sem r (Term Natural) - mkFunCall = do - -- here the temporary stack has been deleted - fpath <- getFunctionPath fun - fname <- getFunctionName fun - let p' = fpath ++ closurePath FunCode - return (opCall ("callFun-" <> fname) p' (opAddress "callFunSubject" emptyPath)) + newSubject <- replaceArgs args + fpath <- getFunctionPath fun + fname <- getFunctionName fun + let p' = fpath ++ closurePath FunCode + return (opCall ("callFun-" <> fname) p' newSubject) callClosure :: (Members '[Reader CompilerCtx] r) => TempRef -> [Term Natural] -> Sem r (Term Natural) callClosure ref newArgs = do @@ -1153,7 +1147,7 @@ replaceArgsWithTerm tag term = _ -> Nothing -- | Replace the arguments in the ArgsTuple stack with the passed arguments. --- Resets the temporary stack to empty. +-- Resets the temporary stack to empty. Returns the new subject. replaceArgs :: (Member (Reader CompilerCtx) r) => [Term Natural] -> Sem r (Term Natural) replaceArgs = replaceArgsWithTerm "replaceArgs" . foldTermsOrNil @@ -1184,9 +1178,8 @@ constructorTagToTerm = \case Tree.UserTag t -> OpQuote # toNock (fromIntegral (t ^. Tree.tagUserWord) :: Natural) Tree.BuiltinTag b -> builtinTagToTerm (nockmaBuiltinTag b) --- Creates a case command from the compiled value `arg` and the compiled --- branches. Note: `arg` is duplicated, so it should be a reference -- not --- perform any non-trivial computation! +-- Creates a case command from the reference `ref` to the compiled value and the +-- compiled branches. caseCmd :: forall r. (Members '[Reader CompilerCtx] r) => From e5bcd1450bfd29eca4fc0b1792c842f1cde11136 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 4 Oct 2024 13:49:05 +0200 Subject: [PATCH 09/18] fix tree parsing --- .../Compiler/Tree/Translation/FromSource.hs | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/src/Juvix/Compiler/Tree/Translation/FromSource.hs b/src/Juvix/Compiler/Tree/Translation/FromSource.hs index f795a60afb..99c28e211f 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromSource.hs @@ -385,7 +385,7 @@ caseBranch = do saveBranch :: ParsecS r (Bool, Node) saveBranch = do kw kwSave - (True,) <$> braces parseNode + (True,) <$> braces (withSave Nothing parseNode) discardBranch :: ParsecS r (Bool, Node) discardBranch = do @@ -407,10 +407,7 @@ parseSave = do loc' <- onlyInterval (kw kwSave) (mname, loc) <- interval $ optional (brackets identifier) arg <- parens parseNode - tmpNum <- lift $ gets @LocalParams (^. localParamsTempIndex) - let updateNames :: LocalNameMap DirectRef -> LocalNameMap DirectRef - updateNames mp = maybe mp (\n -> HashMap.insert n (mkTempRef (OffsetRef tmpNum (Just n))) mp) mname - body <- braces (localS @LocalParams (over localParamsTempIndex (+ 1)) $ localS @LocalParams (over localParamsNameMap updateNames) parseNode) + body <- braces (withSave mname parseNode) return NodeSave { _nodeSaveInfo = NodeInfo (Just loc'), @@ -418,3 +415,14 @@ parseSave = do _nodeSaveBody = body, _nodeSaveTempVar = TempVar mname (Just loc) } + +withSave :: + (Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) => + Maybe Text -> + ParsecS r Node -> + ParsecS r Node +withSave mname a = do + tmpNum <- lift $ gets @LocalParams (^. localParamsTempIndex) + let updateNames :: LocalNameMap DirectRef -> LocalNameMap DirectRef + updateNames mp = maybe mp (\n -> HashMap.insert n (mkTempRef (OffsetRef tmpNum (Just n))) mp) mname + localS @LocalParams (over localParamsTempIndex (+ 1)) $ localS @LocalParams (over localParamsNameMap updateNames) a From ff8928a56d64a26d1cb09f1222baf8c6bd97cd0d Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 4 Oct 2024 16:03:26 +0200 Subject: [PATCH 10/18] fix case temp ref --- src/Juvix/Compiler/Nockma/Translation/FromTree.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index af201aefdc..f0979e4276 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -213,7 +213,6 @@ indexTuple IndexTupleArgs {..} makeLenses ''CompilerOptions makeLenses ''AnomaResult makeLenses ''CompilerFunction -makeLenses ''TempRef makeLenses ''CompilerCtx makeLenses ''FunctionCtx makeLenses ''ConstructorInfo @@ -812,7 +811,7 @@ withTempVar value cont = withTemp value $ \temp -> do tempVar <- asks (^. compilerTempVarsNum) local (over compilerTempVarMap (HashMap.insert tempVar temp)) . local (over compilerTempVarsNum (+ 1)) - $ cont (TempRef tempVar) + $ cont temp popTempVar :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => @@ -924,11 +923,10 @@ directRefPath :: forall r. (Members '[Reader FunctionCtx, Reader CompilerCtx] r) directRefPath = \case Tree.ArgRef a -> pathToArg (fromOffsetRef a) Tree.TempRef Tree.RefTemp {..} -> do - stackHeight <- asks (^. compilerStackHeight) varMap <- asks (^. compilerTempVarMap) let tempIdx = _refTempOffsetRef ^. Tree.offsetRefOffset ref = fromJust $ HashMap.lookup tempIdx varMap - return $ indexStack $ fromIntegral $ (stackHeight - ref ^. tempRefIndex - 1) + tempRefPath ref nockmaBuiltinTag :: Tree.BuiltinDataTag -> NockmaBuiltinTag nockmaBuiltinTag = \case From 620906bf178083f1f4f96b0caad373e0878995dd Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 4 Oct 2024 17:07:42 +0200 Subject: [PATCH 11/18] fix anoma-get --- .../Compiler/Nockma/Translation/FromTree.hs | 20 ++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index f0979e4276..3065119d13 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -218,7 +218,7 @@ makeLenses ''FunctionCtx makeLenses ''ConstructorInfo makeLenses ''FunctionInfo -stackPath :: (Member (Reader CompilerCtx) r) => AnomaCallablePathId -> Sem r Path +stackPath :: (Member (Reader CompilerCtx) r, Enum field) => field -> Sem r Path stackPath s = do h <- asks (^. compilerStackHeight) return $ indexStack (fromIntegral (h + fromEnum s)) @@ -378,9 +378,10 @@ mainFunctionWrapper funslib funCode = do -- when anomaGet is compiled. -- -- 4. If the Anoma system expectation changes then this code must be changed. + anomaGet <- getFieldInSubject ArgsTuple captureAnomaGetOrder <- replaceSubject $ \case FunCode -> Just (OpQuote # funCode) - AnomaGetOrder -> Just (getClosureFieldInSubject ArgsTuple) + AnomaGetOrder -> Just anomaGet FunctionsLibrary -> Just (OpQuote # funslib) _ -> Nothing return $ opCall "mainFunctionWrapper" (closurePath FunCode) captureAnomaGetOrder @@ -571,7 +572,8 @@ compile = \case goAnomaGet :: [Term Natural] -> Sem r (Term Natural) goAnomaGet key = do - let arg = remakeList [getFieldInSubject AnomaGetOrder, foldTermsOrNil key] + anomaGet <- getFieldInSubject AnomaGetOrder + let arg = remakeList [anomaGet, foldTermsOrNil key] return (OpScry # (OpQuote # nockNilTagged "OpScry-typehint") # arg) goAnomaEncode :: [Term Natural] -> Sem r (Term Natural) @@ -867,6 +869,7 @@ extendClosure :: Sem r (Term Natural) extendClosure Tree.NodeExtendClosure {..} = do args <- mapM compile _nodeExtendClosureArgs + -- TODO: closure is evaluated multiple times closure <- compile _nodeExtendClosureFun let argsNum = getClosureField ClosureArgsNum closure oldArgs = getClosureField ClosureArgs closure @@ -1300,17 +1303,16 @@ getConstructorInfo tag = asks (^?! compilerConstructorInfos . at tag . _Just) getClosureField :: AnomaCallablePathId -> Term Natural -> Term Natural getClosureField = getField -getClosureFieldInSubject :: AnomaCallablePathId -> Term Natural -getClosureFieldInSubject = getFieldInSubject - getConstructorField :: ConstructorPathId -> Term Natural -> Term Natural getConstructorField = getField getField :: (Enum field) => field -> Term Natural -> Term Natural -getField field t = t >># getFieldInSubject field +getField field t = t >># opAddress "getField" (pathFromEnum field) -getFieldInSubject :: (Enum field) => field -> Term Natural -getFieldInSubject field = opAddress "getFieldInSubject" (pathFromEnum field) +getFieldInSubject :: (Member (Reader CompilerCtx) r) => (Enum field) => field -> Sem r (Term Natural) +getFieldInSubject field = do + path <- stackPath field + return $ opAddress "getFieldInSubject" path getConstructorMemRep :: (Members '[Reader CompilerCtx] r) => Tree.Tag -> Sem r NockmaMemRep getConstructorMemRep tag = (^. constructorInfoMemRep) <$> getConstructorInfo tag From 3164c72e28a1a30264780cc8e69bd5d108c07cba Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 4 Oct 2024 17:29:59 +0200 Subject: [PATCH 12/18] avoid duplication in closure extension --- .../Compiler/Nockma/Translation/FromTree.hs | 33 ++++++++++--------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 3065119d13..4646cf8ba8 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -868,22 +868,23 @@ extendClosure :: Tree.NodeExtendClosure -> Sem r (Term Natural) extendClosure Tree.NodeExtendClosure {..} = do - args <- mapM compile _nodeExtendClosureArgs - -- TODO: closure is evaluated multiple times - closure <- compile _nodeExtendClosureFun - let argsNum = getClosureField ClosureArgsNum closure - oldArgs = getClosureField ClosureArgs closure - allArgs <- append oldArgs argsNum (remakeList args) - newArgsNum <- add argsNum (nockIntegralLiteral (length _nodeExtendClosureArgs)) - return . makeClosure $ \case - FunCode -> getClosureField FunCode closure - ClosureTotalArgsNum -> getClosureField ClosureTotalArgsNum closure - ClosureArgsNum -> newArgsNum - ClosureArgs -> allArgs - ArgsTuple -> getClosureField ArgsTuple closure - FunctionsLibrary -> getClosureField FunctionsLibrary closure - StandardLibrary -> getClosureField StandardLibrary closure - AnomaGetOrder -> getClosureField AnomaGetOrder closure + closureFun <- compile _nodeExtendClosureFun + withTemp closureFun $ \ref -> do + args <- mapM compile _nodeExtendClosureArgs + closure <- addressTempRef ref + let argsNum = getClosureField ClosureArgsNum closure + oldArgs = getClosureField ClosureArgs closure + allArgs <- append oldArgs argsNum (remakeList args) + newArgsNum <- add argsNum (nockIntegralLiteral (length _nodeExtendClosureArgs)) + return . makeClosure $ \case + FunCode -> getClosureField FunCode closure + ClosureTotalArgsNum -> getClosureField ClosureTotalArgsNum closure + ClosureArgsNum -> newArgsNum + ClosureArgs -> allArgs + ArgsTuple -> getClosureField ArgsTuple closure + FunctionsLibrary -> getClosureField FunctionsLibrary closure + StandardLibrary -> getClosureField StandardLibrary closure + AnomaGetOrder -> getClosureField AnomaGetOrder closure -- Calling convention for Anoma stdlib -- From 42d7e71fc3aaa22796836d648c4bc18ea44c1053 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 4 Oct 2024 18:23:24 +0200 Subject: [PATCH 13/18] use temporary value in anomaSign --- .../Compiler/Nockma/Translation/FromTree.hs | 105 +++++++++--------- 1 file changed, 51 insertions(+), 54 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 4646cf8ba8..88d66a8ec6 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -173,15 +173,6 @@ data AnomaCallablePathId indexStack :: Natural -> Path indexStack idx = replicate idx R ++ [L] --- | A closure has the following structure: --- [code totalArgsNum argsNum args], where --- 1. code is code to run when fully applied. --- 2. totalArgsNum is the number of arguments that the function --- which created the closure expects. --- 3. argsNum is the number of arguments that have been applied to the closure. --- 4. args is the list of args that have been applied. --- The length of the list should be argsNum. --- TODO: this comment seems outdated pathFromEnum :: (Enum a) => a -> Path pathFromEnum = indexStack . fromIntegral . fromEnum @@ -228,6 +219,53 @@ getSubjectBasePath = do h <- asks (^. compilerStackHeight) return $ replicate h R +-- | Pushes a temporary value onto the subject stack and continues compilation +-- with the provided continuation function. +-- +-- NOTE: It is *important* to *never* duplicate any compilation steps, e.g., +-- ``` +-- doSth <- compile something +-- return $ doSth # doSth +-- ``` +-- is incorrect. Duplication of `doSth` in the returned generated code may +-- result in changing the asymptotic complexity of the compiled program +-- exponentially. The above code should be replaced with: +-- ``` +-- doSth <- compile something +-- withTemp doSth $ \ref -> do +-- val <- addressTempRef ref +-- return $ val # val +withTemp :: + (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => + Term Natural -> + (TempRef -> Sem r (Term Natural)) -> + Sem r (Term Natural) +withTemp value f = do + stackHeight <- asks (^. compilerStackHeight) + body' <- local (over compilerStackHeight (+ 1)) $ f (TempRef stackHeight) + return $ OpPush # value # body' + +withTempVar :: + (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => + Term Natural -> + (TempRef -> Sem r (Term Natural)) -> + Sem r (Term Natural) +withTempVar value cont = withTemp value $ \temp -> do + tempVar <- asks (^. compilerTempVarsNum) + local (over compilerTempVarMap (HashMap.insert tempVar temp)) + . local (over compilerTempVarsNum (+ 1)) + $ cont temp + +popTempVar :: + (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => + (Sem r (Term Natural)) -> + Sem r (Term Natural) +popTempVar cont = do + tempVar <- asks (^. compilerTempVarsNum) + local (over compilerTempVarMap (HashMap.delete (tempVar - 1))) + . local (over compilerTempVarsNum (\x -> x - 1)) + $ cont + runCompilerFunction :: CompilerCtx -> CompilerFunction -> Term Natural runCompilerFunction ctx fun = run @@ -610,25 +648,15 @@ compile = \case [ enc, byteArrayPayload "anomaSignPrivKeyTail" privKey ] - ret <- goReturnByteArray - -- TODO: is this correct? should we adjust paths? - return $ - opReplace - "callMkByteArrayOnSignResult" - (closurePath ArgsTuple) - stdcall - (opAddress "stack" emptyPath) - >># ret + withTemp stdcall goReturnByteArray _ -> impossible where - goReturnByteArray :: Sem r (Term Natural) - goReturnByteArray = do + goReturnByteArray :: TempRef -> Sem r (Term Natural) + goReturnByteArray ref = do + signResult <- addressTempRef ref res <- callStdlib StdlibLengthBytes [signResult] return $ mkByteArray res signResult - signResult :: Term Natural - signResult = opAddress "sign-result" (closurePath ArgsTuple) - goAnomaSignDetached :: [Term Natural] -> Sem r (Term Natural) goAnomaSignDetached = \case [message, privKeyByteArray] -> do @@ -794,37 +822,6 @@ appendRights path n = do n' <- pow2 n mul n' (OpInc # OpQuote # path) >>= dec -withTemp :: - (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => - Term Natural -> - (TempRef -> Sem r (Term Natural)) -> - Sem r (Term Natural) -withTemp value f = do - stackHeight <- asks (^. compilerStackHeight) - body' <- local (over compilerStackHeight (+ 1)) $ f (TempRef stackHeight) - return $ OpPush # value # body' - -withTempVar :: - (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => - Term Natural -> - (TempRef -> Sem r (Term Natural)) -> - Sem r (Term Natural) -withTempVar value cont = withTemp value $ \temp -> do - tempVar <- asks (^. compilerTempVarsNum) - local (over compilerTempVarMap (HashMap.insert tempVar temp)) - . local (over compilerTempVarsNum (+ 1)) - $ cont temp - -popTempVar :: - (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => - (Sem r (Term Natural)) -> - Sem r (Term Natural) -popTempVar cont = do - tempVar <- asks (^. compilerTempVarsNum) - local (over compilerTempVarMap (HashMap.delete (tempVar - 1))) - . local (over compilerTempVarsNum (\x -> x - 1)) - $ cont - testEq :: (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => Tree.Node -> Tree.Node -> Sem r (Term Natural) testEq a b = do a' <- compile a From 64fd42956c260a7f80e89378b5df08c78ee679bb Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 4 Oct 2024 18:35:04 +0200 Subject: [PATCH 14/18] remove remaining duplication --- .../Compiler/Nockma/Translation/FromTree.hs | 32 +++++++++++-------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 88d66a8ec6..68437c0a31 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -236,7 +236,7 @@ getSubjectBasePath = do -- val <- addressTempRef ref -- return $ val # val withTemp :: - (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => + (Member (Reader CompilerCtx) r) => Term Natural -> (TempRef -> Sem r (Term Natural)) -> Sem r (Term Natural) @@ -246,7 +246,7 @@ withTemp value f = do return $ OpPush # value # body' withTempVar :: - (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => + (Member (Reader CompilerCtx) r) => Term Natural -> (TempRef -> Sem r (Term Natural)) -> Sem r (Term Natural) @@ -257,7 +257,7 @@ withTempVar value cont = withTemp value $ \temp -> do $ cont temp popTempVar :: - (Members '[Reader FunctionCtx, Reader CompilerCtx] r) => + (Member (Reader CompilerCtx) r) => (Sem r (Term Natural)) -> Sem r (Term Natural) popTempVar cont = do @@ -724,11 +724,12 @@ compile = \case goTrace :: Term Natural -> Sem r (Term Natural) goTrace arg = do enabled <- asks (^. compilerOptions . compilerOptionsEnableTrace) - return $ - if - -- TODO: remove duplication of `arg` here - | enabled -> OpTrace # arg # arg - | otherwise -> arg + if + | enabled -> + withTemp arg $ \ref -> do + val <- addressTempRef ref + return $ OpTrace # val # val + | otherwise -> return arg goBinop :: Tree.NodeBinop -> Sem r (Term Natural) goBinop Tree.NodeBinop {..} = do @@ -794,7 +795,6 @@ opAddress' x = evaluated $ (opQuote "opAddress'" OpAddress) # x -- [a [b [c 0]]] -> [a [b c]] -- len = quote 3 --- TODO: lst is being evaluated three times! listToTuple :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) listToTuple lst len = do -- posOfLast uses stdlib so when it is evaulated the stdlib must be in the @@ -808,11 +808,15 @@ listToTuple lst len = do -- -- TODO: there is way too much arithmetic here with many calls to stdlib; this -- makes the generated code very inefficient - posOfLastOffset <- appendRights [L] =<< dec len - posOfLast <- appendRights emptyPath =<< dec len - let t1 = (lst #. posOfLastOffset) >># (opAddress' (OpAddress # [R])) >># (opAddress "listToTupleLast" [L]) - return $ - OpIf # isZero len # lst # (replaceSubterm' lst posOfLast t1) + withTemp lst $ \lstRef -> + withTemp len $ \lenRef -> do + lstVal <- addressTempRef lstRef + lenVal <- addressTempRef lenRef + posOfLastOffset <- appendRights [L] =<< dec lenVal + posOfLast <- appendRights emptyPath =<< dec lenVal + let t1 = (lstVal #. posOfLastOffset) >># (opAddress' (OpAddress # [R])) >># (opAddress "listToTupleLast" [L]) + return $ + OpIf # isZero lenVal # lstVal # (replaceSubterm' lstVal posOfLast t1) argsTuplePlaceholder :: Text -> Term Natural argsTuplePlaceholder txt = nockNilTagged ("argsTuplePlaceholder-" <> txt) From 876f1b0ee338685ca58552037d5a8a41e3486dd1 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 4 Oct 2024 19:02:51 +0200 Subject: [PATCH 15/18] remove unused transformations --- src/Juvix/Compiler/Core/Pipeline.hs | 2 +- .../Compiler/Tree/Data/TransformationId.hs | 4 +-- .../Tree/Data/TransformationId/Strings.hs | 3 -- src/Juvix/Compiler/Tree/Language/Base.hs | 16 ++--------- src/Juvix/Compiler/Tree/Transformation.hs | 2 -- .../Tree/Transformation/TempHeight.hs | 28 ------------------- 6 files changed, 5 insertions(+), 50 deletions(-) delete mode 100644 src/Juvix/Compiler/Tree/Transformation/TempHeight.hs diff --git a/src/Juvix/Compiler/Core/Pipeline.hs b/src/Juvix/Compiler/Core/Pipeline.hs index 4ec9024f02..51d4d50658 100644 --- a/src/Juvix/Compiler/Core/Pipeline.hs +++ b/src/Juvix/Compiler/Core/Pipeline.hs @@ -26,7 +26,7 @@ toVampIR :: (Members '[Error JuvixError, Reader EntryPoint] r) => Module -> Sem toVampIR = mapReader fromEntryPoint . applyTransformations toVampIRTransformations extraAnomaTransformations :: [TransformationId] -extraAnomaTransformations = [ComputeCaseANF] +extraAnomaTransformations = [] applyExtraTransformations :: (Members '[Error JuvixError, Reader EntryPoint] r) => [TransformationId] -> Module -> Sem r Module applyExtraTransformations transforms = mapReader fromEntryPoint . applyTransformations transforms diff --git a/src/Juvix/Compiler/Tree/Data/TransformationId.hs b/src/Juvix/Compiler/Tree/Data/TransformationId.hs index 8238814ae3..86f2437401 100644 --- a/src/Juvix/Compiler/Tree/Data/TransformationId.hs +++ b/src/Juvix/Compiler/Tree/Data/TransformationId.hs @@ -9,7 +9,6 @@ data TransformationId | IdentityU | IdentityD | Apply - | TempHeight | FilterUnreachable | Validate | CheckNoAnoma @@ -25,7 +24,7 @@ data PipelineId type TransformationLikeId = TransformationLikeId' TransformationId PipelineId toNockmaTransformations :: [TransformationId] -toNockmaTransformations = [Validate, Apply, FilterUnreachable, TempHeight] +toNockmaTransformations = [Validate, Apply, FilterUnreachable] toAsmTransformations :: [TransformationId] toAsmTransformations = [Validate, CheckNoAnoma, CheckNoByteArray] @@ -40,7 +39,6 @@ instance TransformationId' TransformationId where IdentityU -> strIdentityU IdentityD -> strIdentityD Apply -> strApply - TempHeight -> strTempHeight FilterUnreachable -> strFilterUnreachable Validate -> strValidate CheckNoAnoma -> strCheckNoAnoma diff --git a/src/Juvix/Compiler/Tree/Data/TransformationId/Strings.hs b/src/Juvix/Compiler/Tree/Data/TransformationId/Strings.hs index 54c9584530..8b270ccc27 100644 --- a/src/Juvix/Compiler/Tree/Data/TransformationId/Strings.hs +++ b/src/Juvix/Compiler/Tree/Data/TransformationId/Strings.hs @@ -23,9 +23,6 @@ strIdentityD = "identity-dmap" strApply :: Text strApply = "apply" -strTempHeight :: Text -strTempHeight = "temp-height" - strFilterUnreachable :: Text strFilterUnreachable = "filter-unreachable" diff --git a/src/Juvix/Compiler/Tree/Language/Base.hs b/src/Juvix/Compiler/Tree/Language/Base.hs index 10d9f9f52a..8ed0586f1e 100644 --- a/src/Juvix/Compiler/Tree/Language/Base.hs +++ b/src/Juvix/Compiler/Tree/Language/Base.hs @@ -51,20 +51,10 @@ data DirectRef deriving stock (Eq) mkTempRef :: OffsetRef -> DirectRef -mkTempRef o = TempRef (RefTemp o Nothing) +mkTempRef o = TempRef (RefTemp o) -mkTempRef' :: Int -> Int -> DirectRef -mkTempRef' height idx = - TempRef - ( RefTemp - { _refTempOffsetRef = OffsetRef {_offsetRefOffset = idx, _offsetRefName = Nothing}, - _refTempTempHeight = Just height - } - ) - -data RefTemp = RefTemp - { _refTempOffsetRef :: OffsetRef, - _refTempTempHeight :: Maybe Int +newtype RefTemp = RefTemp + { _refTempOffsetRef :: OffsetRef } deriving stock (Eq) diff --git a/src/Juvix/Compiler/Tree/Transformation.hs b/src/Juvix/Compiler/Tree/Transformation.hs index 39120e5dd0..656784f8de 100644 --- a/src/Juvix/Compiler/Tree/Transformation.hs +++ b/src/Juvix/Compiler/Tree/Transformation.hs @@ -14,7 +14,6 @@ import Juvix.Compiler.Tree.Transformation.CheckNoAnoma import Juvix.Compiler.Tree.Transformation.CheckNoByteArray import Juvix.Compiler.Tree.Transformation.FilterUnreachable import Juvix.Compiler.Tree.Transformation.IdentityTrans -import Juvix.Compiler.Tree.Transformation.TempHeight import Juvix.Compiler.Tree.Transformation.Validate applyTransformations :: forall r. (Member (Error JuvixError) r) => [TransformationId] -> InfoTable -> Sem r InfoTable @@ -26,7 +25,6 @@ applyTransformations ts tbl = foldM (flip appTrans) tbl ts IdentityU -> return . identityU IdentityD -> return . identityD Apply -> return . computeApply - TempHeight -> return . computeTempHeight FilterUnreachable -> return . filterUnreachable Validate -> mapError (JuvixError @TreeError) . validate CheckNoAnoma -> \tbl' -> mapError (JuvixError @TreeError) (checkNoAnoma tbl') $> tbl' diff --git a/src/Juvix/Compiler/Tree/Transformation/TempHeight.hs b/src/Juvix/Compiler/Tree/Transformation/TempHeight.hs deleted file mode 100644 index dd16e72a97..0000000000 --- a/src/Juvix/Compiler/Tree/Transformation/TempHeight.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Juvix.Compiler.Tree.Transformation.TempHeight where - -import Juvix.Compiler.Tree.Data.InfoTable -import Juvix.Compiler.Tree.Extra.Recursors -import Juvix.Compiler.Tree.Transformation.Base - -computeFunctionTempHeight :: Node -> Node -computeFunctionTempHeight = umapN go - where - go :: Int -> Node -> Node - go k = \case - MemRef (NodeMemRef i (DRef (TempRef r))) -> - let r' = set refTempTempHeight (Just k) r - in MemRef $ NodeMemRef i $ DRef (TempRef r') - MemRef (NodeMemRef i (ConstrRef field@Field {_fieldRef = TempRef r})) -> - let r' = set refTempTempHeight (Just k) r - in MemRef $ - NodeMemRef - i - ( ConstrRef - field - { _fieldRef = TempRef r' - } - ) - node -> node - -computeTempHeight :: InfoTable -> InfoTable -computeTempHeight = mapT (const computeFunctionTempHeight) From c73ea1363b1e3f6bbcdae99791302d4aef43ef23 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 4 Oct 2024 19:09:31 +0200 Subject: [PATCH 16/18] comments --- src/Juvix/Compiler/Nockma/Translation/FromTree.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 68437c0a31..bbd08617d4 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -229,7 +229,8 @@ getSubjectBasePath = do -- ``` -- is incorrect. Duplication of `doSth` in the returned generated code may -- result in changing the asymptotic complexity of the compiled program --- exponentially. The above code should be replaced with: +-- exponentially, because `doSth` will be evaluated twice. The above code should +-- be replaced with: -- ``` -- doSth <- compile something -- withTemp doSth $ \ref -> do @@ -245,6 +246,9 @@ withTemp value f = do body' <- local (over compilerStackHeight (+ 1)) $ f (TempRef stackHeight) return $ OpPush # value # body' +-- | Pushes a temporary value onto the subject stack, associates the resulting +-- stack reference with the next JuvixTree temporary variable, and continues +-- compilation. withTempVar :: (Member (Reader CompilerCtx) r) => Term Natural -> From f8bd3af2b5ddd9c36d12a754af0eae9e7041b5df Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 7 Oct 2024 15:23:07 +0200 Subject: [PATCH 17/18] remove listToTuple --- src/Juvix/Compiler/Nockma/Evaluator.hs | 2 +- .../Compiler/Nockma/Translation/FromTree.hs | 48 ++++--------------- src/Juvix/Compiler/Tree/Language.hs | 1 + test/Nockma/Eval/Positive.hs | 14 +----- 4 files changed, 12 insertions(+), 53 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Evaluator.hs b/src/Juvix/Compiler/Nockma/Evaluator.hs index 3ca175c09a..6593395fb9 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator.hs @@ -16,8 +16,8 @@ import Juvix.Compiler.Nockma.Evaluator.Error import Juvix.Compiler.Nockma.Evaluator.Options import Juvix.Compiler.Nockma.Evaluator.Storage import Juvix.Compiler.Nockma.Language +import Juvix.Compiler.Nockma.Pretty import Juvix.Prelude hiding (Atom, Path) -import Juvix.Prelude.Pretty newtype OpCounts = OpCounts { _opCountsMap :: HashMap NockOp Int diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index bbd08617d4..f072554711 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -24,7 +24,6 @@ module Juvix.Compiler.Nockma.Translation.FromTree foldTerms, pathToArg, makeList, - listToTuple, appendToTuple, append, opAddress', @@ -791,37 +790,9 @@ compile = \case newargs <- mapM compile _nodeCallArgs callClosure ref newargs -isZero :: Term Natural -> Term Natural -isZero a = OpEq # a # nockNatLiteral 0 - opAddress' :: Term Natural -> Term Natural opAddress' x = evaluated $ (opQuote "opAddress'" OpAddress) # x --- [a [b [c 0]]] -> [a [b c]] --- len = quote 3 -listToTuple :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Sem r (Term Natural) -listToTuple lst len = do - -- posOfLast uses stdlib so when it is evaulated the stdlib must be in the - -- subject lst must also be evaluated against the standard subject. We achieve - -- this by evaluating `lst #. posOfLastOffset` in `t1`. The address that - -- posOfLastOffset now points to must be shifted by [L] to make it relative to - -- `lst`. - -- - -- TODO: dec and the pow2 in appendRights are being evaluated twice. We should - -- have appendRights' which takes 2^n instead of n - -- - -- TODO: there is way too much arithmetic here with many calls to stdlib; this - -- makes the generated code very inefficient - withTemp lst $ \lstRef -> - withTemp len $ \lenRef -> do - lstVal <- addressTempRef lstRef - lenVal <- addressTempRef lenRef - posOfLastOffset <- appendRights [L] =<< dec lenVal - posOfLast <- appendRights emptyPath =<< dec lenVal - let t1 = (lstVal #. posOfLastOffset) >># (opAddress' (OpAddress # [R])) >># (opAddress "listToTupleLast" [L]) - return $ - OpIf # isZero lenVal # lstVal # (replaceSubterm' lstVal posOfLast t1) - argsTuplePlaceholder :: Text -> Term Natural argsTuplePlaceholder txt = nockNilTagged ("argsTuplePlaceholder-" <> txt) @@ -843,23 +814,16 @@ nockIntegralLiteral :: (Integral a) => a -> Term Natural nockIntegralLiteral = (OpQuote #) . toNock @Natural . fromIntegral -- | xs must be a list. --- ys is a (possibly empty) tuple. +-- ys is a non-empty tuple. -- the result is a tuple. --- NOTE: xs occurs twice, but that's fine because each occurrence is in a --- different if branch. --- TODO: this function generates extremely inefficient code +-- TODO: this function generates inefficient code appendToTuple :: (Member (Reader CompilerCtx) r) => Term Natural -> Term Natural -> Term Natural -> - Term Natural -> Sem r (Term Natural) -appendToTuple xs lenXs ys lenYs = do - tp1 <- listToTuple xs lenXs - tp2 <- append xs lenXs ys - -- TODO: omit the if when lenYs is known at compile-time - return $ OpIf # isZero lenYs # tp1 # tp2 +appendToTuple xs lenXs ys = append xs lenXs ys -- TODO: what does this function do? what are the arguments? -- TODO: this function generates inefficient code @@ -1121,10 +1085,14 @@ callFunWithArgs fun args = do callClosure :: (Members '[Reader CompilerCtx] r) => TempRef -> [Term Natural] -> Sem r (Term Natural) callClosure ref newArgs = do + -- We never call a closure with zero arguments: if there are no arguments then + -- there is no application and the closure is just returned. This differs from + -- the behaviour with calls to known functions which may have zero arguments. + massert (not (null newArgs)) closure <- addressTempRef ref let oldArgsNum = getClosureField ClosureArgsNum closure oldArgs = getClosureField ClosureArgs closure - allArgs <- appendToTuple oldArgs oldArgsNum (foldTermsOrNil newArgs) (nockIntegralLiteral (length newArgs)) + allArgs <- appendToTuple oldArgs oldArgsNum (foldTermsOrNil newArgs) newSubject <- replaceSubject $ \case FunCode -> Just (getClosureField FunCode closure) ArgsTuple -> Just allArgs diff --git a/src/Juvix/Compiler/Tree/Language.hs b/src/Juvix/Compiler/Tree/Language.hs index deb476e696..9369633c05 100644 --- a/src/Juvix/Compiler/Tree/Language.hs +++ b/src/Juvix/Compiler/Tree/Language.hs @@ -131,6 +131,7 @@ data NodeExtendClosure = NodeExtendClosure _nodeExtendClosureArgs :: NonEmpty Node } +-- | If _nodeCallType is 'CallClosure', then _nodeCallArgs must be non-empty. data NodeCall = NodeCall { _nodeCallInfo :: NodeInfo, _nodeCallType :: CallType, diff --git a/test/Nockma/Eval/Positive.hs b/test/Nockma/Eval/Positive.hs index 19425ef938..f8c47b19ed 100644 --- a/test/Nockma/Eval/Positive.hs +++ b/test/Nockma/Eval/Positive.hs @@ -252,9 +252,6 @@ juvixCallingConventionTests = let l :: NonEmpty Natural = 1 :| [2] l' :: NonEmpty (Term Natural) = nockNatLiteral <$> l in compilerTest "foldTermsOrNil (non-empty)" (foldTermsOrNil (toList l')) (eqNock (foldTerms (toNock @Natural <$> l))), - let l :: NonEmpty (Term Natural) = toNock <$> nonEmpty' [1 :: Natural .. 3] - in compilerTestM "list to tuple" (listToTuple (OpQuote # makeList (toList l)) (nockIntegralLiteral (length l))) $ - eqNock (foldTerms l), let l :: Term Natural = OpQuote # foldTerms (toNock @Natural <$> (1 :| [2, 3])) in compilerTest "replaceSubterm'" (replaceSubterm' l (OpQuote # toNock [R]) (OpQuote # (toNock @Natural 999))) (eqNock (toNock @Natural 1 # toNock @Natural 999)), let lst :: [Term Natural] = toNock @Natural <$> [1, 2, 3] @@ -265,20 +262,13 @@ juvixCallingConventionTests = r :: NonEmpty Natural = 3 :| [4] res :: Term Natural = foldTerms (toNock <$> prependList l r) lenL :: Term Natural = nockIntegralLiteral (length l) - lenR :: Term Natural = nockIntegralLiteral (length r) lstL = OpQuote # makeList (map toNock l) tupR = OpQuote # foldTerms (toNock <$> r) - in compilerTestM "appendToTuple (left non-empty, right non-empty)" (appendToTuple lstL lenL tupR lenR) (eqNock res), - let l :: NonEmpty Natural = 1 :| [2] - res :: Term Natural = foldTerms (toNock <$> l) - lenL :: Term Natural = nockIntegralLiteral (length l) - lstL = OpQuote # makeList (toNock <$> (toList l)) - in compilerTestM "appendToTuple (left non-empty, right empty)" (appendToTuple lstL lenL (OpQuote # nockNilTagged "appendToTuple") (nockNatLiteral 0)) (eqNock res), + in compilerTestM "appendToTuple (left non-empty, right non-empty)" (appendToTuple lstL lenL tupR) (eqNock res), let r :: NonEmpty Natural = 3 :| [4] res :: Term Natural = foldTerms (toNock <$> r) - lenR :: Term Natural = nockIntegralLiteral (length r) tupR = OpQuote # foldTerms (toNock <$> r) - in compilerTestM "appendToTuple (left empty, right-nonempty)" (appendToTuple (OpQuote # nockNilTagged "test-appendtotuple") (nockNatLiteral 0) tupR lenR) (eqNock res), + in compilerTestM "appendToTuple (left empty, right-nonempty)" (appendToTuple (OpQuote # nockNilTagged "test-appendtotuple") (nockNatLiteral 0) tupR) (eqNock res), compilerTestM "stdlib cat" (callStdlib StdlibCatBytes [nockNatLiteral 2, nockNatLiteral 1]) (eqNock [nock| 258 |]), compilerTestM "fold bytes empty" (callStdlib StdlibFoldBytes [OpQuote # makeList []]) (eqNock [nock| 0 |]), compilerTestM "fold bytes [1, 0, 0] == 1" (callStdlib StdlibFoldBytes [OpQuote # makeList (toNock @Natural <$> [1, 0, 0])]) (eqNock [nock| 1 |]), From 22a65a7abf3fbd71eea584d6b0efc3129c73bb1a Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 7 Oct 2024 15:49:17 +0200 Subject: [PATCH 18/18] fix compilation --- .../Compiler/Nockma/Translation/FromTree.hs | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 19fc49ede7..60d33c3c16 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -122,8 +122,7 @@ data CompilerCtx = CompilerCtx -- | Maps temporary variables to their stack indices. _compilerTempVarMap :: HashMap Int TempRef, _compilerTempVarsNum :: Int, - _compilerStackHeight :: Int, - _compilerOptions :: CompilerOptions + _compilerStackHeight :: Int } emptyCompilerCtx :: CompilerCtx @@ -133,8 +132,7 @@ emptyCompilerCtx = _compilerConstructorInfos = mempty, _compilerTempVarMap = mempty, _compilerTempVarsNum = 0, - _compilerStackHeight = 0, - _compilerOptions = CompilerOptions True + _compilerStackHeight = 0 } data ConstructorInfo = ConstructorInfo @@ -723,13 +721,9 @@ compile = \case goTrace :: Term Natural -> Sem r (Term Natural) goTrace arg = do - enabled <- asks (^. compilerOptions . compilerOptionsEnableTrace) - if - | enabled -> - withTemp arg $ \ref -> do - val <- addressTempRef ref - return $ OpHint # (nockHintAtom NockHintPuts # val) # val - | otherwise -> return arg + withTemp arg $ \ref -> do + val <- addressTempRef ref + return $ OpHint # (nockHintAtom NockHintPuts # val) # val goBinop :: Tree.NodeBinop -> Sem r (Term Natural) goBinop Tree.NodeBinop {..} = do @@ -953,7 +947,7 @@ remakeList :: (Foldable l) => l (Term Natural) -> Term Natural remakeList ts = foldTerms (toList ts `prependList` pure (OpQuote # nockNilTagged "remakeList")) runCompilerWith :: CompilerOptions -> ConstructorInfos -> [CompilerFunction] -> CompilerFunction -> AnomaResult -runCompilerWith opts constrs moduleFuns mainFun = +runCompilerWith _opts constrs moduleFuns mainFun = AnomaResult { _anomaClosure = mainClosure }