mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-22 07:48:10 +03:00
Merge remote-tracking branch 'origin/trunk' into topic/hashing
This commit is contained in:
commit
1447b0a2cd
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -14,9 +14,6 @@ module Unison.Runtime.Builtin
|
||||
, builtinTypeBackref
|
||||
, builtinForeigns
|
||||
, numberedTermLookup
|
||||
, charTag
|
||||
, natTag
|
||||
, eitherTag
|
||||
) where
|
||||
|
||||
import Control.Exception (IOException, try)
|
||||
@ -115,22 +112,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
|
||||
@ -176,7 +160,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
|
||||
@ -191,7 +175,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
|
||||
@ -343,8 +327,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
|
||||
@ -372,7 +356,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]
|
||||
@ -384,24 +368,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
|
||||
@ -418,13 +402,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 []
|
||||
|
||||
@ -432,14 +416,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
|
||||
@ -490,15 +474,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]
|
||||
|
||||
@ -517,26 +501,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
|
||||
@ -548,39 +532,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]
|
||||
@ -604,7 +588,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]
|
||||
@ -613,7 +597,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
|
||||
@ -638,8 +622,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
|
||||
@ -651,7 +635,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))
|
||||
]
|
||||
|
||||
@ -663,7 +647,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
|
||||
@ -672,7 +656,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
|
||||
@ -681,7 +665,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
|
||||
@ -756,7 +740,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
|
||||
|
||||
@ -767,23 +751,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
|
||||
@ -851,7 +835,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
|
||||
|
||||
@ -859,7 +843,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
|
||||
|
||||
@ -867,7 +851,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
|
||||
|
||||
@ -945,7 +929,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
|
||||
|
||||
@ -954,7 +938,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
|
||||
|
||||
@ -1024,8 +1008,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
|
||||
@ -1482,7 +1466,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 ]
|
||||
@ -1501,10 +1485,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..])
|
||||
@ -1513,10 +1493,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)
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -21,11 +21,10 @@ import Unison.Type
|
||||
import Unison.Var (Var)
|
||||
import Unison.Reference (Reference)
|
||||
|
||||
import Unison.Runtime.ANF (RTag, CTag, Tag(..))
|
||||
import Unison.Runtime.Foreign
|
||||
(Foreign, HashAlgorithm(..), 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)
|
||||
@ -34,47 +33,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
|
||||
@ -87,7 +83,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
|
||||
@ -98,17 +94,16 @@ 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 h <- maybeUnwrapBuiltin f = Right $ decompileHashAlgorithm h
|
||||
| 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
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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
|
||||
|
@ -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 ++ "`."
|
||||
|
||||
|
||||
|
@ -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 ()
|
||||
|
@ -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
|
||||
|
||||
|
@ -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 ()))
|
||||
|
@ -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
|
||||
]
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user