Merge pull request #2273 from unisonweb/fix/misc

Assorted fixes

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 $

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)

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
+  , MatchData r cs df <- bs
-  =  Ins (Unpack i)
+  =  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

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
+  poke ustk $ if universalEq (==) x y then 1 else 0
-    $ case universalCompare compare x y of
-        EQ -> 1
-        _ -> 0
   pure (denv, ustk, bstk, k)
 exec !_   !denv !ustk !bstk !k (BPrim2 CMPU i j) = do
   x <- peekOff bstk i
@@ -275,8 +272,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
+exec !_   !denv !ustk !bstk !k (Unpack r i) = do
-  (ustk, bstk) <- dumpData ustk bstk =<< peekOff bstk i
+  (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 +604,55 @@ buildData !ustk !bstk !r !t (DArgV ui bi) = do
 {-# inline buildData #-}
 
 dumpData
-  :: Stack 'UN -> Stack 'BX -> Closure -> IO (Stack 'UN, Stack 'BX)
+  :: Maybe Reference
-dumpData !ustk !bstk (Enum _ t) = do
+  -> 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

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

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")

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,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

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.