unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-22 07:48:10 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #1706 from unisonweb/topic/mobile-code

Browse Source 
Pull in some changes from the mobile code development
This commit is contained in:
Paul Chiusano 2020-10-01 18:45:10 -04:00 committed by GitHub
commit 71ff9f7c48
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
15 changed files with 620 additions and 536 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs
View File

@ -189,13 +189,16 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
evalUnisonFile :: PPE.PrettyPrintEnv -> UF.TypecheckedUnisonFile v Ann -> _
evalUnisonFile ppe (UF.discardTypes -> unisonFile) = do
let codeLookup = Codebase.toCodeLookup codebase
selfContained <- Codebase.makeSelfContained' codeLookup unisonFile
evalFile <-
if Runtime.needsContainment rt
then Codebase.makeSelfContained' codeLookup unisonFile
else pure unisonFile
let watchCache (Reference.DerivedId h) = do
m1 <- Codebase.getWatch codebase UF.RegularWatch h
m2 <- maybe (Codebase.getWatch codebase UF.TestWatch h) (pure . Just) m1
pure $ Term.amap (const ()) <$> m2
watchCache Reference.Builtin{} = pure Nothing
r <- Runtime.evaluateWatches codeLookup ppe watchCache rt selfContained
r <- Runtime.evaluateWatches codeLookup ppe watchCache rt evalFile
case r of
Left e -> pure (Left e)
Right rs@(_,map) -> do

8
parser-typechecker/src/Unison/Codebase/Runtime.hs
View File

@ -35,6 +35,7 @@ data Runtime v = Runtime
-> Term v
-> IO (Either Error (Term v))
, mainType :: Type v Ann
, needsContainment :: Bool
}
type IsCacheHit = Bool
@ -125,8 +126,11 @@ evaluateTerm
evaluateTerm codeLookup ppe rt tm = do
let uf = UF.UnisonFileId mempty mempty mempty
(Map.singleton UF.RegularWatch [(Var.nameds "result", tm)])
selfContained <- Codebase.makeSelfContained' codeLookup uf
r <- evaluateWatches codeLookup ppe noCache rt selfContained
runnable <-
if needsContainment rt
then Codebase.makeSelfContained' codeLookup uf
else pure uf
r <- evaluateWatches codeLookup ppe noCache rt runnable
pure $ r <&> \(_,map) ->
let [(_loc, _kind, _hash, _src, value, _isHit)] = Map.elems map
in value

110
parser-typechecker/src/Unison/Runtime/ANF.hs
View File

