mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-21 15:28:15 +03:00
commit
3857b896f6
@ -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 $
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
@ -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
|
||||
(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 +604,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
|
||||
|
@ -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
|
||||
|
@ -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")
|
||||
|
@ -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
|
@ -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.
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user