From 2b8da9410381de95ea269c923c91cf474cf95d87 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Wed, 28 Jul 2021 17:33:30 -0400 Subject: [PATCH 1/6] Fix return value of MVar.tryRead --- .../src/Unison/Runtime/Builtin.hs | 28 ++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index a174faae9..1aa3886cd 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -980,6 +980,20 @@ outIoFailBool stack1 stack2 stack3 bool fail result = $ TCon eitherReference 1 [bool]) ] +outIoFailG + :: Var v => v -> v -> v -> v -> v + -> ((ANormal v -> ANormal v) -> ([Mem], ANormal v)) + -> ANormal v +outIoFailG stack1 stack2 fail result output k + = TMatch result . MatchSum $ mapFromList + [ (0, ([BX, BX],) + . TAbss [stack1, stack2] + . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) + $ TCon eitherReference 0 [fail]) + , (1, k $ \t -> TLetD output BX t + $ TCon eitherReference 1 [output]) + ] + -- Input / Output glue -- -- These are pairings of input and output functions to handle a @@ -1103,6 +1117,18 @@ boxToEFBox = where (arg, result, stack1, stack2, fail) = fresh5 +-- a -> Either Failure (Maybe b) +boxToEFMBox :: ForeignOp +boxToEFMBox + = inBx arg result + . outIoFailG stack1 stack2 fail result output $ \k -> + ([UN], TAbs stack3 . TMatch stack3 . MatchSum $ mapFromList + [ (0, ([], k $ TCon Ty.optionalRef 0 [])) + , (1, ([BX], TAbs stack4 . k $ TCon Ty.optionalRef 1 [stack4])) + ]) + where + (arg, result, stack1, stack2, stack3, stack4, fail, output) = fresh8 + -- a -> Maybe b boxToMaybeBox :: ForeignOp boxToMaybeBox = @@ -1553,7 +1579,7 @@ declareForeigns = do declareForeign "MVar.read.impl.v3" boxBoxToEFBox . mkForeignIOF $ \(mv :: MVar Closure) -> readMVar mv - declareForeign "MVar.tryRead.impl.v3" boxToEFBox + declareForeign "MVar.tryRead.impl.v3" boxToEFMBox . mkForeignIOF $ \(mv :: MVar Closure) -> tryReadMVar mv declareForeign "Char.toText" (wordDirect Ty.charRef) . mkForeign $ From 501a3c3ab647b8b4ae81b1874fc02fadd82e9a43 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Wed, 28 Jul 2021 17:34:24 -0400 Subject: [PATCH 2/6] Add more debug info when `dumpData` goes wrong --- .../src/Unison/Runtime/MCode.hs | 9 +++--- .../src/Unison/Runtime/Machine.hs | 28 +++++++++++-------- parser-typechecker/tests/Unison/Test/MCode.hs | 2 +- 3 files changed, 23 insertions(+), 16 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/MCode.hs b/parser-typechecker/src/Unison/Runtime/MCode.hs index ce1ff63e4..b791045a3 100644 --- a/parser-typechecker/src/Unison/Runtime/MCode.hs +++ b/parser-typechecker/src/Unison/Runtime/MCode.hs @@ -408,7 +408,8 @@ data Instr !Args -- arguments to pack -- Unpack the contents of a data type onto the stack - | Unpack !Int -- stack index of data to unpack + | Unpack !(Maybe Reference) -- debug reference + !Int -- stack index of data to unpack -- Push a particular value onto the appropriate stack | Lit !MLit -- value to push onto the stack @@ -738,13 +739,13 @@ emitSection _ _ _ ctx (TLit l) | otherwise = addCount 1 0 emitSection rns grpn rec ctx (TMatch v bs) | Just (i,BX) <- ctxResolve ctx v - , MatchData _ cs df <- bs - = Ins (Unpack i) + , MatchData r cs df <- bs + = Ins (Unpack (Just r) i) <$> emitDataMatching rns grpn rec ctx cs df | Just (i,BX) <- ctxResolve ctx v , MatchRequest hs0 df <- bs , hs <- mapFromList $ first (dnum rns) <$> M.toList hs0 - = Ins (Unpack i) + = Ins (Unpack Nothing i) <$> emitRequestMatching rns grpn rec ctx hs df | Just (i,UN) <- ctxResolve ctx v , MatchIntegral cs df <- bs diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index b21798325..5c51f24d8 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -275,8 +275,8 @@ exec !_ !denv !ustk !bstk !k (Pack r t args) = do bstk <- bump bstk poke bstk clo pure (denv, ustk, bstk, k) -exec !_ !denv !ustk !bstk !k (Unpack i) = do - (ustk, bstk) <- dumpData ustk bstk =<< peekOff bstk i +exec !_ !denv !ustk !bstk !k (Unpack r i) = do + (ustk, bstk) <- dumpData r ustk bstk =<< peekOff bstk i pure (denv, ustk, bstk, k) exec !_ !denv !ustk !bstk !k (Print i) = do t <- peekOffBi bstk i @@ -607,49 +607,55 @@ buildData !ustk !bstk !r !t (DArgV ui bi) = do {-# inline buildData #-} dumpData - :: Stack 'UN -> Stack 'BX -> Closure -> IO (Stack 'UN, Stack 'BX) -dumpData !ustk !bstk (Enum _ t) = do + :: Maybe Reference + -> Stack 'UN + -> Stack 'BX + -> Closure + -> IO (Stack 'UN, Stack 'BX) +dumpData !_ !ustk !bstk (Enum _ t) = do ustk <- bump ustk pokeN ustk t pure (ustk, bstk) -dumpData !ustk !bstk (DataU1 _ t x) = do +dumpData !_ !ustk !bstk (DataU1 _ t x) = do ustk <- bumpn ustk 2 pokeOff ustk 1 x pokeN ustk t pure (ustk, bstk) -dumpData !ustk !bstk (DataU2 _ t x y) = do +dumpData !_ !ustk !bstk (DataU2 _ t x y) = do ustk <- bumpn ustk 3 pokeOff ustk 2 y pokeOff ustk 1 x pokeN ustk t pure (ustk, bstk) -dumpData !ustk !bstk (DataB1 _ t x) = do +dumpData !_ !ustk !bstk (DataB1 _ t x) = do ustk <- bump ustk bstk <- bump bstk poke bstk x pokeN ustk t pure (ustk, bstk) -dumpData !ustk !bstk (DataB2 _ t x y) = do +dumpData !_ !ustk !bstk (DataB2 _ t x y) = do ustk <- bump ustk bstk <- bumpn bstk 2 pokeOff bstk 1 y poke bstk x pokeN ustk t pure (ustk, bstk) -dumpData !ustk !bstk (DataUB _ t x y) = do +dumpData !_ !ustk !bstk (DataUB _ t x y) = do ustk <- bumpn ustk 2 bstk <- bump bstk pokeOff ustk 1 x poke bstk y pokeN ustk t pure (ustk, bstk) -dumpData !ustk !bstk (DataG _ t us bs) = do +dumpData !_ !ustk !bstk (DataG _ t us bs) = do ustk <- dumpSeg ustk us S bstk <- dumpSeg bstk bs S ustk <- bump ustk pokeN ustk t pure (ustk, bstk) -dumpData !_ !_ clo = die $ "dumpData: bad closure: " ++ show clo +dumpData !mr !_ !_ clo + = die $ "dumpData: bad closure: " ++ show clo + ++ maybe "" (\r -> "\nexpected type: " ++ show r) mr {-# inline dumpData #-} -- Note: although the representation allows it, it is impossible diff --git a/parser-typechecker/tests/Unison/Test/MCode.hs b/parser-typechecker/tests/Unison/Test/MCode.hs index a3a416d6a..18c61cd36 100644 --- a/parser-typechecker/tests/Unison/Test/MCode.hs +++ b/parser-typechecker/tests/Unison/Test/MCode.hs @@ -70,7 +70,7 @@ env m = mapInsert (bit 24) m $ cenv asrt :: Section -asrt = Ins (Unpack 0) +asrt = Ins (Unpack Nothing 0) $ Match 0 $ Test1 1 (Yield ZArgs) (Die "assertion failed") From e1f374dc151f022f9ecc4eec39b6850386e87a0e Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Wed, 28 Jul 2021 17:57:04 -0400 Subject: [PATCH 3/6] Implement separate `universalEq` and use it for EQLU - Some things are ineligible for ordering, like MVars, but can be compared for equality just fine. --- .../src/Unison/Runtime/Foreign.hs | 6 +++- .../src/Unison/Runtime/Machine.hs | 5 +--- .../src/Unison/Runtime/Stack.hs | 30 +++++++++++++++++++ 3 files changed, 36 insertions(+), 5 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Foreign.hs b/parser-typechecker/src/Unison/Runtime/Foreign.hs index 34f5bac91..dc7720495 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign.hs @@ -16,7 +16,7 @@ module Unison.Runtime.Foreign , Failure(..) ) where -import Control.Concurrent (ThreadId) +import Control.Concurrent (ThreadId, MVar) import Data.Text (Text, unpack) import Data.Tagged (Tagged(..)) import Network.Socket (Socket) @@ -43,6 +43,10 @@ ref2eq r | r == Ty.textRef = Just $ promote ((==) @Text) | r == Ty.termLinkRef = Just $ promote ((==) @Referent) | r == Ty.typeLinkRef = Just $ promote ((==) @Reference) + | r == Ty.bytesRef = Just $ promote ((==) @Bytes) + -- Note: MVar equality is just reference equality, so it shouldn't + -- matter what type the MVar holds. + | r == Ty.mvarRef = Just $ promote ((==) @(MVar ())) | otherwise = Nothing ref2cmp :: Reference -> Maybe (a -> b -> Ordering) diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 5c51f24d8..0c5764e54 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -256,10 +256,7 @@ exec !_ !denv !ustk !bstk !k (BPrim2 EQLU i j) = do x <- peekOff bstk i y <- peekOff bstk j ustk <- bump ustk - poke ustk - $ case universalCompare compare x y of - EQ -> 1 - _ -> 0 + poke ustk $ if universalEq (==) x y then 1 else 0 pure (denv, ustk, bstk, k) exec !_ !denv !ustk !bstk !k (BPrim2 CMPU i j) = do x <- peekOff bstk i diff --git a/parser-typechecker/src/Unison/Runtime/Stack.hs b/parser-typechecker/src/Unison/Runtime/Stack.hs index 18603820e..679b4d154 100644 --- a/parser-typechecker/src/Unison/Runtime/Stack.hs +++ b/parser-typechecker/src/Unison/Runtime/Stack.hs @@ -17,6 +17,7 @@ module Unison.Runtime.Stack , Off , SZ , FP + , universalEq , universalCompare , marshalToForeign , unull @@ -164,6 +165,35 @@ closureNum Captured{} = 2 closureNum Foreign{} = 3 closureNum BlackHole{} = error "BlackHole" +universalEq + :: (Foreign -> Foreign -> Bool) + -> Closure + -> Closure + -> Bool +universalEq frn = eqc False + where + eql cm l r = length l == length r && and (zipWith cm l r) + eqc tyEq (DataC rf1 ct1 us1 bs1) (DataC rf2 ct2 us2 bs2) + = (if tyEq then rf1 == rf2 else True) + && ct1 == ct2 + && eql (==) us1 us2 + && eql (eqc $ tyEq || rf1 == Ty.anyRef) bs1 bs2 + eqc tyEq (PApV i1 us1 bs1) (PApV i2 us2 bs2) + = i1 == i2 + && eql (==) us1 us2 + && eql (eqc tyEq) bs1 bs2 + eqc _ (CapV k1 us1 bs1) (CapV k2 us2 bs2) + = k1 == k2 + && eql (==) us1 us2 + && eql (eqc True) bs1 bs2 + eqc tyEq (Foreign fl) (Foreign fr) + | Just sl <- maybeUnwrapForeign Ty.listRef fl + , Just sr <- maybeUnwrapForeign Ty.listRef fr + = length sl == length sr && and (Sq.zipWith (eqc tyEq) sl sr) + | otherwise = frn fl fr + eqc _ c d = closureNum c == closureNum d + + universalCompare :: (Foreign -> Foreign -> Ordering) -> Closure From bc4b6ceb25eb23921f47412eda31a03ccbe1602e Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 29 Jul 2021 11:08:12 -0400 Subject: [PATCH 4/6] Add some tryRead tests --- unison-src/new-runtime-failing-transcripts/mvar.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/unison-src/new-runtime-failing-transcripts/mvar.md b/unison-src/new-runtime-failing-transcripts/mvar.md index 8ee495fff..8472af7f2 100644 --- a/unison-src/new-runtime-failing-transcripts/mvar.md +++ b/unison-src/new-runtime-failing-transcripts/mvar.md @@ -29,10 +29,12 @@ testMvars _ = ma2 = !MVar.newEmpty check "tryTake should succeed when not empty" (not (isNone (tryTake ma))) + check "tryRead should succeed when not empty" (not (isNone (tryRead ma))) check "tryTake should not succeed when empty" (isNone (tryTake ma)) check "ma2 should be empty" (isEmpty ma2) check "tryTake should fail when empty" (isNone (tryTake ma2)) + check "tryRead should fail when empty" (isNone (tryRead ma2)) runTest test From 46ee8b9295c5fb13e105a8ccb32bbac69a3ace1b Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 29 Jul 2021 12:30:25 -0400 Subject: [PATCH 5/6] Move mvar.md back to valid transcripts --- .../mvar.md | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename unison-src/{new-runtime-failing-transcripts => transcripts-using-base}/mvar.md (100%) diff --git a/unison-src/new-runtime-failing-transcripts/mvar.md b/unison-src/transcripts-using-base/mvar.md similarity index 100% rename from unison-src/new-runtime-failing-transcripts/mvar.md rename to unison-src/transcripts-using-base/mvar.md From e12334fd64aa342e2667de0f9dad7eef8ec9a8ae Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 29 Jul 2021 12:31:23 -0400 Subject: [PATCH 6/6] Fix mvar transcript - Also add output --- unison-src/transcripts-using-base/mvar.md | 11 +++++++++-- .../transcripts-using-base/mvar.output.md | 19 ++++++++++++++++--- 2 files changed, 25 insertions(+), 5 deletions(-) diff --git a/unison-src/transcripts-using-base/mvar.md b/unison-src/transcripts-using-base/mvar.md index 8472af7f2..ccaa8b5ae 100644 --- a/unison-src/transcripts-using-base/mvar.md +++ b/unison-src/transcripts-using-base/mvar.md @@ -11,6 +11,11 @@ blocks, Queues, etc. ```unison +eitherCk : (a -> Boolean) -> Either e a -> Boolean +eitherCk f = cases + Left _ -> false + Right x -> f x + testMvars: '{io2.IO}[Result] testMvars _ = test = 'let @@ -28,13 +33,15 @@ testMvars _ = expectU "swap returns old contents" test2 test''' ma2 = !MVar.newEmpty + check "tryRead should succeed when not empty" + (eitherCk (x -> not (isNone x)) (tryRead.impl ma)) check "tryTake should succeed when not empty" (not (isNone (tryTake ma))) - check "tryRead should succeed when not empty" (not (isNone (tryRead ma))) check "tryTake should not succeed when empty" (isNone (tryTake ma)) check "ma2 should be empty" (isEmpty ma2) check "tryTake should fail when empty" (isNone (tryTake ma2)) - check "tryRead should fail when empty" (isNone (tryRead ma2)) + check "tryRead should fail when empty" + (eitherCk isNone (tryRead.impl ma2)) runTest test diff --git a/unison-src/transcripts-using-base/mvar.output.md b/unison-src/transcripts-using-base/mvar.output.md index 4889374f7..112c4e032 100644 --- a/unison-src/transcripts-using-base/mvar.output.md +++ b/unison-src/transcripts-using-base/mvar.output.md @@ -11,6 +11,11 @@ blocks, Queues, etc. ```unison +eitherCk : (a -> Boolean) -> Either e a -> Boolean +eitherCk f = cases + Left _ -> false + Right x -> f x + testMvars: '{io2.IO}[Result] testMvars _ = test = 'let @@ -28,11 +33,15 @@ testMvars _ = expectU "swap returns old contents" test2 test''' ma2 = !MVar.newEmpty + check "tryRead should succeed when not empty" + (eitherCk (x -> not (isNone x)) (tryRead.impl ma)) check "tryTake should succeed when not empty" (not (isNone (tryTake ma))) check "tryTake should not succeed when empty" (isNone (tryTake ma)) check "ma2 should be empty" (isEmpty ma2) check "tryTake should fail when empty" (isNone (tryTake ma2)) + check "tryRead should fail when empty" + (eitherCk isNone (tryRead.impl ma2)) runTest test @@ -46,7 +55,8 @@ testMvars _ = ⍟ These new definitions are ok to `add`: - testMvars : '{io2.IO} [Result] + eitherCk : (a ->{g} Boolean) -> Either e a ->{g} Boolean + testMvars : '{IO} [Result] ``` ```ucm @@ -54,7 +64,8 @@ testMvars _ = ⍟ I've added these definitions: - testMvars : '{io2.IO} [Result] + eitherCk : (a ->{g} Boolean) -> Either e a ->{g} Boolean + testMvars : '{IO} [Result] .> io.test testMvars @@ -65,12 +76,14 @@ testMvars _ = ◉ testMvars ma should be empty ◉ testMvars swap returns old contents ◉ testMvars swap returns old contents + ◉ testMvars tryRead should succeed when not empty ◉ testMvars tryTake should succeed when not empty ◉ testMvars tryTake should not succeed when empty ◉ testMvars ma2 should be empty ◉ testMvars tryTake should fail when empty + ◉ testMvars tryRead should fail when empty - ✅ 9 test(s) passing + ✅ 11 test(s) passing Tip: Use view testMvars to view the source of a test.