@ -64,7 +64,7 @@ module Unison.Runtime.ANF
import Unison.Prelude
import Control.Monad.Reader (ReaderT(..), asks, local)
import Control.Monad.Reader (ReaderT(..), ask, local)
import Control.Monad.State (State, runState, MonadState(..), modify, gets)
import Control.Lens (snoc, unsnoc)
@ -473,22 +473,22 @@ data Mem = UN | BX deriving (Eq,Ord,Show,Enum)
-- Context entries with evaluation strategy
data CTE v s
= ST [v] [Mem] s
| LZ v (Either Word64 v) [v]
| LZ v (Either Reference v) [v]
deriving (Show)
pattern ST1 v m s = ST [v] [m] s
data ANormalBF v e
= ALet [Mem] (ANormalTF v e) e
| AName (Either Word64 v) [v] e
| AName (Either Reference v) [v] e
| ATm (ANormalTF v e)
deriving (Show)
data ANormalTF v e
= ALit Lit
| AMatch v (Branched e)
| AShift RTag e
| AHnd [RTag] v e
| AShift Reference e
| AHnd [Reference] v e
| AApp (Func v) [v]
| AFrc v
| AVar v
@ -676,7 +676,7 @@ data SeqEnd = SLeft | SRight
data Branched e
= MatchIntegral (EnumMap Word64 e) (Maybe e)
| MatchText (Map.Map Text e) (Maybe e)
| MatchRequest (EnumMap RTag (EnumMap CTag ([Mem], e))) e
| MatchRequest (Map Reference (EnumMap CTag ([Mem], e))) e
| MatchEmpty
| MatchData Reference (EnumMap CTag ([Mem], e)) (Maybe e)
| MatchSum (EnumMap Word64 ([Mem], e))
@ -694,7 +694,7 @@ data BranchAccum v
| AccumDefault (ANormal v)
| AccumPure (ANormal v)
| AccumRequest
(EnumMap RTag (EnumMap CTag ([Mem],ANormal v)))
(Map Reference (EnumMap CTag ([Mem],ANormal v)))
(Maybe (ANormal v))
| AccumData
Reference
@ -739,7 +739,7 @@ instance Semigroup (BranchAccum v) where
AccumRequest hl dl <> AccumRequest hr dr
= AccumRequest hm $ dl <|> dr
where
hm = EC.unionWith (<>) hl hr
hm = Map.unionWith (<>) hl hr
l@(AccumSeqEmpty _) <> AccumSeqEmpty _ = l
AccumSeqEmpty eml <> AccumSeqView er _ cnr
= AccumSeqView er (Just eml) cnr
@ -777,13 +777,13 @@ data Func v
-- variable
= FVar v
-- top-level combinator
| FComb !Word64
| FComb !Reference
-- continuation jump
| FCont v
-- data constructor
| FCon !RTag !CTag
| FCon !Reference !CTag
-- ability request
| FReq !RTag !CTag
| FReq !Reference !CTag
-- prim op
| FPrim (Either POp FOp)
deriving (Show, Functor, Foldable, Traversable)
@ -869,22 +869,13 @@ data SuperGroup v
, entry :: SuperNormal v
} deriving (Show)
type ANFM v
= ReaderT (Set v, Reference -> Word64, Reference -> RTag)
(State (Word64, [(v, SuperNormal v)]))
resolveTerm :: Reference -> ANFM v Word64
resolveTerm r = asks $ \(_, rtm, _) -> rtm r
resolveType :: Reference -> ANFM v RTag
resolveType r = asks $ \(_, _, rty) -> rty r
type ANFM v = ReaderT (Set v) (State (Word64, [(v, SuperNormal v)]))
groupVars :: ANFM v (Set v)
groupVars = asks $ \(grp, _, _) -> grp
groupVars = ask
bindLocal :: Ord v => [v] -> ANFM v r -> ANFM v r
bindLocal vs
= local $ \(gr, rw, rt) -> (gr Set.\\ Set.fromList vs, rw, rt)
bindLocal vs = local (Set.\\ Set.fromList vs)
freshANF :: Var v => Word64 -> v
freshANF fr = Var.freshenId fr $ typed Var.ANFBlank
@ -903,19 +894,14 @@ contextualize tm = fresh <&> \fv -> ([ST1 fv BX tm], fv)
record :: Var v => (v, SuperNormal v) -> ANFM v ()
record p = modify $ \(fr, to) -> (fr, p:to)
superNormalize
:: Var v
=> (Reference -> Word64)
-> (Reference -> RTag)
-> Term v a
-> SuperGroup v
superNormalize rtm rty tm = Rec l c
superNormalize :: Var v => Term v a -> SuperGroup v
superNormalize tm = Rec l c
where
(bs, e) | LetRecNamed' bs e <- tm = (bs, e)
| otherwise = ([], tm)
grp = Set.fromList $ fst <$> bs
comp = traverse_ superBinding bs *> toSuperNormal e
subc = runReaderT comp (grp, rtm, rty)
subc = runReaderT comp grp
(c, (_,l)) = runState subc (0, [])
superBinding :: Var v => (v, Term v a) -> ANFM v ()
@ -968,12 +954,12 @@ anfBlock (If' c t f) = do
anfBlock (And' l r) = do
(lctx, vl) <- anfArg l
(rctx, vr) <- anfArg r
i <- resolveTerm $ Builtin "Boolean.and"
let i = Builtin "Boolean.and"
pure (lctx ++ rctx, ACom i [vl, vr])
anfBlock (Or' l r) = do
(lctx, vl) <- anfArg l
(rctx, vr) <- anfArg r
i <- resolveTerm $ Builtin "Boolean.or"
let i = Builtin "Boolean.or"
pure (lctx ++ rctx, ACom i [vl, vr])
anfBlock (Handle' h body)
= anfArg h >>= \(hctx, vh) ->
@ -1019,7 +1005,7 @@ anfBlock (Match' scrut cas) = do
| [ST _ _ _] <- cx = error "anfBlock: impossible"
| otherwise = AFrc v
pure ( sctx ++ [LZ hv (Right r) vs]
, AHnd (EC.keys abr) hv . TTm $ msc
, AHnd (Map.keys abr) hv . TTm $ msc
)
AccumText df cs ->
pure (sctx ++ cx, AMatch v $ MatchText cs df)
@ -1036,9 +1022,8 @@ anfBlock (Match' scrut cas) = do
error "anfBlock: non-exhaustive AccumSeqEmpty"
AccumSeqView en (Just em) bd -> do
r <- fresh
op <- case en of
SLeft -> resolveTerm $ Builtin "List.viewl"
_ -> resolveTerm $ Builtin "List.viewr"
let op | SLeft <- en = Builtin "List.viewl"
| otherwise = Builtin "List.viewr"
pure ( sctx ++ cx ++ [ST1 r BX (ACom op [v])]
, AMatch r
$ MatchData Ty.seqViewRef
@ -1080,21 +1065,16 @@ anfBlock (Apps' f args) = do
(actx, cas) <- anfArgs args
pure (fctx ++ actx, AApp cf cas)
anfBlock (Constructor' r t)
= resolveType r <&> \rt -> ([], ACon rt (toEnum t) [])
anfBlock (Request' r t) = do
r <- resolveType r
pure ([], AReq r (toEnum t) [])
anfBlock (Boolean' b) =
resolveType Ty.booleanRef <&> \rt ->
([], ACon rt (if b then 1 else 0) [])
= pure ([], ACon r (toEnum t) [])
anfBlock (Request' r t) = pure ([], AReq r (toEnum t) [])
anfBlock (Boolean' b)
= pure ([], ACon Ty.booleanRef (if b then 1 else 0) [])
anfBlock (Lit' l@(T _)) =
pure ([], ALit l)
anfBlock (Lit' l) = do
lv <- fresh
rt <- resolveType $ litRef l
pure ([ST1 lv UN $ ALit l], ACon rt 0 [lv])
anfBlock (Ref' r) =
resolveTerm r <&> \n -> ([], ACom n [])
pure ([ST1 lv UN $ ALit l], ACon (litRef l) 0 [lv])
anfBlock (Ref' r) = pure ([], ACom r [])
anfBlock (Blank' _) = do
ev <- fresh
pure ([ST1 ev BX (ALit (T "Blank"))], APrm EROR [ev])
@ -1153,15 +1133,14 @@ anfInitCase u (MatchCase p guard (ABT.AbsN' vs bd))
let (us, uk)
= maybe (error "anfInitCase: unsnoc impossible") id
$ unsnoc exp
n <- resolveType r
jn <- resolveTerm $ Builtin "jumpCont"
let jn = Builtin "jumpCont"
kf <- fresh
flip AccumRequest Nothing
. EC.mapSingleton n
. Map.singleton r
. EC.mapSingleton (toEnum t)
. (BX<$us,)
. ABTN.TAbss us
. TShift n kf
. TShift r kf
. TName uk (Left jn) [kf]
<$> anfBody bd
| P.SequenceLiteral _ [] <- p
@ -1223,12 +1202,9 @@ anfCases u = fmap fold . traverse (anfInitCase u)
anfFunc :: Var v => Term v a -> ANFM v (Ctx v, Func v)
anfFunc (Var' v) = pure ([], FVar v)
anfFunc (Ref' r)
= resolveTerm r <&> \n -> ([], FComb n)
anfFunc (Constructor' r t)
= resolveType r <&> \rt -> ([], FCon rt $ toEnum t)
anfFunc (Request' r t)
= resolveType r <&> \rt -> ([], FReq rt $ toEnum t)
anfFunc (Ref' r) = pure ([], FComb r)
anfFunc (Constructor' r t) = pure ([], FCon r $ toEnum t)
anfFunc (Request' r t) = pure ([], FReq r $ toEnum t)
anfFunc tm = do
(fctx, ctm) <- anfBlock tm
(cx, v) <- contextualize ctm
@ -1278,9 +1254,9 @@ sink v mtm tm = dive $ freeVarsT tm
indent :: Int -> ShowS
indent ind = showString (replicate (ind*2) ' ')
prettyGroup :: Var v => SuperGroup v -> ShowS
prettyGroup (Rec grp ent)
= showString "let rec\n"
prettyGroup :: Var v => String -> SuperGroup v -> ShowS
prettyGroup s (Rec grp ent)
= showString ("let rec[" ++ s ++ "]\n")
. foldr f id grp
. showString "entry"
. prettySuperNormal 1 ent
@ -1358,17 +1334,17 @@ prettyANFT m ind tm = prettySpace m ind . case tm of
. prettyVars vs . showString "."
. prettyANF False (ind+1) bo
AHnd rs v bo
-> showString "handle" . prettyTags rs
-> showString "handle" . prettyRefs rs
. prettyANF False (ind+1) bo
. showString " with " . pvar v
prettyLZF :: Var v => Either Word64 v -> ShowS
prettyLZF :: Var v => Either Reference v -> ShowS
prettyLZF (Left w) = showString "ENV(" . shows w . showString ") "
prettyLZF (Right v) = pvar v . showString " "
prettyTags :: [RTag] -> ShowS
prettyTags [] = showString "{}"
prettyTags (r:rs)
prettyRefs :: [Reference] -> ShowS
prettyRefs [] = showString "{}"
prettyRefs (r:rs)
= showString "{" . shows r
. foldr (\t r -> shows t . showString "," . r) id rs
. showString "}"
@ -1404,7 +1380,7 @@ prettyBranches ind bs = case bs of
-> foldr (\(r,m) s ->
foldr (\(c,e) -> prettyCase ind (prettyReq r c) e)
s (mapToList $ snd <$> m))
(prettyCase ind (prettyReq 0 0) df id) (mapToList bs)
(prettyCase ind (prettyReq 0 0) df id) (Map.toList bs)
MatchSum bs
-> foldr (uncurry $ prettyCase ind . shows) id
(mapToList $ snd <$> bs)

160
parser-typechecker/src/Unison/Runtime/Builtin.hs
View File

@ -14,9 +14,6 @@ module Unison.Runtime.Builtin
, builtinTypeBackref
, builtinForeigns
, numberedTermLookup
, charTag
, natTag
, eitherTag
) where
import Control.Exception (IOException, try)
@ -111,22 +108,9 @@ freshes' avoid0 = go avoid0 []
= let v = freshIn avoid $ typed ANFBlank
in go (insert v avoid) (v:vs) (n-1)
boolTag, intTag, natTag, floatTag, charTag :: RTag
boolTag = rtag Ty.booleanRef
intTag = rtag Ty.intRef
natTag = rtag Ty.natRef
floatTag = rtag Ty.floatRef
charTag = rtag Ty.charRef
optionTag, eitherTag, pairTag, seqViewTag :: RTag
optionTag = rtag Ty.optionalRef
eitherTag = rtag eitherReference
pairTag = rtag Ty.pairRef
seqViewTag = rtag Ty.seqViewRef
fls, tru :: Var v => ANormal v
fls = TCon boolTag 0 []
tru = TCon boolTag 1 []
fls = TCon Ty.booleanRef 0 []
tru = TCon Ty.booleanRef 1 []
boolift :: Var v => v -> ANormalT v
boolift v
@ -172,7 +156,7 @@ unop' pop rfi rfo
= unop0 2 $ \[x0,x,r]
-> unbox x0 rfi x
. TLet r UN (APrm pop [x])
$ TCon (rtag rfo) 0 [r]
$ TCon rfo 0 [r]
binop :: Var v => POp -> Reference -> SuperNormal v
binop pop rf = binop' pop rf rf rf
@ -187,7 +171,7 @@ binop' pop rfx rfy rfr
-> unbox x0 rfx x
. unbox y0 rfy y
. TLet r UN (APrm pop [x,y])
$ TCon (rtag rfr) 0 [r]
$ TCon rfr 0 [r]
cmpop :: Var v => POp -> Reference -> SuperNormal v
cmpop pop rf
@ -339,8 +323,8 @@ trni = unop0 3 $ \[x0,x,z,b]
. TLet b UN (APrm LEQI [x, z])
. TMatch b
$ MatchIntegral
(mapSingleton 1 $ TCon natTag 0 [z])
(Just $ TCon natTag 0 [x])
(mapSingleton 1 $ TCon Ty.natRef 0 [z])
(Just $ TCon Ty.natRef 0 [x])
modular :: Var v => POp -> (Bool -> ANormal v) -> SuperNormal v
modular pop ret
@ -368,7 +352,7 @@ dropn = binop0 4 $ \[x0,y0,x,y,b,r]
(AMatch b $ MatchIntegral
(mapSingleton 1 $ TLit $ N 0)
(Just $ TPrm SUBN [x,y]))
$ TCon (rtag Ty.natRef) 0 [r]
$ TCon Ty.natRef 0 [r]
appendt, taket, dropt, sizet, unconst, unsnoct :: Var v => SuperNormal v
appendt = binop0 0 $ \[x,y] -> TPrm CATT [x,y]
@ -380,24 +364,24 @@ dropt = binop0 1 $ \[x0,y,x]
$ TPrm DRPT [x,y]
sizet = unop0 1 $ \[x,r]
-> TLet r UN (APrm SIZT [x])
$ TCon (rtag Ty.natRef) 0 [r]
$ TCon Ty.natRef 0 [r]
unconst = unop0 5 $ \[x,t,c0,c,y,p]
-> TLet t UN (APrm UCNS [x])
. TMatch t . MatchSum $ mapFromList
[ (0, ([], TCon optionTag 0 []))
[ (0, ([], TCon Ty.optionalRef 0 []))
, (1, ([UN,BX], TAbss [c0,y]
. TLet c BX (ACon charTag 0 [c0])
. TLet p BX (ACon pairTag 0 [c,y])
$ TCon optionTag 1 [p]))
. TLet c BX (ACon Ty.charRef 0 [c0])
. TLet p BX (ACon Ty.pairRef 0 [c,y])
$ TCon Ty.optionalRef 1 [p]))
]
unsnoct = unop0 5 $ \[x,t,c0,c,y,p]
-> TLet t UN (APrm USNC [x])
. TMatch t . MatchSum $ mapFromList
[ (0, ([], TCon optionTag 0 []))
[ (0, ([], TCon Ty.optionalRef 0 []))
, (1, ([BX,UN], TAbss [y,c0]
. TLet c BX (ACon charTag 0 [c0])
. TLet p BX (ACon pairTag 0 [y,c])
$ TCon optionTag 1 [p]))
. TLet c BX (ACon Ty.charRef 0 [c0])
. TLet p BX (ACon Ty.pairRef 0 [y,c])
$ TCon Ty.optionalRef 1 [p]))
]
appends, conss, snocs :: Var v => SuperNormal v
@ -414,13 +398,13 @@ drops = binop0 1 $ \[x0,y,x]
$ TPrm DRPS [x,y]
sizes = unop0 1 $ \[x,r]
-> TLet r UN (APrm SIZS [x])
$ TCon natTag 0 [r]
$ TCon Ty.natRef 0 [r]
ats = binop0 3 $ \[x0,y,x,t,r]
-> unbox x0 Ty.natRef x
. TLet t UN (APrm IDXS [x,y])
. TMatch t . MatchSum $ mapFromList
[ (0, ([], TCon optionTag 0 []))
, (1, ([BX], TAbs r $ TCon optionTag 1 [r]))
[ (0, ([], TCon Ty.optionalRef 0 []))
, (1, ([BX], TAbs r $ TCon Ty.optionalRef 1 [r]))
]
emptys = Lambda [] $ TPrm BLDS []
@ -428,14 +412,14 @@ viewls, viewrs :: Var v => SuperNormal v
viewls = unop0 3 $ \[s,u,h,t]
-> TLet u UN (APrm VWLS [s])
. TMatch u . MatchSum $ mapFromList
[ (0, ([], TCon seqViewTag 0 []))
, (1, ([BX,BX], TAbss [h,t] $ TCon seqViewTag 1 [h,t]))
[ (0, ([], TCon Ty.seqViewRef 0 []))
, (1, ([BX,BX], TAbss [h,t] $ TCon Ty.seqViewRef 1 [h,t]))
]
viewrs = unop0 3 $ \[s,u,i,l]
-> TLet u UN (APrm VWRS [s])
. TMatch u . MatchSum $ mapFromList
[ (0, ([], TCon seqViewTag 0 []))
, (1, ([BX,BX], TAbss [i,l] $ TCon seqViewTag 1 [i,l]))
[ (0, ([], TCon Ty.seqViewRef 0 []))
, (1, ([BX,BX], TAbss [i,l] $ TCon Ty.seqViewRef 1 [i,l]))
]
eqt, neqt, leqt, geqt, lesst, great :: Var v => SuperNormal v
@ -486,15 +470,15 @@ atb = binop0 4 $ \[n0,b,n,t,r0,r]
-> unbox n0 Ty.natRef n
. TLet t UN (APrm IDXB [n,b])
. TMatch t . MatchSum $ mapFromList
[ (0, ([], TCon optionTag 0 []))
[ (0, ([], TCon Ty.optionalRef 0 []))
, (1, ([UN], TAbs r0
. TLet r BX (ACon natTag 0 [r0])
$ TCon optionTag 1 [r]))
. TLet r BX (ACon Ty.natRef 0 [r0])
$ TCon Ty.optionalRef 1 [r]))
]
sizeb = unop0 1 $ \[b,n]
-> TLet n UN (APrm SIZB [b])
$ TCon natTag 0 [n]
$ TCon Ty.natRef 0 [n]
flattenb = unop0 0 $ \[b] -> TPrm FLTB [b]
@ -513,26 +497,26 @@ t2i, t2n, t2f :: Var v => SuperNormal v
t2i = unop0 3 $ \[x,t,n0,n]
-> TLet t UN (APrm TTOI [x])
. TMatch t . MatchSum $ mapFromList
[ (0, ([], TCon optionTag 0 []))
[ (0, ([], TCon Ty.optionalRef 0 []))
, (1, ([UN], TAbs n0
. TLet n BX (ACon intTag 0 [n0])
$ TCon optionTag 1 [n]))
. TLet n BX (ACon Ty.intRef 0 [n0])
$ TCon Ty.optionalRef 1 [n]))
]
t2n = unop0 3 $ \[x,t,n0,n]
-> TLet t UN (APrm TTON [x])
. TMatch t . MatchSum $ mapFromList
[ (0, ([], TCon optionTag 0 []))
[ (0, ([], TCon Ty.optionalRef 0 []))
, (1, ([UN], TAbs n0
. TLet n BX (ACon natTag 0 [n0])
$ TCon optionTag 1 [n]))
. TLet n BX (ACon Ty.natRef 0 [n0])
$ TCon Ty.optionalRef 1 [n]))
]
t2f = unop0 3 $ \[x,t,f0,f]
-> TLet t UN (APrm TTOF [x])
. TMatch t . MatchSum $ mapFromList
[ (0, ([], TCon optionTag 0 []))
[ (0, ([], TCon Ty.optionalRef 0 []))
, (1, ([UN], TAbs f0
. TLet f BX (ACon floatTag 0 [f0])
$ TCon optionTag 1 [f]))
. TLet f BX (ACon Ty.floatRef 0 [f0])
$ TCon Ty.optionalRef 1 [f]))
]
equ :: Var v => SuperNormal v
@ -544,39 +528,39 @@ cmpu :: Var v => SuperNormal v
cmpu = binop0 2 $ \[x,y,c,i]
-> TLet c UN (APrm CMPU [x,y])
. TLet i UN (APrm DECI [c])
$ TCon intTag 0 [i]
$ TCon Ty.intRef 0 [i]
ltu :: Var v => SuperNormal v
ltu = binop0 1 $ \[x,y,c]
-> TLet c UN (APrm CMPU [x,y])
. TMatch c
$ MatchIntegral
(mapFromList [ (0, TCon boolTag 1 []) ])
(Just $ TCon boolTag 0 [])
(mapFromList [ (0, TCon Ty.booleanRef 1 []) ])
(Just $ TCon Ty.booleanRef 0 [])
gtu :: Var v => SuperNormal v
gtu = binop0 1 $ \[x,y,c]
-> TLet c UN (APrm CMPU [x,y])
. TMatch c
$ MatchIntegral
(mapFromList [ (2, TCon boolTag 1 []) ])
(Just $ TCon boolTag 0 [])
(mapFromList [ (2, TCon Ty.booleanRef 1 []) ])
(Just $ TCon Ty.booleanRef 0 [])
geu :: Var v => SuperNormal v
geu = binop0 1 $ \[x,y,c]
-> TLet c UN (APrm CMPU [x,y])
. TMatch c
$ MatchIntegral
(mapFromList [ (0, TCon boolTag 0 []) ])
(Just $ TCon boolTag 1 [])
(mapFromList [ (0, TCon Ty.booleanRef 0 []) ])
(Just $ TCon Ty.booleanRef 1 [])
leu :: Var v => SuperNormal v
leu = binop0 1 $ \[x,y,c]
-> TLet c UN (APrm CMPU [x,y])
. TMatch c
$ MatchIntegral
(mapFromList [ (2, TCon boolTag 0 []) ])
(Just $ TCon boolTag 1 [])
(mapFromList [ (2, TCon Ty.booleanRef 0 []) ])
(Just $ TCon Ty.booleanRef 1 [])
notb :: Var v => SuperNormal v
notb = unop0 0 $ \[b]
@ -600,7 +584,7 @@ cast :: Var v => Reference -> Reference -> SuperNormal v
cast ri ro
= unop0 1 $ \[x0,x]
-> unbox x0 ri x
$ TCon (rtag ro) 0 [x]
$ TCon ro 0 [x]
jumpk :: Var v => SuperNormal v
jumpk = binop0 0 $ \[k,a] -> TKon k [a]
@ -609,7 +593,7 @@ fork'comp :: Var v => SuperNormal v
fork'comp
= Lambda [BX]
. TAbs act
. TLet unit BX (ACon (rtag Ty.unitRef) 0 [])
. TLet unit BX (ACon Ty.unitRef 0 [])
. TName lz (Right act) [unit]
$ TPrm FORK [lz]
where
@ -634,8 +618,8 @@ maybe'result'direct
maybe'result'direct ins args t r
= TLet t UN (AFOp ins args)
. TMatch t . MatchSum $ mapFromList
[ (0, ([], TCon optionTag 0 []))
, (1, ([BX], TAbs r $ TCon optionTag 1 [r]))
[ (0, ([], TCon Ty.optionalRef 0 []))
, (1, ([BX], TAbs r $ TCon Ty.optionalRef 1 [r]))
]
io'error'result0
@ -647,7 +631,7 @@ io'error'result0 ins args ior ccs vs e nx
= TLet ior UN (AFOp ins args)
. TMatch ior . MatchSum
$ mapFromList
[ (0, ([BX], TAbs e $ TCon eitherTag 0 [e]))
[ (0, ([BX], TAbs e $ TCon eitherReference 0 [e]))
, (1, (ccs, TAbss vs nx))
]
@ -659,7 +643,7 @@ io'error'result'let
io'error'result'let ins args ior ccs vs e r m
= io'error'result0 ins args ior ccs vs e
. TLet r BX m
$ TCon eitherTag 1 [r]
$ TCon eitherReference 1 [r]
io'error'result'direct
:: Var v
@ -668,7 +652,7 @@ io'error'result'direct
-> ANormal v
io'error'result'direct ins args ior e r
= io'error'result0 ins args ior [BX] [r] e
$ TCon eitherTag 1 [r]
$ TCon eitherReference 1 [r]
io'error'result'unit
:: Var v
@ -677,7 +661,7 @@ io'error'result'unit
-> ANormal v
io'error'result'unit ins args ior e r
= io'error'result'let ins args ior [] [] e r
$ ACon (rtag Ty.unitRef) 0 []
$ ACon Ty.unitRef 0 []
io'error'result'bool
:: Var v
@ -752,7 +736,7 @@ handle'position instr
= ([BX],)
. TAbss [h]
. io'error'result'let instr [h] ior [UN] [i] e r
$ (ACon (rtag Ty.intRef) 0 [i])
$ (ACon Ty.intRef 0 [i])
where
[h,i,ior,e,r] = freshes 5
@ -763,23 +747,23 @@ get'buffering instr
. io'error'result'let instr [h] ior [UN] [bu] e r
. AMatch bu . MatchSum
$ mapFromList
[ (0, ([], TCon (rtag Ty.optionalRef) 0 []))
[ (0, ([], TCon Ty.optionalRef 0 []))
, (1, ([], line))
, (2, ([], block'nothing))
, (3, ([UN], TAbs n $ block'n))
]
where
[h,bu,ior,e,r,m,n,b] = freshes 8
final = TCon (rtag Ty.optionalRef) 1 [b]
block = TLet b BX (ACon (rtag bufferModeReference) 1 [m]) $ final
final = TCon Ty.optionalRef 1 [b]
block = TLet b BX (ACon bufferModeReference 1 [m]) $ final
line
= TLet b BX (ACon (rtag bufferModeReference) 0 []) $ final
= TLet b BX (ACon bufferModeReference 0 []) $ final
block'nothing
= TLet m BX (ACon (rtag Ty.optionalRef) 0 [])
= TLet m BX (ACon Ty.optionalRef 0 [])
$ block
block'n
= TLet m BX (ACon (rtag Ty.optionalRef) 1 [n])
= TLet m BX (ACon Ty.optionalRef 1 [n])
$ block
set'buffering :: ForeignOp
@ -847,7 +831,7 @@ system'time :: ForeignOp
system'time instr
= ([],)
. io'error'result'let instr [] ior [UN] [n] e r
$ ACon (rtag Ty.natRef) 0 [n]
$ ACon Ty.natRef 0 [n]
where
[n,ior,e,r] = freshes 4
@ -855,7 +839,7 @@ get'temp'directory :: ForeignOp
get'temp'directory instr
= ([],)
. io'error'result'let instr [] ior [BX] [t] e r
$ ACon (rtag filePathReference) 0 [t]
$ ACon filePathReference 0 [t]
where
[t,ior,e,r] = freshes 4
@ -863,7 +847,7 @@ get'current'directory :: ForeignOp
get'current'directory instr
= ([],)
. io'error'result'let instr [] ior [BX] [t] e r
$ ACon (rtag filePathReference) 0 [r]
$ ACon filePathReference 0 [r]
where
[t,e,r,ior] = freshes 4
@ -941,7 +925,7 @@ get'file'timestamp instr
= ([BX],)
. TAbs fp
. io'error'result'let instr [fp] ior [UN] [n] e r
$ ACon (rtag Ty.natRef) 0 [n]
$ ACon Ty.natRef 0 [n]
where
[fp,n,ior,e,r] = freshes 5
@ -950,7 +934,7 @@ get'file'size instr
= ([BX],)
. TAbs fp
. io'error'result'let instr [fp] ior [UN] [n] e r
$ ACon (rtag Ty.natRef) 0 [n]
$ ACon Ty.natRef 0 [n]
where
[fp,n,ior,e,r] = freshes 5
@ -1020,8 +1004,8 @@ socket'receive instr
. io'error'result'let instr [sk,n] ior [UN] [mt] e r
. AMatch mt . MatchSum
$ mapFromList
[ (0, ([], TCon (rtag Ty.optionalRef) 0 []))
, (1, ([BX], TAbs b $ TCon (rtag Ty.optionalRef) 1 [b]))
[ (0, ([], TCon Ty.optionalRef 0 []))
, (1, ([BX], TAbs b $ TCon Ty.optionalRef 1 [b]))
]
where
[n0,sk,n,ior,e,r,b,mt] = freshes 8
@ -1408,7 +1392,7 @@ hostPreference :: Maybe Text -> SYS.HostPreference
hostPreference Nothing = SYS.HostAny
hostPreference (Just host) = SYS.Host $ Text.unpack host
typeReferences :: [(Reference, RTag)]
typeReferences :: [(Reference, Word64)]
typeReferences = zip rs [1..]
where
rs = [ r | (_,r) <- Ty.builtinTypes ]
@ -1427,10 +1411,6 @@ numberedTermLookup :: Var v => EnumMap Word64 (SuperNormal v)
numberedTermLookup
= mapFromList . zip [1..] . Map.elems $ builtinLookup
rtag :: Reference -> RTag
rtag r | Just x <- Map.lookup r builtinTypeNumbering = x
| otherwise = error $ "rtag: unknown reference: " ++ show r
builtinTermNumbering :: Map Reference Word64
builtinTermNumbering
= Map.fromList (zip (Map.keys $ builtinLookup @Symbol) [1..])
@ -1439,10 +1419,10 @@ builtinTermBackref :: EnumMap Word64 Reference
builtinTermBackref
= mapFromList . zip [1..] . Map.keys $ builtinLookup @Symbol
builtinTypeNumbering :: Map Reference RTag
builtinTypeNumbering :: Map Reference Word64
builtinTypeNumbering = Map.fromList typeReferences
builtinTypeBackref :: EnumMap RTag Reference
builtinTypeBackref :: EnumMap Word64 Reference
builtinTypeBackref = mapFromList $ swap <$> typeReferences
where swap (x, y) = (y, x)

20
parser-typechecker/src/Unison/Runtime/Debug.hs
View File

@ -24,14 +24,15 @@ type Term v = Tm.Term v ()
traceComb :: Bool -> Word64 -> Comb -> Bool
traceComb False _ _ = True
traceComb True w c = trace (prettyComb w c "\n") True
traceComb True w c = trace (prettyComb w 0 c "\n") True
traceCombs
:: Bool
-> (Comb, EnumMap Word64 Comb, Word64)
-> (Comb, EnumMap Word64 Comb, Word64)
traceCombs False c = c
traceCombs True c = trace (prettyCombs c "") c
:: Word64
-> Bool
-> EnumMap Word64 Comb
-> EnumMap Word64 Comb
traceCombs _ False c = c
traceCombs w True c = trace (prettyCombs w c "") c
tracePretty
:: Var v
@ -44,9 +45,10 @@ tracePretty ppe True tm = trace (toANSI 50 $ pretty ppe tm) tm
tracePrettyGroup
:: Var v
=> Bool
=> Word64
-> Bool
-> SuperGroup v
-> SuperGroup v
tracePrettyGroup False g = g
tracePrettyGroup True g = trace (prettyGroup g "") g
tracePrettyGroup _ False g = g
tracePrettyGroup w True g = trace (prettyGroup (show w) g "") g

59
parser-typechecker/src/Unison/Runtime/Decompile.hs
View File

@ -23,11 +23,10 @@ import Unison.Type
import Unison.Var (Var)
import Unison.Reference (Reference)
import Unison.Runtime.ANF (RTag, CTag, Tag(..))
import Unison.Runtime.Foreign
(Foreign, maybeUnwrapBuiltin, maybeUnwrapForeign)
import Unison.Runtime.Stack
(Closure(..), pattern DataC, pattern PApV, IComb(..))
(Closure(..), pattern DataC, pattern PApV, CombIx(..))
import Unison.Codebase.Runtime (Error)
import Unison.Util.Pretty (lit)
@ -36,47 +35,44 @@ import qualified Unison.Util.Bytes as By
import Unsafe.Coerce -- for Int -> Double
con :: Var v => Reference -> CTag -> Term v ()
con rf ct = constructor () rf . fromIntegral $ rawTag ct
con :: Var v => Reference -> Word64 -> Term v ()
con rf ct = constructor () rf $ fromIntegral ct
err :: String -> Either Error a
err = Left . lit . fromString
decompile
:: Var v
=> (RTag -> Maybe Reference)
-> (Word64 -> Maybe (Term v ()))
=> (Word64 -> Maybe (Term v ()))
-> Closure
-> Either Error (Term v ())
decompile tyRef _ (DataC rt ct [] [])
| Just rf <- tyRef rt
, rf == booleanRef
decompile _ (DataC rf ct [] [])
| rf == booleanRef
= boolean () <$> tag2bool ct
decompile tyRef _ (DataC rt ct [i] [])
| Just rf <- tyRef rt
decompile _ (DataC rf ct [i] [])
= decompileUnboxed rf ct i
decompile tyRef topTerms (DataC rt ct [] bs)
| Just rf <- tyRef rt
= apps' (con rf ct) <$> traverse (decompile tyRef topTerms) bs
decompile tyRef topTerms (PApV (IC rt _) [] bs)
decompile topTerms (DataC rf ct [] bs)
= apps' (con rf ct) <$> traverse (decompile topTerms) bs
decompile _ (PApV (CIx _ _ n) _ _) | n > 0
= err "cannot decompile an application to a local recusive binding"
decompile topTerms (PApV (CIx _ rt 0) [] bs)
| Just t <- topTerms rt
= substitute t <$> traverse (decompile tyRef topTerms) bs
= substitute t <$> traverse (decompile topTerms) bs
| otherwise
= err "reference to unknown combinator"
decompile _ _ cl@(PAp _ _ _)
decompile _ cl@(PAp _ _ _)
= err $ "cannot decompile a partial application to unboxed values: "
++ show cl
decompile _ _ (DataC{})
decompile _ (DataC{})
= err "cannot decompile data type with multiple unboxed fields"
decompile _ _ BlackHole = err "exception"
decompile _ _ (Captured{}) = err "decompiling a captured continuation"
decompile tyRef topTerms (Foreign f) = decompileForeign tyRef topTerms f
decompile _ BlackHole = err "exception"
decompile _ (Captured{}) = err "decompiling a captured continuation"
decompile topTerms (Foreign f) = decompileForeign topTerms f
tag2bool :: CTag -> Either Error Bool
tag2bool c = case rawTag c of
0 -> Right False
1 -> Right True
_ -> err "bad boolean tag"
tag2bool :: Word64 -> Either Error Bool
tag2bool 0 = Right False
tag2bool 1 = Right True
tag2bool _ = err "bad boolean tag"
substitute :: Var v => Term v () -> [Term v ()] -> Term v ()
substitute (AbsN' vs bd) ts = align [] vs ts
@ -89,7 +85,7 @@ substitute (AbsN' vs bd) ts = align [] vs ts
substitute _ _ = error "impossible"
decompileUnboxed
:: Var v => Reference -> CTag -> Int -> Either Error (Term v ())
:: Var v => Reference -> Word64 -> Int -> Either Error (Term v ())
decompileUnboxed r _ i
| r == natRef = pure . nat () $ fromIntegral i
| r == intRef = pure . int () $ fromIntegral i
@ -100,16 +96,15 @@ decompileUnboxed r _ _
decompileForeign
:: Var v
=> (RTag -> Maybe Reference)
-> (Word64 -> Maybe (Term v ()))
=> (Word64 -> Maybe (Term v ()))
-> Foreign
-> Either Error (Term v ())
decompileForeign tyRef topTerms f
decompileForeign topTerms f
| Just t <- maybeUnwrapBuiltin f = Right $ text () t
| Just b <- maybeUnwrapBuiltin f = Right $ decompileBytes b
| Just s <- unwrapSeq f
= seq' () <$> traverse (decompile tyRef topTerms) s
decompileForeign _ _ _ = err "cannot decompile Foreign"
= seq' () <$> traverse (decompile topTerms) s
decompileForeign _ _ = err "cannot decompile Foreign"
decompileBytes :: Var v => By.Bytes -> Term v ()
decompileBytes

144
parser-typechecker/src/Unison/Runtime/Interface.hs
View File

@ -6,6 +6,8 @@ module Unison.Runtime.Interface
( startRuntime
) where
import GHC.Stack (HasCallStack)
import Control.Exception (try)
import Control.Monad (foldM, (<=<))
@ -16,6 +18,7 @@ import Data.Word (Word64)
import qualified Data.Map.Strict as Map
import qualified Unison.ABT as Tm (substs)
import qualified Unison.Term as Tm
import Unison.Var (Var)
@ -47,13 +50,13 @@ type Term v = Tm.Term v ()
data EvalCtx v
= ECtx
{ freshTy :: Int
{ freshTy :: Word64
, freshTm :: Word64
, refTy :: Map.Map RF.Reference RTag
, refTy :: Map.Map RF.Reference Word64
, refTm :: Map.Map RF.Reference Word64
, combs :: EnumMap Word64 Comb
, combs :: EnumMap Word64 Combs
, dspec :: DataSpec
, backrefTy :: EnumMap RTag RF.Reference
, backrefTy :: EnumMap Word64 RF.Reference
, backrefTm :: EnumMap Word64 (Term v)
, backrefComb :: EnumMap Word64 RF.Reference
}
@ -63,11 +66,6 @@ uncurryDspec = Map.fromList . concatMap f . Map.toList
where
f (r,l) = zipWith (\n c -> ((r,n),c)) [0..] $ either id id l
numberLetRec :: Word64 -> Term v -> EnumMap Word64 (Term v)
numberLetRec frsh (Tm.LetRecNamed' bs e)
= mapFromList . zip [frsh..] $ e : map snd bs
numberLetRec _ _ = error "impossible"
baseContext :: forall v. Var v => EvalCtx v
baseContext
= ECtx
@ -75,7 +73,9 @@ baseContext
, freshTm = ftm
, refTy = builtinTypeNumbering
, refTm = builtinTermNumbering
, combs = emitComb @v mempty <$> numberedTermLookup
, combs = mapSingleton 0
. emitComb @v emptyRNs 0 mempty
<$> numberedTermLookup
, dspec = builtinDataSpec
, backrefTy = builtinTypeBackref
, backrefTm = Tm.ref () <$> builtinTermBackref
@ -83,18 +83,44 @@ baseContext
}
where
ftm = 1 + maximum builtinTermNumbering
fty = (1+) . fromEnum $ maximum builtinTypeNumbering
fty = 1 + maximum builtinTypeNumbering
-- allocTerm
-- :: Var v
-- => CodeLookup v m ()
-- -> EvalCtx v
-- -> RF.Reference
-- -> IO (EvalCtx v)
-- allocTerm _ _ b@(RF.Builtin _)
-- = die $ "Unknown builtin term reference: " ++ show b
-- allocTerm _ _ (RF.DerivedId _)
-- = die $ "TODO: allocTerm: hash reference"
allocTerm
:: Var v
=> EvalCtx v
-> RF.Reference
-> Term v
-> EvalCtx v
allocTerm ctx r tm = snd $ allocTerm' ctx r tm
allocTerm'
:: Var v
=> EvalCtx v
-> RF.Reference
-> Term v
-> (Word64, EvalCtx v)
allocTerm' ctx r tm
| Just w <- Map.lookup r (refTm ctx) = (w, ctx)
| rt <- freshTm ctx
= (rt, ctx
{ refTm = Map.insert r rt $ refTm ctx
, backrefTm = mapInsert rt tm $ backrefTm ctx
, backrefComb = mapInsert rt r $ backrefComb ctx
, freshTm = rt+1
})
allocTermRef
:: Var v
=> CodeLookup v IO ()
-> EvalCtx v
-> RF.Reference
-> IO (EvalCtx v)
allocTermRef _ _ b@(RF.Builtin _)
= die $ "Unknown builtin term reference: " ++ show b
allocTermRef cl ctx r@(RF.DerivedId i)
= getTerm cl i >>= \case
Nothing -> die $ "Unknown term reference: " ++ show r
Just tm -> pure $ allocTerm ctx r tm
allocType
:: EvalCtx v
@ -113,7 +139,7 @@ allocType ctx r cons
where
(rt, fresh)
| Just rt <- Map.lookup r $ refTy ctx = (rt, freshTy ctx)
| frsh <- freshTy ctx = (toEnum $ frsh, frsh + 1)
| frsh <- freshTy ctx = (frsh, frsh + 1)
collectDeps
:: Var v
@ -138,49 +164,72 @@ loadDeps
-> Term v
-> IO (EvalCtx v)
loadDeps cl ctx tm = do
(tys, _ ) <- collectDeps cl tm
(tys, tms) <- collectDeps cl tm
-- TODO: terms
foldM (uncurry . allocType) ctx $ filter p tys
ctx <- foldM (uncurry . allocType) ctx $ filter p tys
ctx <- foldM (allocTermRef cl) ctx $ filter q tms
pure $ foldl' compileAllocated ctx $ filter q tms
where
p (r@RF.DerivedId{},_)
= r `Map.notMember` dspec ctx
|| r `Map.notMember` refTy ctx
p _ = False
addCombs :: EnumMap Word64 Comb -> EvalCtx v -> EvalCtx v
addCombs m ctx = ctx { combs = m <> combs ctx }
q r@RF.DerivedId{} = r `Map.notMember` refTm ctx
q _ = False
addTermBackrefs :: EnumMap Word64 (Term v) -> EvalCtx v -> EvalCtx v
addTermBackrefs refs ctx = ctx { backrefTm = refs <> backrefTm ctx }
compileAllocated
:: HasCallStack => Var v => EvalCtx v -> Reference -> EvalCtx v
compileAllocated ctx r
| Just w <- Map.lookup r (refTm ctx)
, Just tm <- EC.lookup w (backrefTm ctx)
= compileTerm w tm ctx
| otherwise
= error "compileAllocated: impossible"
refresh :: Word64 -> EvalCtx v -> EvalCtx v
refresh w ctx = ctx { freshTm = w }
addCombs :: EvalCtx v -> Word64 -> Combs -> EvalCtx v
addCombs ctx w m = ctx { combs = mapInsert w m $ combs ctx }
ref :: Ord k => Show k => Map.Map k v -> k -> v
-- addTermBackrefs :: EnumMap Word64 (Term v) -> EvalCtx v -> EvalCtx v
-- addTermBackrefs refs ctx = ctx { backrefTm = refs <> backrefTm ctx }
-- refresh :: Word64 -> EvalCtx v -> EvalCtx v
-- refresh w ctx = ctx { freshTm = w }
ref :: HasCallStack => Ord k => Show k => Map.Map k v -> k -> v
ref m k
| Just x <- Map.lookup k m = x
| otherwise = error $ "unknown reference: " ++ show k
compileTerm
:: Var v => Word64 -> Term v -> EvalCtx v -> EvalCtx v
:: HasCallStack => Var v => Word64 -> Term v -> EvalCtx v -> EvalCtx v
compileTerm w tm ctx
= finish
. fmap
( emitCombs frsh
. superNormalize (ref $ refTm ctx) (ref $ refTy ctx))
. bkrf
= addCombs ctx w
. emitCombs (RN (ref $ refTy ctx) (ref $ refTm ctx)) w
. superNormalize
. lamLift
. splitPatterns (dspec ctx)
. saturate (uncurryDspec $ dspec ctx)
$ tm
prepareEvaluation
:: HasCallStack => Var v => Term v -> EvalCtx v -> (EvalCtx v, Word64)
prepareEvaluation (Tm.LetRecNamed' bs mn0) ctx0 = (ctx4, mid)
where
frsh = freshTm ctx
bkrf tm = (numberLetRec frsh tm, tm)
finish (recs, (main, aux, frsh'))
= refresh frsh'
. addTermBackrefs recs
. addCombs (mapInsert w main aux)
$ ctx
hcs = fmap (first RF.DerivedId) . Tm.hashComponents $ Map.fromList bs
mn = Tm.substs (Map.toList $ Tm.ref () . fst <$> hcs) mn0
rmn = RF.DerivedId $ Tm.hashClosedTerm mn
ctx1 = foldl (uncurry . allocTerm) ctx0 hcs
ctx2 = foldl (\ctx (r, _) -> compileAllocated ctx r) ctx1 hcs
(mid, ctx3) = allocTerm' ctx2 rmn mn
ctx4 = compileTerm mid mn ctx3
prepareEvaluation mn ctx0 = (ctx2, mid)
where
rmn = RF.DerivedId $ Tm.hashClosedTerm mn
(mid, ctx1) = allocTerm' ctx0 rmn mn
ctx2 = compileTerm mid mn ctx1
watchHook :: IORef Closure -> Stack 'UN -> Stack 'BX -> IO ()
watchHook r _ bstk = peek bstk >>= writeIORef r
@ -204,7 +253,7 @@ evalInContext ppe ctx w = do
<=< try $ apply0 (Just hook) senv w
pure $ decom =<< result
where
decom = decompile (`EC.lookup`backrefTy ctx) (`EC.lookup`backrefTm ctx)
decom = decompile (`EC.lookup`backrefTm ctx)
prettyError (PE p) = p
prettyError (BU c) = either id (pretty ppe) $ decom c
@ -217,9 +266,8 @@ startRuntime = do
ctx <- readIORef ctxVar
ctx <- loadDeps cl ctx tm
writeIORef ctxVar ctx
let init = freshTm ctx
ctx <- pure $ refresh (init+1) ctx
ctx <- pure $ compileTerm init tm ctx
(ctx, init) <- pure $ prepareEvaluation tm ctx
evalInContext ppe ctx init
, mainType = builtinMain External
, needsContainment = False
}

288
parser-typechecker/src/Unison/Runtime/MCode.hs
View File

@ -8,10 +8,12 @@
module Unison.Runtime.MCode
( Args'(..)
, Args(..)
, RefNums(..)
, MLit(..)
, Instr(..)
, Section(.., MatchT, MatchW)
, Comb(..)
, Combs
, Ref(..)
, UPrim1(..)
, UPrim2(..)
@ -22,6 +24,7 @@ module Unison.Runtime.MCode
, ucount
, emitCombs
, emitComb
, emptyRNs
, argsToLists
, prettyCombs
, prettyComb
@ -56,10 +59,8 @@ import Unison.Runtime.ANF
, Mem(..)
, SuperNormal(..)
, SuperGroup(..)
, RTag
, CTag
, Tag(..)
, packTags
, pattern TVar
, pattern TLit
, pattern TApp
@ -238,6 +239,7 @@ data Args'
-- frame index of each argument to the function
| ArgN {-# unpack #-} !(PrimArray Int)
| ArgR !Int !Int
deriving (Show)
data Args
= ZArgs
@ -396,8 +398,9 @@ data Instr
-- Pack a data type value into a closure and place it
-- on the stack.
| Pack !Word64 -- tag
!Args -- arguments to pack
| Pack !Reference -- data type reference
!Word64 -- tag
!Args -- arguments to pack
-- Unpack the contents of a data type onto the stack
| Unpack !Int -- stack index of data to unpack
@ -463,6 +466,15 @@ data Section
| Exit
deriving (Show, Eq, Ord)
data RefNums
= RN { dnum :: Reference -> Word64
, cnum :: Reference -> Word64
}
emptyRNs :: RefNums
emptyRNs = RN mt mt
where mt _ = error "RefNums: empty"
data Comb
= Lam !Int -- Number of unboxed arguments
!Int -- Number of boxed arguments
@ -471,9 +483,12 @@ data Comb
!Section -- Entry
deriving (Show, Eq, Ord)
type Combs = EnumMap Word64 Comb
data Ref
= Stk !Int -- stack reference to a closure
| Env !Word64 -- global environment reference to a combinator
!Word64 -- section
| Dyn !Word64 -- dynamic scope reference to a closure
deriving (Show, Eq, Ord)
@ -567,18 +582,21 @@ rctxResolve :: Var v => RCtx v -> v -> Maybe Word64
rctxResolve ctx u = M.lookup u ctx
-- Compile a top-level definition group to a collection of combinators.
-- The values in the recursive group are numbered according to the
-- provided word.
-- The provided word refers to the numbering for the overall group,
-- and intra-group calls are numbered locally, with 0 specifying
-- the global entry point.
emitCombs
:: Var v => Word64 -> SuperGroup v
-> (Comb, EnumMap Word64 Comb, Word64)
emitCombs frsh (Rec grp ent)
= (emitComb rec ent, EC.mapFromList aux, frsh')
:: Var v
=> RefNums
-> Word64
-> SuperGroup v
-> EnumMap Word64 Comb
emitCombs rns lcl (Rec grp ent)
= mapInsert 0 (emitComb rns lcl rec ent) (EC.mapFromList aux)
where
frsh' = frsh + fromIntegral (length grp)
(rvs, cmbs) = unzip grp
rec = M.fromList $ zip rvs [frsh..]
aux = zip [frsh..] $ emitComb rec <$> cmbs
rec = M.fromList $ zip rvs [1..]
aux = zip [1..] $ emitComb rns lcl rec <$> cmbs
-- Type for aggregating the necessary stack frame size. First field is
-- unboxed size, second is boxed. The Applicative instance takes the
@ -602,10 +620,11 @@ countCtx = go 0 0
go ui bi (Block ctx) = go ui bi ctx
go ui bi ECtx = C ui bi
emitComb :: Var v => RCtx v -> SuperNormal v -> Comb
emitComb rec (Lambda ccs (TAbss vs bd))
emitComb
:: Var v => RefNums -> Word64 -> RCtx v -> SuperNormal v -> Comb
emitComb rns lcl rec (Lambda ccs (TAbss vs bd))
= Lam 0 (length vs) u b s
where C u b s = emitSection rec (ctx vs ccs) bd
where C u b s = emitSection rns lcl rec (ctx vs ccs) bd
addCount :: Int -> Int -> Counted a -> Counted a
addCount i j (C u b x) = C (u+i) (b+j) x
@ -613,68 +632,75 @@ addCount i j (C u b x) = C (u+i) (b+j) x
-- Emit a machine code section from an ANF term
emitSection
:: Var v
=> RCtx v -> Ctx v -> ANormal v
=> RefNums -> Word64 -> RCtx v -> Ctx v -> ANormal v
-> Counted Section
emitSection rec ctx (TLets us ms bu bo)
= emitLet rec ctx bu $ emitSection rec ectx bo
emitSection rns lcl rec ctx (TLets us ms bu bo)
= emitLet rns lcl rec ctx bu $ emitSection rns lcl rec ectx bo
where
ectx = pushCtx (zip us ms) ctx
emitSection rec ctx (TName u (Left f) args bo)
= emitClosures rec ctx args $ \ctx as
-> Ins (Name (Env f) as) <$> emitSection rec (Var u BX ctx) bo
emitSection rec ctx (TName u (Right v) args bo)
emitSection rns lcl rec ctx (TName u (Left f) args bo)
= emitClosures lcl rec ctx args $ \ctx as
-> Ins (Name (Env (cnum rns f) 0) as)
<$> emitSection rns lcl rec (Var u BX ctx) bo
emitSection rns lcl rec ctx (TName u (Right v) args bo)
| Just (i,BX) <- ctxResolve ctx v
= emitClosures rec ctx args $ \ctx as
-> Ins (Name (Stk i) as) <$> emitSection rec (Var u BX ctx) bo
= emitClosures lcl rec ctx args $ \ctx as
-> Ins (Name (Stk i) as)
<$> emitSection rns lcl rec (Var u BX ctx) bo
| Just n <- rctxResolve rec v
= emitClosures rec ctx args $ \ctx as
-> Ins (Name (Env n) as) <$> emitSection rec (Var u BX ctx) bo
= emitClosures lcl rec ctx args $ \ctx as
-> Ins (Name (Env lcl n) as)
<$> emitSection rns lcl rec (Var u BX ctx) bo
| otherwise = emitSectionVErr v
emitSection rec ctx (TVar v)
emitSection _ lcl rec ctx (TVar v)
| Just (i,BX) <- ctxResolve ctx v = countCtx ctx . Yield $ BArg1 i
| Just (i,UN) <- ctxResolve ctx v = countCtx ctx . Yield $ UArg1 i
| Just j <- rctxResolve rec v = countCtx ctx $ App False (Env j) ZArgs
| Just j <- rctxResolve rec v
= countCtx ctx $ App False (Env lcl j) ZArgs
| otherwise = emitSectionVErr v
emitSection _ ctx (TPrm p args)
emitSection _ _ _ ctx (TPrm p args)
-- 3 is a conservative estimate of how many extra stack slots
-- a prim op will need for its results.
= addCount 3 3 . countCtx ctx
. Ins (emitPOp p $ emitArgs ctx args) . Yield $ DArgV i j
where
(i, j) = countBlock ctx
emitSection _ ctx (TFOp p args)
emitSection _ _ _ ctx (TFOp p args)
= addCount 3 3 . countCtx ctx
. Ins (emitFOp p $ emitArgs ctx args) . Yield $ DArgV i j
where
(i, j) = countBlock ctx
emitSection rec ctx (TApp f args)
= emitClosures rec ctx args $ \ctx as
-> countCtx ctx $ emitFunction rec ctx f as
emitSection _ ctx (TLit l)
emitSection rns lcl rec ctx (TApp f args)
= emitClosures lcl rec ctx args $ \ctx as
-> countCtx ctx $ emitFunction rns lcl rec ctx f as
emitSection _ _ _ ctx (TLit l)
= c . countCtx ctx . Ins (emitLit l) . Yield $ litArg l
where
c | ANF.T{} <- l = addCount 0 1
| ANF.LM{} <- l = addCount 0 1
| ANF.LY{} <- l = addCount 0 1
| otherwise = addCount 1 0
emitSection rec ctx (TMatch v bs)
emitSection rns lcl rec ctx (TMatch v bs)
| Just (i,BX) <- ctxResolve ctx v
, MatchData _ cs df <- bs
= Ins (Unpack i)
<$> emitDataMatching rec ctx cs df
<$> emitDataMatching rns lcl rec ctx cs df
| Just (i,BX) <- ctxResolve ctx v
, MatchRequest hs df <- bs
, MatchRequest hs0 df <- bs
, hs <- mapFromList $ first (dnum rns) <$> M.toList hs0
= Ins (Unpack i)
<$> emitRequestMatching rec ctx hs df
<$> emitRequestMatching rns lcl rec ctx hs df
| Just (i,UN) <- ctxResolve ctx v
, MatchIntegral cs df <- bs
= emitIntegralMatching rec ctx i cs df
= emitLitMatching MatchW "missing integral case"
rns lcl rec ctx i cs df
| Just (i,BX) <- ctxResolve ctx v
, MatchText cs df <- bs
= emitTextMatching rec ctx i cs df
= emitLitMatching MatchT "missing text case"
rns lcl rec ctx i cs df
| Just (i,UN) <- ctxResolve ctx v
, MatchSum cs <- bs
= emitSumMatching rec ctx v i cs
= emitSumMatching rns lcl rec ctx v i cs
| Just (_,cc) <- ctxResolve ctx v
= error
$ "emitSection: mismatched calling convention for match: "
@ -682,54 +708,66 @@ emitSection rec ctx (TMatch v bs)
| otherwise
= error
$ "emitSection: could not resolve match variable: " ++ show (ctx,v)
emitSection rec ctx (THnd rts h b)
emitSection rns lcl rec ctx (THnd rs h b)
| Just (i,BX) <- ctxResolve ctx h
= Ins (Reset (EC.setFromList rs))
. flip (foldr (\r -> Ins (SetDyn r i))) rs
<$> emitSection rec ctx b
= Ins (Reset (EC.setFromList ws))
. flip (foldr (\r -> Ins (SetDyn r i))) ws
<$> emitSection rns lcl rec ctx b
| otherwise = emitSectionVErr h
where
rs = rawTag <$> rts
ws = dnum rns <$> rs
emitSection rec ctx (TShift i v e)
= Ins (Capture $ rawTag i)
<$> emitSection rec (Var v BX ctx) e
emitSection _ ctx (TFrc v)
emitSection rns lcl rec ctx (TShift r v e)
= Ins (Capture $ dnum rns r)
<$> emitSection rns lcl rec (Var v BX ctx) e
emitSection _ _ _ ctx (TFrc v)
| Just (i,BX) <- ctxResolve ctx v
= countCtx ctx $ App False (Stk i) ZArgs
| Just _ <- ctxResolve ctx v = error
$ "emitSection: values to be forced must be boxed: " ++ show v
| otherwise = emitSectionVErr v
emitSection _ _ tm = error $ "emitSection: unhandled code: " ++ show tm
emitSection _ _ _ _ tm
= error $ "emitSection: unhandled code: " ++ show tm
-- Emit the code for a function call
emitFunction :: Var v => RCtx v -> Ctx v -> Func v -> Args -> Section
emitFunction rec ctx (FVar v) as
emitFunction
:: Var v
=> RefNums
-> Word64 -- self combinator number
-> RCtx v -- recursive binding group
-> Ctx v -- local context
-> Func v
-> Args
-> Section
emitFunction _ lcl rec ctx (FVar v) as
| Just (i,BX) <- ctxResolve ctx v
= App False (Stk i) as
| Just j <- rctxResolve rec v
= App False (Env j) as
= App False (Env lcl j) as
| otherwise = emitSectionVErr v
emitFunction _ _ (FComb n) as
emitFunction rns _ _ _ (FComb r) as
| False -- known saturated call
= Call False n as
| False -- known unsaturated call
= Ins (Name (Env n) as) $ Yield (BArg1 0)
= Ins (Name (Env n 0) as) $ Yield (BArg1 0)
| otherwise -- slow path
= App False (Env n) as
emitFunction _ _ (FCon r t) as
= Ins (Pack (packTags r t) as)
= App False (Env n 0) as
where n = cnum rns r
emitFunction _ _ _ _ (FCon r t) as
= Ins (Pack r (rawTag t) as)
. Yield $ BArg1 0
emitFunction _ _ (FReq a e) as
emitFunction rns _ _ _ (FReq r e) as
-- Currently implementing packed calling convention for abilities
= Ins (Lit (MI . fromIntegral $ rawTag e))
. Ins (Pack (rawTag a) (reqArgs as))
. App True (Dyn $ rawTag a) $ BArg1 0
emitFunction _ ctx (FCont k) as
. Ins (Pack r a (reqArgs as))
. App True (Dyn a) $ BArg1 0
where
a = dnum rns r
emitFunction _ _ _ ctx (FCont k) as
| Just (i, BX) <- ctxResolve ctx k = Jump i as
| Nothing <- ctxResolve ctx k = emitFunctionVErr k
| otherwise = error $ "emitFunction: continuations are boxed"
emitFunction _ _ (FPrim _) _
emitFunction _ _ _ _ (FPrim _) _
= error "emitFunction: impossible"
-- Modify function arguments for packing into a request
@ -802,22 +840,24 @@ litArg _ = UArg1 0
-- manipulation.
emitLet
:: Var v
=> RCtx v -> Ctx v -> ANormalT v
=> RefNums -> Word64 -> RCtx v -> Ctx v -> ANormalT v
-> Counted Section
-> Counted Section
emitLet _ _ (ALit l)
emitLet _ _ _ _ (ALit l)
= fmap (Ins $ emitLit l)
emitLet _ ctx (AApp (FComb n) args)
emitLet rns _ _ ctx (AApp (FComb r) args)
-- We should be able to tell if we are making a saturated call
-- or not here. We aren't carrying the information here yet, though.
| False -- not saturated
= fmap (Ins . Name (Env n) $ emitArgs ctx args)
emitLet _ ctx (AApp (FCon r n) args)
= fmap (Ins . Pack (packTags r n) $ emitArgs ctx args)
emitLet _ ctx (AApp (FPrim p) args)
= fmap (Ins . Name (Env n 0) $ emitArgs ctx args)
where
n = cnum rns r
emitLet _ _ _ ctx (AApp (FCon r n) args)
= fmap (Ins . Pack r (rawTag n) $ emitArgs ctx args)
emitLet _ _ _ ctx (AApp (FPrim p) args)
= fmap (Ins . either emitPOp emitFOp p $ emitArgs ctx args)
emitLet rec ctx bnd
= liftA2 Let (emitSection rec (Block ctx) (TTm bnd))
emitLet rns lcl rec ctx bnd
= liftA2 Let (emitSection rns lcl rec (Block ctx) (TTm bnd))
-- Translate from ANF prim ops to machine code operations. The
-- machine code operations are divided with respect to more detailed
@ -998,18 +1038,20 @@ emitBP2 p a
emitDataMatching
:: Var v
=> RCtx v
=> RefNums
-> Word64
-> RCtx v
-> Ctx v
-> EnumMap CTag ([Mem], ANormal v)
-> Maybe (ANormal v)
-> Counted Section
emitDataMatching rec ctx cs df
= MatchW 0 <$> edf <*> traverse (emitCase rec ctx) (coerce cs)
emitDataMatching rns lcl rec ctx cs df
= MatchW 0 <$> edf <*> traverse (emitCase rns lcl rec ctx) (coerce cs)
where
-- Note: this is not really accurate. A default data case needs
-- stack space corresponding to the actual data that shows up there.
-- However, we currently don't use default cases for data.
edf | Just co <- df = emitSection rec ctx co
edf | Just co <- df = emitSection rns lcl rec ctx co
| otherwise = countCtx ctx $ Die "missing data case"
-- Emits code corresponding to an unboxed sum match.
@ -1019,73 +1061,68 @@ emitDataMatching rec ctx cs df
-- branching on the tag.
emitSumMatching
:: Var v
=> RCtx v
=> RefNums
-> Word64
-> RCtx v
-> Ctx v
-> v
-> Int
-> EnumMap Word64 ([Mem], ANormal v)
-> Counted Section
emitSumMatching rec ctx v i cs
= MatchW i edf <$> traverse (emitSumCase rec ctx v) cs
emitSumMatching rns lcl rec ctx v i cs
= MatchW i edf <$> traverse (emitSumCase rns lcl rec ctx v) cs
where
edf = Die "uncovered unboxed sum case"
emitRequestMatching
:: Var v
=> RCtx v
=> RefNums
-> Word64
-> RCtx v
-> Ctx v
-> EnumMap RTag (EnumMap CTag ([Mem], ANormal v))
-> EnumMap Word64 (EnumMap CTag ([Mem], ANormal v))
-> ANormal v
-> Counted Section
emitRequestMatching rec ctx hs df = MatchW 0 edf <$> tops
emitRequestMatching rns lcl rec ctx hs df = MatchW 0 edf <$> tops
where
tops = mapInsert 0
<$> emitCase rec ctx ([BX], df)
<$> emitCase rns lcl rec ctx ([BX], df)
<*> traverse f (coerce hs)
f cs = MatchW 1 edf <$> traverse (emitCase rec ctx) cs
f cs = MatchW 1 edf <$> traverse (emitCase rns lcl rec ctx) cs
edf = Die "unhandled ability"
emitIntegralMatching
emitLitMatching
:: Var v
=> RCtx v
=> Traversable f
=> (Int -> Section -> f Section -> Section)
-> String
-> RefNums
-> Word64
-> RCtx v
-> Ctx v
-> Int
-> EnumMap Word64 (ANormal v)
-> f (ANormal v)
-> Maybe (ANormal v)
-> Counted Section
emitIntegralMatching rec ctx i cs df
= MatchW i <$> edf <*> traverse (emitCase rec ctx . ([],)) cs
emitLitMatching con err rns lcl rec ctx i cs df
= con i <$> edf <*> traverse (emitCase rns lcl rec ctx . ([],)) cs
where
edf | Just co <- df = emitSection rec ctx co
| otherwise = countCtx ctx $ Die "missing integral case"
emitTextMatching
:: Var v
=> RCtx v
-> Ctx v
-> Int
-> M.Map Text (ANormal v)
-> Maybe (ANormal v)
-> Counted Section
emitTextMatching rec ctx i cs df
= MatchT i <$> edf <*> traverse (emitCase rec ctx . ([],)) cs
where
edf | Just co <- df = emitSection rec ctx co
| otherwise = countCtx ctx $ Die "missing text case"
edf | Just co <- df = emitSection rns lcl rec ctx co
| otherwise = countCtx ctx $ Die err
emitCase
:: Var v
=> RCtx v -> Ctx v -> ([Mem], ANormal v)
=> RefNums -> Word64 -> RCtx v -> Ctx v -> ([Mem], ANormal v)
-> Counted Section
emitCase rec ctx (ccs, TAbss vs bo)
= emitSection rec (Tag $ pushCtx (zip vs ccs) ctx) bo
emitCase rns lcl rec ctx (ccs, TAbss vs bo)
= emitSection rns lcl rec (Tag $ pushCtx (zip vs ccs) ctx) bo
emitSumCase
:: Var v
=> RCtx v -> Ctx v -> v -> ([Mem], ANormal v)
=> RefNums -> Word64 -> RCtx v -> Ctx v -> v -> ([Mem], ANormal v)
-> Counted Section
emitSumCase rec ctx v (ccs, TAbss vs bo)
= emitSection rec (sumCtx ctx v $ zip vs ccs) bo
emitSumCase rns lcl rec ctx v (ccs, TAbss vs bo)
= emitSection rns lcl rec (sumCtx ctx v $ zip vs ccs) bo
emitLit :: ANF.Lit -> Instr
emitLit l = Lit $ case l of
@ -1106,17 +1143,17 @@ emitLit l = Lit $ case l of
-- provided continuation.
emitClosures
:: Var v
=> RCtx v -> Ctx v -> [v]
=> Word64 -> RCtx v -> Ctx v -> [v]
-> (Ctx v -> Args -> Counted Section)
-> Counted Section
emitClosures rec ctx args k
emitClosures lcl rec ctx args k
= allocate ctx args $ \ctx -> k ctx $ emitArgs ctx args
where
allocate ctx [] k = k ctx
allocate ctx (a:as) k
| Just _ <- ctxResolve ctx a = allocate ctx as k
| Just n <- rctxResolve rec a
= Ins (Name (Env n) ZArgs) <$> allocate (Var a BX ctx) as k
= Ins (Name (Env lcl n) ZArgs) <$> allocate (Var a BX ctx) as k
| otherwise
= error $ "emitClosures: unknown reference: " ++ show a
@ -1146,16 +1183,16 @@ indent :: Int -> ShowS
indent ind = showString (replicate (ind*2) ' ')
prettyCombs
:: (Comb, EnumMap Word64 Comb, Word64)
:: Word64
-> EnumMap Word64 Comb
-> ShowS
prettyCombs (c, es, w)
= foldr (\(w,c) r -> prettyComb w c . showString "\n" . r)
prettyCombs w es
= foldr (\(i,c) r -> prettyComb w i c . showString "\n" . r)
id (mapToList es)
. showString "\n" . prettyComb w c
prettyComb :: Word64 -> Comb -> ShowS
prettyComb w (Lam ua ba _ _ s)
= shows w . shows [ua,ba]
prettyComb :: Word64 -> Word64 -> Comb -> ShowS
prettyComb w i (Lam ua ba _ _ s)
= shows w . showString ":" . shows i . shows [ua,ba]
. showString ":\n" . prettySection 2 s
prettySection :: Int -> Section -> ShowS
@ -1205,8 +1242,9 @@ bx :: ShowS
bx = ('B':)
prettyIns :: Instr -> ShowS
prettyIns (Pack i as)
= showString "Pack " . shows i . (' ':) . prettyArgs as
prettyIns (Pack r i as)
= showString "Pack " . showsPrec 10 r
. (' ':) . shows i . (' ':) . prettyArgs as
prettyIns i = shows i
prettyArgs :: Args -> ShowS

162
parser-typechecker/src/Unison/Runtime/Machine.hs
View File

@ -1,6 +1,7 @@
{-# language DataKinds #-}
{-# language RankNTypes #-}
{-# language BangPatterns #-}
{-# language ViewPatterns #-}
{-# language PatternGuards #-}
module Unison.Runtime.Machine where
@ -27,8 +28,7 @@ import Text.Read (readMaybe)
import Unison.Reference (Reference)
import Unison.Runtime.ANF (Mem(..), RTag, packTags)
import Unison.Runtime.Builtin (charTag,natTag,eitherTag)
import Unison.Runtime.ANF (Mem(..))
import Unison.Runtime.Exception
import Unison.Runtime.Foreign
import Unison.Runtime.Foreign.Function
@ -51,10 +51,10 @@ type DEnv = EnumMap Word64 Closure
-- static environment
data SEnv
= SEnv
{ combs :: !(EnumMap Word64 Comb)
{ combs :: !(EnumMap Word64 Combs)
, foreignFuncs :: !(EnumMap Word64 ForeignFunc)
, combRefs :: !(EnumMap Word64 Reference)
, tagRefs :: !(EnumMap RTag Reference)
, tagRefs :: !(EnumMap Word64 Reference)
}
info :: Show a => String -> a -> IO ()
@ -77,13 +77,14 @@ eval0 !env !co = do
apply0
:: Maybe (Stack 'UN -> Stack 'BX -> IO ())
-> SEnv -> Word64 -> IO ()
apply0 !callback !env !i
| Just cmb <- EC.lookup i (combs env) = do
apply0 !callback !env !i = do
ustk <- alloc
bstk <- alloc
r <- case EC.lookup i $ combRefs env of
Just r -> pure r
Nothing -> die "apply0: missing reference to entry point"
apply env mempty ustk bstk k0 True ZArgs
$ PAp (IC i cmb) unull bnull
| otherwise = die $ "apply0: unknown combinator: " ++ show i
$ PAp (CIx r i 0) unull bnull
where
k0 = maybe KE (CB . Hook) callback
@ -133,36 +134,26 @@ exec !_ !denv !ustk !bstk !k (UPrim2 op i j) = do
exec !_ !denv !ustk !bstk !k (BPrim1 op i) = do
(ustk,bstk) <- bprim1 ustk bstk op i
pure (denv, ustk, bstk, k)
exec !env !denv !ustk !bstk !k (BPrim2 EQLU i j) = do
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 cmb tag compare x y of
$ case universalCompare compare x y of
EQ -> 1
_ -> 0
pure (denv, ustk, bstk, k)
where
cmb w | Just r <- EC.lookup w (combRefs env) = r
| otherwise = error $ "exec: unknown combinator: " ++ show w
tag t | Just r <- EC.lookup t (tagRefs env) = r
| otherwise = error $ "exec: unknown data: " ++ show t
exec !env !denv !ustk !bstk !k (BPrim2 CMPU i j) = do
exec !_ !denv !ustk !bstk !k (BPrim2 CMPU i j) = do
x <- peekOff bstk i
y <- peekOff bstk j
ustk <- bump ustk
poke ustk . fromEnum $ universalCompare cmb tag compare x y
poke ustk . fromEnum $ universalCompare compare x y
pure (denv, ustk, bstk, k)
where
cmb w | Just r <- EC.lookup w (combRefs env) = r
| otherwise = error $ "exec: unknown combinator: " ++ show w
tag t | Just r <- EC.lookup t (tagRefs env) = r
| otherwise = error $ "exec: unknown data: " ++ show t
exec !_ !denv !ustk !bstk !k (BPrim2 op i j) = do
(ustk,bstk) <- bprim2 ustk bstk op i j
pure (denv, ustk, bstk, k)
exec !_ !denv !ustk !bstk !k (Pack t args) = do
clo <- buildData ustk bstk t args
exec !_ !denv !ustk !bstk !k (Pack r t args) = do
clo <- buildData ustk bstk r t args
bstk <- bump bstk
poke bstk clo
pure (denv, ustk, bstk, k)
@ -214,9 +205,6 @@ exec !env !denv !ustk !bstk !k (Fork i) = do
pure (denv, ustk, bstk, k)
{-# inline exec #-}
maskTag :: Word64 -> Word64
maskTag i = i .&. 0xFFFF
eval :: SEnv -> DEnv
-> Stack 'UN -> Stack 'BX -> K -> Section -> IO ()
eval !env !denv !ustk !bstk !k (Match i (TestT df cs)) = do
@ -237,7 +225,8 @@ eval !env !denv !ustk !bstk !k (App ck r args) =
resolve env denv bstk r
>>= apply env denv ustk bstk k ck args
eval !env !denv !ustk !bstk !k (Call ck n args)
| Just cmb <- EC.lookup n (combs env)
| Just cmbs <- EC.lookup n (combs env)
, Just cmb <- EC.lookup 0 cmbs
= enter env denv ustk bstk k ck args cmb
| otherwise = die $ "eval: unknown combinator: " ++ show n
eval !env !denv !ustk !bstk !k (Jump i args) =
@ -264,7 +253,7 @@ forkEval env clo
err :: Stack 'UN -> Stack 'BX -> IO ()
err _ bstk = peek bstk >>= \case
-- Left e
DataB1 t e | t == leftDTag -> throwIO $ BU e
DataB1 _ 0 e -> throwIO $ BU e
_ -> pure ()
{-# inline forkEval #-}
@ -299,7 +288,7 @@ apply
:: SEnv -> DEnv -> Stack 'UN -> Stack 'BX -> K
-> Bool -> Args -> Closure -> IO ()
apply !env !denv !ustk !bstk !k !ck !args clo = case clo of
PAp comb@(Lam_ ua ba uf bf entry) useg bseg
PAp comb@(combSection env -> Lam ua ba uf bf entry) useg bseg
| ck || ua <= uac && ba <= bac -> do
ustk <- ensure ustk uf
bstk <- ensure bstk bf
@ -440,54 +429,54 @@ closureArgs !_ _
{-# inline closureArgs #-}
buildData
:: Stack 'UN -> Stack 'BX -> Tag -> Args -> IO Closure
buildData !_ !_ !t ZArgs = pure $ Enum t
buildData !ustk !_ !t (UArg1 i) = do
:: Stack 'UN -> Stack 'BX -> Reference -> Tag -> Args -> IO Closure
buildData !_ !_ !r !t ZArgs = pure $ Enum r t
buildData !ustk !_ !r !t (UArg1 i) = do
x <- peekOff ustk i
pure $ DataU1 t x
buildData !ustk !_ !t (UArg2 i j) = do
pure $ DataU1 r t x
buildData !ustk !_ !r !t (UArg2 i j) = do
x <- peekOff ustk i
y <- peekOff ustk j
pure $ DataU2 t x y
buildData !_ !bstk !t (BArg1 i) = do
pure $ DataU2 r t x y
buildData !_ !bstk !r !t (BArg1 i) = do
x <- peekOff bstk i
pure $ DataB1 t x
buildData !_ !bstk !t (BArg2 i j) = do
pure $ DataB1 r t x
buildData !_ !bstk !r !t (BArg2 i j) = do
x <- peekOff bstk i
y <- peekOff bstk j
pure $ DataB2 t x y
buildData !ustk !bstk !t (DArg2 i j) = do
pure $ DataB2 r t x y
buildData !ustk !bstk !r !t (DArg2 i j) = do
x <- peekOff ustk i
y <- peekOff bstk j
pure $ DataUB t x y
buildData !ustk !_ !t (UArgR i l) = do
pure $ DataUB r t x y
buildData !ustk !_ !r !t (UArgR i l) = do
useg <- augSeg I ustk unull (Just $ ArgR i l)
pure $ DataG t useg bnull
buildData !_ !bstk !t (BArgR i l) = do
pure $ DataG r t useg bnull
buildData !_ !bstk !r !t (BArgR i l) = do
bseg <- augSeg I bstk bnull (Just $ ArgR i l)
pure $ DataG t unull bseg
buildData !ustk !bstk !t (DArgR ui ul bi bl) = do
pure $ DataG r t unull bseg
buildData !ustk !bstk !r !t (DArgR ui ul bi bl) = do
useg <- augSeg I ustk unull (Just $ ArgR ui ul)
bseg <- augSeg I bstk bnull (Just $ ArgR bi bl)
pure $ DataG t useg bseg
buildData !ustk !_ !t (UArgN as) = do
pure $ DataG r t useg bseg
buildData !ustk !_ !r !t (UArgN as) = do
useg <- augSeg I ustk unull (Just $ ArgN as)
pure $ DataG t useg bnull
buildData !_ !bstk !t (BArgN as) = do
pure $ DataG r t useg bnull
buildData !_ !bstk !r !t (BArgN as) = do
bseg <- augSeg I bstk bnull (Just $ ArgN as)
pure $ DataG t unull bseg
buildData !ustk !bstk !t (DArgN us bs) = do
pure $ DataG r t unull bseg
buildData !ustk !bstk !r !t (DArgN us bs) = do
useg <- augSeg I ustk unull (Just $ ArgN us)
bseg <- augSeg I bstk bnull (Just $ ArgN bs)
pure $ DataG t useg bseg
buildData !ustk !bstk !t (DArgV ui bi) = do
pure $ DataG r t useg bseg
buildData !ustk !bstk !r !t (DArgV ui bi) = do
useg <- if ul > 0
then augSeg I ustk unull (Just $ ArgR 0 ul)
else pure unull
bseg <- if bl > 0
then augSeg I bstk bnull (Just $ ArgR 0 bl)
else pure bnull
pure $ DataG t useg bseg
pure $ DataG r t useg bseg
where
ul = fsize ustk - ui
bl = fsize bstk - bi
@ -495,46 +484,46 @@ buildData !ustk !bstk !t (DArgV ui bi) = do
dumpData
:: Stack 'UN -> Stack 'BX -> Closure -> IO (Stack 'UN, Stack 'BX)
dumpData !ustk !bstk (Enum t) = do
dumpData !ustk !bstk (Enum _ t) = do
ustk <- bump ustk
pokeN ustk $ maskTag t
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 $ maskTag t
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 $ maskTag t
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 $ maskTag t
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 $ maskTag t
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 $ maskTag t
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 $ maskTag t
pokeN ustk t
pure (ustk, bstk)
dumpData !_ !_ clo = die $ "dumpData: bad closure: " ++ show clo
{-# inline dumpData #-}
@ -888,11 +877,6 @@ uprim2 !ustk XORN !i !j = do
pure ustk
{-# inline uprim2 #-}
charDTag, natDTag, leftDTag :: Word64
charDTag = packTags charTag 0
natDTag = packTags natTag 0
leftDTag = packTags eitherTag 0
bprim1
:: Stack 'UN -> Stack 'BX -> BPrim1 -> Int
-> IO (Stack 'UN, Stack 'BX)
@ -1015,13 +999,13 @@ bprim1 !ustk !bstk PAKT i = do
pokeBi bstk . Tx.pack . toList $ clo2char <$> s
pure (ustk, bstk)
where
clo2char (DataU1 t i) | charDTag == t = toEnum i
clo2char (DataU1 _ 0 i) = toEnum i
clo2char c = error $ "pack text: non-character closure: " ++ show c
bprim1 !ustk !bstk UPKT i = do
t <- peekOffBi bstk i
bstk <- bump bstk
pokeS bstk . Sq.fromList
. fmap (DataU1 charDTag . fromEnum) . Tx.unpack $ t
. fmap (DataU1 Rf.charRef 0 . fromEnum) . Tx.unpack $ t
pure (ustk, bstk)
bprim1 !ustk !bstk PAKB i = do
s <- peekOffS bstk i
@ -1029,12 +1013,12 @@ bprim1 !ustk !bstk PAKB i = do
pokeBi bstk . By.fromWord8s . fmap clo2w8 $ toList s
pure (ustk, bstk)
where
clo2w8 (DataU1 t n) | natDTag == t = toEnum n
clo2w8 (DataU1 _ 0 n) = toEnum n
clo2w8 c = error $ "pack bytes: non-natural closure: " ++ show c
bprim1 !ustk !bstk UPKB i = do
b <- peekOffBi bstk i
bstk <- bump bstk
pokeS bstk . Sq.fromList . fmap (DataU1 natDTag . fromEnum)
pokeS bstk . Sq.fromList . fmap (DataU1 Rf.natRef 0 . fromEnum)
$ By.toWord8s b
pure (ustk, bstk)
bprim1 !ustk !bstk SIZB i = do
@ -1210,7 +1194,7 @@ yield !env !denv !ustk !bstk !k = leap denv k
leap !denv0 (Mark ps cs k) = do
let denv = cs <> EC.withoutKeys denv0 ps
clo = denv0 EC.! EC.findMin ps
poke bstk . DataB1 0 =<< peek bstk
poke bstk . DataB1 Rf.effectRef 0 =<< peek bstk
apply env denv ustk bstk k False (BArg1 0) clo
leap !denv (Push ufsz bfsz uasz basz nx k) = do
ustk <- restoreFrame ustk ufsz uasz
@ -1271,10 +1255,22 @@ discardCont denv ustk bstk k p
{-# inline discardCont #-}
resolve :: SEnv -> DEnv -> Stack 'BX -> Ref -> IO Closure
resolve env _ _ (Env i) = case EC.lookup i (combs env) of
Just cmb -> return $ PAp (IC i cmb) unull bnull
_ -> die $ "resolve: looked up unknown combinator: " ++ show i
resolve env _ _ (Env n i)
| Just r <- EC.lookup n $ combRefs env
= pure $ PAp (CIx r n i) unull bnull
| otherwise = die $ "resolve: missing reference for comb: " ++ show n
resolve _ _ bstk (Stk i) = peekOff bstk i
resolve _ denv _ (Dyn i) = case EC.lookup i denv of
Just clo -> pure clo
_ -> die $ "resolve: looked up bad dynamic: " ++ show i
combSection :: SEnv -> CombIx -> Comb
combSection env (CIx _ n i)
= case EC.lookup n (combs env) of
Just cmbs -> case EC.lookup i cmbs of
Just cmb -> cmb
Nothing -> error $ "unknown section `" ++ show i
++ "` of combinator `" ++ show n ++ "`."
Nothing -> error $ "unknown combinator `" ++ show n ++ "`."

2
parser-typechecker/src/Unison/Runtime/Rt1IO.hs
View File

@ -456,7 +456,7 @@ lamToHask cenv s ir val = RT.run (handleIO' cenv s) cenv $ task val
where task x = IR.Let (Var.named "_") (IR.Leaf (IR.Val x)) ir mempty
runtime :: Runtime Symbol
runtime = Runtime terminate eval (nullaryMain External)
runtime = Runtime terminate eval (nullaryMain External) True
where
terminate :: IO ()
terminate = pure ()

109
parser-typechecker/src/Unison/Runtime/Stack.hs
View File

@ -8,7 +8,7 @@
module Unison.Runtime.Stack
( K(..)
, IComb(.., Lam_)
, CombIx(..)
, Closure(.., DataC, PApV, CapV)
, Callback(..)
, Augment(..)
@ -37,6 +37,7 @@ module Unison.Runtime.Stack
, peekOffS
, pokeS
, pokeOffS
, frameView
, uscount
, bscount
) where
@ -59,7 +60,7 @@ import Data.Word
import Unison.Reference (Reference)
import Unison.Runtime.ANF (Mem(..), unpackTags, RTag)
import Unison.Runtime.ANF (Mem(..))
import Unison.Runtime.MCode
import Unison.Runtime.Foreign
@ -92,44 +93,36 @@ data K
!K
deriving (Eq, Ord)
-- Comb with an identifier
data IComb
= IC !Word64 !Comb
deriving (Show)
instance Eq IComb where
IC i _ == IC j _ = i == j
pattern Lam_ ua ba uf bf entry <- IC _ (Lam ua ba uf bf entry)
-- TODO: more reliable ordering for combinators
instance Ord IComb where
compare (IC i _) (IC j _) = compare i j
data CombIx
= CIx !Reference -- top reference
!Word64 -- top level
!Word64 -- section
deriving (Eq, Ord, Show)
data Closure
= PAp {-# unpack #-} !IComb -- code
= PAp {-# unpack #-} !CombIx -- reference
{-# unpack #-} !(Seg 'UN) -- unboxed args
{- unpack -} !(Seg 'BX) -- boxed args
| Enum !Word64
| DataU1 !Word64 !Int
| DataU2 !Word64 !Int !Int
| DataB1 !Word64 !Closure
| DataB2 !Word64 !Closure !Closure
| DataUB !Word64 !Int !Closure
| DataG !Word64 !(Seg 'UN) !(Seg 'BX)
| Enum !Reference !Word64
| DataU1 !Reference !Word64 !Int
| DataU2 !Reference !Word64 !Int !Int
| DataB1 !Reference !Word64 !Closure
| DataB2 !Reference !Word64 !Closure !Closure
| DataUB !Reference !Word64 !Int !Closure
| DataG !Reference !Word64 !(Seg 'UN) !(Seg 'BX)
| Captured !K {-# unpack #-} !(Seg 'UN) !(Seg 'BX)
| Foreign !Foreign
| BlackHole
deriving (Show, Eq, Ord)
splitData :: Closure -> Maybe (Word64, [Int], [Closure])
splitData (Enum t) = Just (t, [], [])
splitData (DataU1 t i) = Just (t, [i], [])
splitData (DataU2 t i j) = Just (t, [i,j], [])
splitData (DataB1 t x) = Just (t, [], [x])
splitData (DataB2 t x y) = Just (t, [], [x,y])
splitData (DataUB t i y) = Just (t, [i], [y])
splitData (DataG t us bs) = Just (t, ints us, toList bs)
splitData :: Closure -> Maybe (Reference, Word64, [Int], [Closure])
splitData (Enum r t) = Just (r, t, [], [])
splitData (DataU1 r t i) = Just (r, t, [i], [])
splitData (DataU2 r t i j) = Just (r, t, [i,j], [])
splitData (DataB1 r t x) = Just (r, t, [], [x])
splitData (DataB2 r t x y) = Just (r, t, [], [x,y])
splitData (DataUB r t i y) = Just (r, t, [i], [y])
splitData (DataG r t us bs) = Just (r, t, ints us, toList bs)
splitData _ = Nothing
ints :: ByteArray -> [Int]
@ -137,8 +130,8 @@ ints ba = fmap (indexByteArray ba) [0..n-1]
where
n = sizeofByteArray ba `div` 8
pattern DataC rt ct us bs <-
(splitData -> Just (unpackTags -> (rt, ct), us, bs))
pattern DataC rf ct us bs <-
(splitData -> Just (rf, ct, us, bs))
pattern PApV ic us bs <- PAp ic (ints -> us) (toList -> bs)
pattern CapV k us bs <- Captured k (ints -> us) (toList -> bs)
@ -155,35 +148,33 @@ closureNum Foreign{} = 3
closureNum BlackHole{} = error "BlackHole"
universalCompare
:: (Word64 -> Reference)
-> (RTag -> Reference)
-> (Foreign -> Foreign -> Ordering)
:: (Foreign -> Foreign -> Ordering)
-> Closure
-> Closure
-> Ordering
universalCompare comb tag frn = cmpc
universalCompare frn = cmpc False
where
cmpl cm l r
= compare (length l) (length r) <> fold (zipWith cm l r)
cmpc (DataC rt1 ct1 us1 bs1) (DataC rt2 ct2 us2 bs2)
= compare (tag rt1) (tag rt2)
cmpc tyEq (DataC rf1 ct1 us1 bs1) (DataC rf2 ct2 us2 bs2)
= (if tyEq then compare rf1 rf2 else EQ)
<> compare ct1 ct2
<> cmpl compare us1 us2
<> cmpl cmpc bs1 bs2
cmpc (PApV (IC i1 _) us1 bs1) (PApV (IC i2 _) us2 bs2)
= compare (comb i1) (comb i2)
<> cmpl (cmpc tyEq) bs1 bs2
cmpc tyEq (PApV i1 us1 bs1) (PApV i2 us2 bs2)
= compare i1 i2
<> cmpl compare us1 us2
<> cmpl cmpc bs1 bs2
cmpc (CapV k1 us1 bs1) (CapV k2 us2 bs2)
<> cmpl (cmpc tyEq) bs1 bs2
cmpc _ (CapV k1 us1 bs1) (CapV k2 us2 bs2)
= compare k1 k2
<> cmpl compare us1 us2
<> cmpl cmpc bs1 bs2
cmpc (Foreign fl) (Foreign fr)
<> cmpl (cmpc True) bs1 bs2
cmpc tyEq (Foreign fl) (Foreign fr)
| Just sl <- maybeUnwrapForeign Ty.vectorRef fl
, Just sr <- maybeUnwrapForeign Ty.vectorRef fr
= comparing Sq.length sl sr <> fold (Sq.zipWith cmpc sl sr)
= comparing Sq.length sl sr <> fold (Sq.zipWith (cmpc tyEq) sl sr)
| otherwise = frn fl fr
cmpc c d = comparing closureNum c d
cmpc _ c d = comparing closureNum c d
marshalToForeign :: HasCallStack => Closure -> Foreign
marshalToForeign (Foreign x) = x
@ -402,7 +393,7 @@ instance MEM 'UN where
augSeg mode (US ap fp sp stk) seg margs = do
cop <- newByteArray $ ssz+psz+asz
copyByteArray cop soff seg 0 ssz
copyMutableByteArray cop 0 stk ap psz
copyMutableByteArray cop 0 stk (bytes $ ap+1) psz
for_ margs $ uargOnto stk sp cop (words poff + pix - 1)
unsafeFreezeByteArray cop
where
@ -600,7 +591,7 @@ instance MEM 'BX where
augSeg mode (BS ap fp sp stk) seg margs = do
cop <- newArray (ssz+psz+asz) BlackHole
copyArray cop soff seg 0 ssz
copyMutableArray cop poff stk ap psz
copyMutableArray cop poff stk (ap+1) psz
for_ margs $ bargOnto stk sp cop (poff+psz-1)
unsafeFreezeArray cop
where
@ -632,6 +623,24 @@ instance MEM 'BX where
asize (BS ap fp _ _) = fp-ap
frameView :: MEM b => Show (Elem b) => Stack b -> IO ()
frameView stk = putStr "|" >> gof False 0
where
fsz = fsize stk
asz = asize stk
gof delim n
| n >= fsz = putStr "|" >> goa False 0
| otherwise = do
when delim $ putStr ","
putStr . show =<< peekOff stk n
gof True (n+1)
goa delim n
| n >= asz = putStrLn "|.."
| otherwise = do
when delim $ putStr ","
putStr . show =<< peekOff stk (fsz+n)
goa True (n+1)
uscount :: Seg 'UN -> Int
uscount seg = words $ sizeofByteArray seg

30
parser-typechecker/tests/Unison/Test/ANF.hs
View File

@ -9,12 +9,14 @@ import Unison.ABT.Normalized (Term(TAbs))
import qualified Unison.Pattern as P
import Unison.Reference (Reference)
import Unison.Runtime.ANF as ANF
import Unison.Runtime.MCode (emitCombs)
import Unison.Runtime.MCode (emitCombs, RefNums(..))
import Unison.Type as Ty
import Unison.Var as Var
import Unison.Util.EnumContainers as EC
import Data.Word (Word64)
import qualified Data.Set as Set
import qualified Data.Map as Map
@ -41,9 +43,7 @@ simpleRefs r
| otherwise = 100
runANF :: Var v => ANFM v a -> a
runANF m = evalState (runReaderT m env) (0, [])
where
env = (Set.empty, const 0, simpleRefs)
runANF m = evalState (runReaderT m Set.empty) (0, [])
testANF :: String -> Test ()
testANF s
@ -54,9 +54,12 @@ testANF s
anf = runANF $ anfTerm t0
testLift :: String -> Test ()
testLift s = case cs of (!_, !_, _) -> ok
testLift s = case cs of !_ -> ok
where
cs = emitCombs 0 . superNormalize (const 0) (const 0) . lamLift $ tm s
cs = emitCombs (RN (const 0) (const 0)) 0
. superNormalize
. lamLift
$ tm s
denormalize :: Var v => ANormal v -> Term.Term0 v
denormalize (TVar v) = Term.var () v
@ -84,8 +87,7 @@ denormalize (TName _ _ _ _)
denormalize (TMatch v cs)
= Term.match () (ABT.var v) $ denormalizeMatch cs
denormalize (TApp f args)
| FCon rt 0 <- f
, r <- denormalizeRef rt
| FCon r 0 <- f
, r `elem` [Ty.natRef, Ty.intRef]
, [v] <- args
= Term.var () v
@ -95,9 +97,9 @@ denormalize (TApp f args) = Term.apps' df (Term.var () <$> args)
FVar v -> Term.var () v
FComb _ -> error "FComb"
FCon r n ->
Term.constructor () (denormalizeRef r) (fromIntegral $ rawTag n)
Term.constructor () r (fromIntegral $ rawTag n)
FReq r n ->
Term.request () (denormalizeRef r) (fromIntegral $ rawTag n)
Term.request () r (fromIntegral $ rawTag n)
FPrim _ -> error "FPrim"
FCont _ -> error "denormalize FCont"
denormalize (TFrc _) = error "denormalize TFrc"
@ -112,7 +114,7 @@ denormalizeRef r
| 5 <- rawTag r = Ty.charRef
| otherwise = error "denormalizeRef"
backReference :: RTag -> Reference
backReference :: Word64 -> Reference
backReference _ = error "backReference"
denormalizeMatch
@ -151,19 +153,19 @@ denormalizeBranch tm = (0, denormalize tm)
denormalizeHandler
:: Var v
=> EnumMap RTag (EnumMap CTag ([Mem], ANormal v))
=> Map.Map Reference (EnumMap CTag ([Mem], ANormal v))
-> ANormal v
-> [Term.MatchCase () (Term.Term0 v)]
denormalizeHandler cs df = dcs
where
dcs = foldMapWithKey rf cs <> dfc
dcs = Map.foldMapWithKey rf cs <> dfc
dfc = [ Term.MatchCase
(P.EffectPure () (P.Var ()))
Nothing
db
]
where (_, db) = denormalizeBranch df
rf r rcs = foldMapWithKey (cf $ backReference r) rcs
rf r rcs = foldMapWithKey (cf r) rcs
cf r t b = [ Term.MatchCase
(P.EffectBind () r (fromEnum t)
(replicate n $ P.Var ()) (P.Var ()))

49
parser-typechecker/tests/Unison/Test/MCode.hs
View File

@ -26,7 +26,9 @@ import Unison.Runtime.MCode
, Instr(..)
, Args(..)
, Comb(..)
, Combs
, Branch(..)
, RefNums(..)
, emitComb
, emitCombs
)
@ -36,9 +38,12 @@ import Unison.Runtime.Machine
import Unison.Test.Common (tm)
testEval0 :: EnumMap Word64 Comb -> Section -> Test ()
dummyRef :: Reference
dummyRef = Builtin "dummy"
testEval0 :: EnumMap Word64 Combs -> Section -> Test ()
testEval0 env sect = do
io $ eval0 (SEnv env builtinForeigns mempty mempty) sect
io $ eval0 (SEnv env builtinForeigns (dummyRef <$ env) mempty) sect
ok
builtins :: Reference -> Word64
@ -47,11 +52,14 @@ builtins r
| Just i <- Map.lookup r builtinTermNumbering = i
| otherwise = error $ "builtins: " ++ show r
cenv :: EnumMap Word64 Comb
cenv = fmap (emitComb mempty) $ numberedTermLookup @Symbol
cenv :: EnumMap Word64 Combs
cenv = fmap (mapSingleton 0 . emitComb numbering 0 mempty)
$ numberedTermLookup @Symbol
env :: EnumMap Word64 Comb -> EnumMap Word64 Comb
env m = m <> mapInsert (bit 64) (Lam 0 1 2 1 asrt) cenv
env :: Combs -> EnumMap Word64 Combs
env m = mapInsert (bit 24) m
. mapInsert (bit 64) (mapSingleton 0 $ Lam 0 1 2 1 asrt)
$ cenv
asrt :: Section
asrt = Ins (Unpack 0)
@ -68,17 +76,18 @@ multRec
\ _ -> f (##Nat.+ acc n) (##Nat.sub i 1)\n\
\ ##todo (##Nat.== (f 0 1000) 5000)"
dataSpec :: DataSpec
dataSpec = mempty
numbering :: RefNums
numbering = RN (builtinTypeNumbering Map.!) builtins
testEval :: String -> Test ()
testEval s = testEval0 (env aux) main
where
(Lam 0 0 _ _ main, aux, _)
= emitCombs (bit 24)
. superNormalize builtins (builtinTypeNumbering Map.!)
Lam 0 0 _ _ main = aux ! 0
aux
= emitCombs numbering (bit 24)
. superNormalize
. lamLift
. splitPatterns dataSpec
. splitPatterns builtinDataSpec
. unannotate
$ tm s
@ -90,6 +99,20 @@ nested
\ m@n -> n\n\
\ ##todo (##Nat.== x 2)"
matching'arguments :: String
matching'arguments
= "let\n\
\ f x y z = y\n\
\ g x = f x\n\
\ blorf = let\n\
\ a = 0\n\
\ b = 1\n\
\ d = 2\n\
\ h = g a b\n\
\ c = 2\n\
\ h c\n\
\ ##todo (##Nat.== blorf 1)"
test :: Test ()
test = scope "mcode" . tests $
[ scope "2=2" $ testEval "##todo (##Nat.== 2 2)"
@ -102,4 +125,6 @@ test = scope "mcode" . tests $
, scope "5*1000=5000 rec" $ testEval multRec
, scope "nested"
$ testEval nested
, scope "matching arguments"
$ testEval matching'arguments
]

5
parser-typechecker/tests/Unison/Test/UnisonSources.hs
View File

@ -3,6 +3,7 @@
module Unison.Test.UnisonSources where
import Control.Exception (throwIO)
import Control.Lens ( view )
import Control.Lens.Tuple ( _5 )
import Control.Monad (void)
@ -37,6 +38,7 @@ import Unison.Test.Common (parseAndSynthesizeAsFile, parsingEnv)
import Unison.Type ( Type )
import qualified Unison.UnisonFile as UF
import Unison.Util.Monoid (intercalateMap)
import Unison.Util.Pretty (toPlain)
import qualified Unison.Var as Var
import qualified Unison.Test.Common as Common
import qualified Unison.Names3
@ -137,7 +139,8 @@ resultTest rt uf filepath = do
values <- io $ unpack <$> Data.Text.IO.readFile valueFile
let untypedFile = UF.discardTypes uf
let term = Parsers.parseTerm values parsingEnv
(bindings, watches) <- io $ either undefined id <$>
let report e = throwIO (userError $ toPlain 10000 e)
(bindings, watches) <- io $ either report pure =<<
evaluateWatches Builtin.codeLookup
mempty
(const $ pure Nothing)

3
unison-core/src/Unison/Term.hs
View File

@ -961,6 +961,9 @@ hashComponents
:: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a)
hashComponents = ReferenceUtil.hashComponents $ refId ()
hashClosedTerm :: Var v => Term v a -> Reference.Id
hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1
-- The hash for a constructor
hashConstructor'
:: (Reference -> ConstructorId -> Term0 Symbol) -> Reference -> ConstructorId -> Reference